source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 141       if (ipot.lt.6) then
 142 #ifdef SPLITELE
 143          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 144      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 145      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 146      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 147 #else
 148          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 149      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 150      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 151      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 152 #endif
 153             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 154          else
 155             ees=0.0d0
 156             evdw1=0.0d0
 157             eel_loc=0.0d0
 158             eello_turn3=0.0d0
 159             eello_turn4=0.0d0
 160          endif
 161       else
 162         write (iout,*) "Soft-spheer ELEC potential"
 163         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164      &   eello_turn4)
 165       endif
 166 c      print *,"Processor",myrank," computed UELEC"
 167 C
 168 C Calculate excluded-volume interaction energy between peptide groups
 169 C and side chains.
 170 C
 171       if (ipot.lt.6) then
 172        if(wscp.gt.0d0) then
 173         call escp(evdw2,evdw2_14)
 174        else
 175         evdw2=0
 176         evdw2_14=0
 177        endif
 178       else
 179 c        write (iout,*) "Soft-sphere SCP potential"
 180         call escp_soft_sphere(evdw2,evdw2_14)
 181       endif
 182 c
 183 c Calculate the bond-stretching energy
 184 c
 185       call ebond(estr)
 186 C
 187 C Calculate the disulfide-bridge and other energy and the contributions
 188 C from other distance constraints.
 189 cd    print *,'Calling EHPB'
 190       call edis(ehpb)
 191 cd    print *,'EHPB exitted succesfully.'
 192 C
 193 C Calculate the virtual-bond-angle energy.
 194 C
 195       if (wang.gt.0d0) then
 196         call ebend(ebe)
 197       else
 198         ebe=0
 199       endif
 200 c      print *,"Processor",myrank," computed UB"
 201 C
 202 C Calculate the SC local energy.
 203 C
 204 C      print *,"TU DOCHODZE?"
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217
 218       if (constr_homology.ge.1) then
 219         call e_modeller(ehomology_constr)
 220 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 221 c     &  'Processor',fg_rank,' CG group',kolor,
 222 c     &  ' absolute rank',MyRank
 223       else
 224         ehomology_constr=0.0d0
 225       endif
 226
 227
 228 c      write(iout,*) ehomology_constr
 229 c      print *,"Processor",myrank," computed Utor"
 230 C
 231 C 6/23/01 Calculate double-torsional energy
 232 C
 233       if (wtor_d.gt.0) then
 234        call etor_d(etors_d)
 235       else
 236        etors_d=0
 237       endif
 238 c      print *,"Processor",myrank," computed Utord"
 239 C
 240 C 21/5/07 Calculate local sicdechain correlation energy
 241 C
 242       if (wsccor.gt.0.0d0) then
 243         call eback_sc_corr(esccor)
 244       else
 245         esccor=0.0d0
 246       endif
 247 C      print *,"PRZED MULIt"
 248 c      print *,"Processor",myrank," computed Usccorr"
 249 C
 250 C 12/1/95 Multi-body terms
 251 C
 252       n_corr=0
 253       n_corr1=0
 254       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 255      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 256          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 257 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 258 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 259       else
 260          ecorr=0.0d0
 261          ecorr5=0.0d0
 262          ecorr6=0.0d0
 263          eturn6=0.0d0
 264       endif
 265       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 266          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 267 cd         write (iout,*) "multibody_hb ecorr",ecorr
 268       endif
 269 c      print *,"Processor",myrank," computed Ucorr"
 270 C
 271 C If performing constraint dynamics, call the constraint energy
 272 C  after the equilibration time
 273       if(usampl.and.totT.gt.eq_time) then
 274          call EconstrQ
 275          call Econstr_back
 276       else
 277          Uconst=0.0d0
 278          Uconst_back=0.0d0
 279       endif
 280 C 01/27/2015 added by adasko
 281 C the energy component below is energy transfer into lipid environment
 282 C based on partition function
 283 C      print *,"przed lipidami"
 284       if (wliptran.gt.0) then
 285         call Eliptransfer(eliptran)
 286       endif
 287 C      print *,"za lipidami"
 288       if (AFMlog.gt.0) then
 289         call AFMforce(Eafmforce)
 290       else if (selfguide.gt.0) then
 291         call AFMvel(Eafmforce)
 292       endif
 293 #ifdef TIMING
 294       time_enecalc=time_enecalc+MPI_Wtime()-time00
 295 #endif
 296 c      print *,"Processor",myrank," computed Uconstr"
 297 #ifdef TIMING
 298       time00=MPI_Wtime()
 299 #endif
 300 c
 301 C Sum the energies
 302 C
 303       energia(1)=evdw
 304 #ifdef SCP14
 305       energia(2)=evdw2-evdw2_14
 306       energia(18)=evdw2_14
 307 #else
 308       energia(2)=evdw2
 309       energia(18)=0.0d0
 310 #endif
 311 #ifdef SPLITELE
 312       energia(3)=ees
 313       energia(16)=evdw1
 314 #else
 315       energia(3)=ees+evdw1
 316       energia(16)=0.0d0
 317 #endif
 318       energia(4)=ecorr
 319       energia(5)=ecorr5
 320       energia(6)=ecorr6
 321       energia(7)=eel_loc
 322       energia(8)=eello_turn3
 323       energia(9)=eello_turn4
 324       energia(10)=eturn6
 325       energia(11)=ebe
 326       energia(12)=escloc
 327       energia(13)=etors
 328       energia(14)=etors_d
 329       energia(15)=ehpb
 330       energia(19)=edihcnstr
 331       energia(17)=estr
 332       energia(20)=Uconst+Uconst_back
 333       energia(21)=esccor
 334       energia(22)=eliptran
 335       energia(23)=Eafmforce
 336       energia(24)=ehomology_constr
 337 c    Here are the energies showed per procesor if the are more processors
 338 c    per molecule then we sum it up in sum_energy subroutine
 339 c      print *," Processor",myrank," calls SUM_ENERGY"
 340       call sum_energy(energia,.true.)
 341       if (dyn_ss) call dyn_set_nss
 342 c      print *," Processor",myrank," left SUM_ENERGY"
 343 #ifdef TIMING
 344       time_sumene=time_sumene+MPI_Wtime()-time00
 345 #endif
 346       return
 347       end
 348 c-------------------------------------------------------------------------------
 349       subroutine sum_energy(energia,reduce)
 350       implicit real*8 (a-h,o-z)
 351       include 'DIMENSIONS'
 352 #ifndef ISNAN
 353       external proc_proc
 354 #ifdef WINPGI
 355 cMS$ATTRIBUTES C ::  proc_proc
 356 #endif
 357 #endif
 358 #ifdef MPI
 359       include "mpif.h"
 360 #endif
 361       include 'COMMON.SETUP'
 362       include 'COMMON.IOUNITS'
 363       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 364       include 'COMMON.FFIELD'
 365       include 'COMMON.DERIV'
 366       include 'COMMON.INTERACT'
 367       include 'COMMON.SBRIDGE'
 368       include 'COMMON.CHAIN'
 369       include 'COMMON.VAR'
 370       include 'COMMON.CONTROL'
 371       include 'COMMON.TIME1'
 372       logical reduce
 373 #ifdef MPI
 374       if (nfgtasks.gt.1 .and. reduce) then
 375 #ifdef DEBUG
 376         write (iout,*) "energies before REDUCE"
 377         call enerprint(energia)
 378         call flush(iout)
 379 #endif
 380         do i=0,n_ene
 381           enebuff(i)=energia(i)
 382         enddo
 383         time00=MPI_Wtime()
 384         call MPI_Barrier(FG_COMM,IERR)
 385         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 386         time00=MPI_Wtime()
 387         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 388      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 389 #ifdef DEBUG
 390         write (iout,*) "energies after REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         time_Reduce=time_Reduce+MPI_Wtime()-time00
 395       endif
 396       if (fg_rank.eq.0) then
 397 #endif
 398       evdw=energia(1)
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428       eliptran=energia(22)
 429       Eafmforce=energia(23)
 430       ehomology_constr=energia(24)
 431 #ifdef SPLITELE
 432       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 433      & +wang*ebe+wtor*etors+wscloc*escloc
 434      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 435      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 436      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 437      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 438      & +wliptran*eliptran+Eafmforce
 439 #else
 440       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 441      & +wang*ebe+wtor*etors+wscloc*escloc
 442      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 443      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 444      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 445      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 446      & +wliptran*eliptran
 447      & +Eafmforce
 448 #endif
 449       energia(0)=etot
 450 c detecting NaNQ
 451 #ifdef ISNAN
 452 #ifdef AIX
 453       if (isnan(etot).ne.0) energia(0)=1.0d+99
 454 #else
 455       if (isnan(etot)) energia(0)=1.0d+99
 456 #endif
 457 #else
 458       i=0
 459 #ifdef WINPGI
 460       idumm=proc_proc(etot,i)
 461 #else
 462       call proc_proc(etot,i)
 463 #endif
 464       if(i.eq.1)energia(0)=1.0d+99
 465 #endif
 466 #ifdef MPI
 467       endif
 468 #endif
 469       return
 470       end
 471 c-------------------------------------------------------------------------------
 472       subroutine sum_gradient
 473       implicit real*8 (a-h,o-z)
 474       include 'DIMENSIONS'
 475 #ifndef ISNAN
 476       external proc_proc
 477 #ifdef WINPGI
 478 cMS$ATTRIBUTES C ::  proc_proc
 479 #endif
 480 #endif
 481 #ifdef MPI
 482       include 'mpif.h'
 483 #endif
 484       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 485      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 486      & ,gloc_scbuf(3,-1:maxres)
 487       include 'COMMON.SETUP'
 488       include 'COMMON.IOUNITS'
 489       include 'COMMON.FFIELD'
 490       include 'COMMON.DERIV'
 491       include 'COMMON.INTERACT'
 492       include 'COMMON.SBRIDGE'
 493       include 'COMMON.CHAIN'
 494       include 'COMMON.VAR'
 495       include 'COMMON.CONTROL'
 496       include 'COMMON.TIME1'
 497       include 'COMMON.MAXGRAD'
 498       include 'COMMON.SCCOR'
 499       include 'COMMON.MD'
 500 #ifdef TIMING
 501       time01=MPI_Wtime()
 502 #endif
 503 #ifdef DEBUG
 504       write (iout,*) "sum_gradient gvdwc, gvdwx"
 505       do i=1,nres
 506         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 507      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 508       enddo
 509       call flush(iout)
 510 #endif
 511 #ifdef MPI
 512 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 513         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 514      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 515 #endif
 516 C
 517 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 518 C            in virtual-bond-vector coordinates
 519 C
 520 #ifdef DEBUG
 521 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 522 c      do i=1,nres-1
 523 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 524 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 525 c      enddo
 526 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 527 c      do i=1,nres-1
 528 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 529 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 530 c      enddo
 531       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 534      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 535      &   g_corr5_loc(i)
 536       enddo
 537       call flush(iout)
 538 #endif
 539 #ifdef SPLITELE
 540       do i=0,nct
 541         do j=1,3
 542           gradbufc(j,i)=wsc*gvdwc(j,i)+
 543      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 544      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 545      &                wel_loc*gel_loc_long(j,i)+
 546      &                wcorr*gradcorr_long(j,i)+
 547      &                wcorr5*gradcorr5_long(j,i)+
 548      &                wcorr6*gradcorr6_long(j,i)+
 549      &                wturn6*gcorr6_turn_long(j,i)+
 550      &                wstrain*ghpbc(j,i)
 551      &                +wliptran*gliptranc(j,i)
 552      &                +gradafm(j,i)
 553
 554         enddo
 555       enddo
 556 #else
 557       do i=0,nct
 558         do j=1,3
 559           gradbufc(j,i)=wsc*gvdwc(j,i)+
 560      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 561      &                welec*gelc_long(j,i)+
 562      &                wbond*gradb(j,i)+
 563      &                wel_loc*gel_loc_long(j,i)+
 564      &                wcorr*gradcorr_long(j,i)+
 565      &                wcorr5*gradcorr5_long(j,i)+
 566      &                wcorr6*gradcorr6_long(j,i)+
 567      &                wturn6*gcorr6_turn_long(j,i)+
 568      &                wstrain*ghpbc(j,i)
 569      &                +wliptran*gliptranc(j,i)
 570      &                +gradafm(j,i)
 571
 572         enddo
 573       enddo
 574 #endif
 575 #ifdef MPI
 576       if (nfgtasks.gt.1) then
 577       time00=MPI_Wtime()
 578 #ifdef DEBUG
 579       write (iout,*) "gradbufc before allreduce"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 582       enddo
 583       call flush(iout)
 584 #endif
 585       do i=0,nres
 586         do j=1,3
 587           gradbufc_sum(j,i)=gradbufc(j,i)
 588         enddo
 589       enddo
 590 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 591 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 592 c      time_reduce=time_reduce+MPI_Wtime()-time00
 593 #ifdef DEBUG
 594 c      write (iout,*) "gradbufc_sum after allreduce"
 595 c      do i=1,nres
 596 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 597 c      enddo
 598 c      call flush(iout)
 599 #endif
 600 #ifdef TIMING
 601 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 602 #endif
 603       do i=nnt,nres
 604         do k=1,3
 605           gradbufc(k,i)=0.0d0
 606         enddo
 607       enddo
 608 #ifdef DEBUG
 609       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 610       write (iout,*) (i," jgrad_start",jgrad_start(i),
 611      &                  " jgrad_end  ",jgrad_end(i),
 612      &                  i=igrad_start,igrad_end)
 613 #endif
 614 c
 615 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 616 c do not parallelize this part.
 617 c
 618 c      do i=igrad_start,igrad_end
 619 c        do j=jgrad_start(i),jgrad_end(i)
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625       do j=1,3
 626         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 627       enddo
 628       do i=nres-2,-1,-1
 629         do j=1,3
 630           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 631         enddo
 632       enddo
 633 #ifdef DEBUG
 634       write (iout,*) "gradbufc after summing"
 635       do i=1,nres
 636         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640       else
 641 #endif
 642 #ifdef DEBUG
 643       write (iout,*) "gradbufc"
 644       do i=1,nres
 645         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 646       enddo
 647       call flush(iout)
 648 #endif
 649       do i=-1,nres
 650         do j=1,3
 651           gradbufc_sum(j,i)=gradbufc(j,i)
 652           gradbufc(j,i)=0.0d0
 653         enddo
 654       enddo
 655       do j=1,3
 656         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 657       enddo
 658       do i=nres-2,-1,-1
 659         do j=1,3
 660           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 661         enddo
 662       enddo
 663 c      do i=nnt,nres-1
 664 c        do k=1,3
 665 c          gradbufc(k,i)=0.0d0
 666 c        enddo
 667 c        do j=i+1,nres
 668 c          do k=1,3
 669 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 670 c          enddo
 671 c        enddo
 672 c      enddo
 673 #ifdef DEBUG
 674       write (iout,*) "gradbufc after summing"
 675       do i=1,nres
 676         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 677       enddo
 678       call flush(iout)
 679 #endif
 680 #ifdef MPI
 681       endif
 682 #endif
 683       do k=1,3
 684         gradbufc(k,nres)=0.0d0
 685       enddo
 686       do i=-1,nct
 687         do j=1,3
 688 #ifdef SPLITELE
 689           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 690      &                wel_loc*gel_loc(j,i)+
 691      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 692      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 693      &                wel_loc*gel_loc_long(j,i)+
 694      &                wcorr*gradcorr_long(j,i)+
 695      &                wcorr5*gradcorr5_long(j,i)+
 696      &                wcorr6*gradcorr6_long(j,i)+
 697      &                wturn6*gcorr6_turn_long(j,i))+
 698      &                wbond*gradb(j,i)+
 699      &                wcorr*gradcorr(j,i)+
 700      &                wturn3*gcorr3_turn(j,i)+
 701      &                wturn4*gcorr4_turn(j,i)+
 702      &                wcorr5*gradcorr5(j,i)+
 703      &                wcorr6*gradcorr6(j,i)+
 704      &                wturn6*gcorr6_turn(j,i)+
 705      &                wsccor*gsccorc(j,i)
 706      &               +wscloc*gscloc(j,i)
 707      &               +wliptran*gliptranc(j,i)
 708      &                +gradafm(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i) +
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728      &               +wliptran*gliptranc(j,i)
 729      &                +gradafm(j,i)
 730
 731 #endif
 732           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 733      &                  wbond*gradbx(j,i)+
 734      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 735      &                  wsccor*gsccorx(j,i)
 736      &                 +wscloc*gsclocx(j,i)
 737      &                 +wliptran*gliptranx(j,i)
 738         enddo
 739       enddo
 740       if (constr_homology.gt.0) then
 741         do i=1,nct
 742           do j=1,3
 743             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 744             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 745           enddo
 746         enddo
 747       endif
 748 #ifdef DEBUG
 749       write (iout,*) "gloc before adding corr"
 750       do i=1,4*nres
 751         write (iout,*) i,gloc(i,icg)
 752       enddo
 753 #endif
 754       do i=1,nres-3
 755         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 756      &   +wcorr5*g_corr5_loc(i)
 757      &   +wcorr6*g_corr6_loc(i)
 758      &   +wturn4*gel_loc_turn4(i)
 759      &   +wturn3*gel_loc_turn3(i)
 760      &   +wturn6*gel_loc_turn6(i)
 761      &   +wel_loc*gel_loc_loc(i)
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "gloc after adding corr"
 765       do i=1,4*nres
 766         write (iout,*) i,gloc(i,icg)
 767       enddo
 768 #endif
 769 #ifdef MPI
 770       if (nfgtasks.gt.1) then
 771         do j=1,3
 772           do i=1,nres
 773             gradbufc(j,i)=gradc(j,i,icg)
 774             gradbufx(j,i)=gradx(j,i,icg)
 775           enddo
 776         enddo
 777         do i=1,4*nres
 778           glocbuf(i)=gloc(i,icg)
 779         enddo
 780 c#define DEBUG
 781 #ifdef DEBUG
 782       write (iout,*) "gloc_sc before reduce"
 783       do i=1,nres
 784        do j=1,1
 785         write (iout,*) i,j,gloc_sc(j,i,icg)
 786        enddo
 787       enddo
 788 #endif
 789 c#undef DEBUG
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         time_reduce=time_reduce+MPI_Wtime()-time00
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 c#define DEBUG
 810 #ifdef DEBUG
 811       write (iout,*) "gloc_sc after reduce"
 812       do i=1,nres
 813        do j=1,1
 814         write (iout,*) i,j,gloc_sc(j,i,icg)
 815        enddo
 816       enddo
 817 #endif
 818 c#undef DEBUG
 819 #ifdef DEBUG
 820       write (iout,*) "gloc after reduce"
 821       do i=1,4*nres
 822         write (iout,*) i,gloc(i,icg)
 823       enddo
 824 #endif
 825       endif
 826 #endif
 827       if (gnorm_check) then
 828 c
 829 c Compute the maximum elements of the gradient
 830 c
 831       gvdwc_max=0.0d0
 832       gvdwc_scp_max=0.0d0
 833       gelc_max=0.0d0
 834       gvdwpp_max=0.0d0
 835       gradb_max=0.0d0
 836       ghpbc_max=0.0d0
 837       gradcorr_max=0.0d0
 838       gel_loc_max=0.0d0
 839       gcorr3_turn_max=0.0d0
 840       gcorr4_turn_max=0.0d0
 841       gradcorr5_max=0.0d0
 842       gradcorr6_max=0.0d0
 843       gcorr6_turn_max=0.0d0
 844       gsccorc_max=0.0d0
 845       gscloc_max=0.0d0
 846       gvdwx_max=0.0d0
 847       gradx_scp_max=0.0d0
 848       ghpbx_max=0.0d0
 849       gradxorr_max=0.0d0
 850       gsccorx_max=0.0d0
 851       gsclocx_max=0.0d0
 852       do i=1,nct
 853         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 894         if (gradx_scp_norm.gt.gradx_scp_max)
 895      &    gradx_scp_max=gradx_scp_norm
 896         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 897         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 898         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 899         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 900         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 901         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 902         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 903         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 904       enddo
 905       if (gradout) then
 906 #ifdef AIX
 907         open(istat,file=statname,position="append")
 908 #else
 909         open(istat,file=statname,access="append")
 910 #endif
 911         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 912      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 913      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 914      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 915      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 916      &     gsccorx_max,gsclocx_max
 917         close(istat)
 918         if (gvdwc_max.gt.1.0d4) then
 919           write (iout,*) "gvdwc gvdwx gradb gradbx"
 920           do i=nnt,nct
 921             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 922      &        gradb(j,i),gradbx(j,i),j=1,3)
 923           enddo
 924           call pdbout(0.0d0,'cipiszcze',iout)
 925           call flush(iout)
 926         endif
 927       endif
 928       endif
 929 #ifdef DEBUG
 930       write (iout,*) "gradc gradx gloc"
 931       do i=1,nres
 932         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 933      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 934       enddo
 935 #endif
 936 #ifdef TIMING
 937       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 938 #endif
 939       return
 940       end
 941 c-------------------------------------------------------------------------------
 942       subroutine rescale_weights(t_bath)
 943       implicit real*8 (a-h,o-z)
 944       include 'DIMENSIONS'
 945       include 'COMMON.IOUNITS'
 946       include 'COMMON.FFIELD'
 947       include 'COMMON.SBRIDGE'
 948       double precision kfac /2.4d0/
 949       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 950 c      facT=temp0/t_bath
 951 c      facT=2*temp0/(t_bath+temp0)
 952       if (rescale_mode.eq.0) then
 953         facT=1.0d0
 954         facT2=1.0d0
 955         facT3=1.0d0
 956         facT4=1.0d0
 957         facT5=1.0d0
 958       else if (rescale_mode.eq.1) then
 959         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 960         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 961         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 962         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 963         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 964       else if (rescale_mode.eq.2) then
 965         x=t_bath/temp0
 966         x2=x*x
 967         x3=x2*x
 968         x4=x3*x
 969         x5=x4*x
 970         facT=licznik/dlog(dexp(x)+dexp(-x))
 971         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 972         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 973         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 974         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 975       else
 976         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 977         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 978 #ifdef MPI
 979        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 980 #endif
 981        stop 555
 982       endif
 983       welec=weights(3)*fact
 984       wcorr=weights(4)*fact3
 985       wcorr5=weights(5)*fact4
 986       wcorr6=weights(6)*fact5
 987       wel_loc=weights(7)*fact2
 988       wturn3=weights(8)*fact2
 989       wturn4=weights(9)*fact3
 990       wturn6=weights(10)*fact5
 991       wtor=weights(13)*fact
 992       wtor_d=weights(14)*fact2
 993       wsccor=weights(21)*fact
 994
 995       return
 996       end
 997 C------------------------------------------------------------------------
 998       subroutine enerprint(energia)
 999       implicit real*8 (a-h,o-z)
1000       include 'DIMENSIONS'
1001       include 'COMMON.IOUNITS'
1002       include 'COMMON.FFIELD'
1003       include 'COMMON.SBRIDGE'
1004       include 'COMMON.MD'
1005       double precision energia(0:n_ene)
1006       etot=energia(0)
1007       evdw=energia(1)
1008       evdw2=energia(2)
1009 #ifdef SCP14
1010       evdw2=energia(2)+energia(18)
1011 #else
1012       evdw2=energia(2)
1013 #endif
1014       ees=energia(3)
1015 #ifdef SPLITELE
1016       evdw1=energia(16)
1017 #endif
1018       ecorr=energia(4)
1019       ecorr5=energia(5)
1020       ecorr6=energia(6)
1021       eel_loc=energia(7)
1022       eello_turn3=energia(8)
1023       eello_turn4=energia(9)
1024       eello_turn6=energia(10)
1025       ebe=energia(11)
1026       escloc=energia(12)
1027       etors=energia(13)
1028       etors_d=energia(14)
1029       ehpb=energia(15)
1030       edihcnstr=energia(19)
1031       estr=energia(17)
1032       Uconst=energia(20)
1033       esccor=energia(21)
1034       ehomology_constr=energia(24)
1035       eliptran=energia(22)
1036       Eafmforce=energia(23)
1037 #ifdef SPLITELE
1038       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1039      &  estr,wbond,ebe,wang,
1040      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1041      &  ecorr,wcorr,
1042      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1043      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1044      &  edihcnstr,ehomology_constr, ebr*nss,
1045      &  Uconst,eliptran,wliptran,Eafmforce,etot
1046    10 format (/'Virtual-chain energies:'//
1047      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1048      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1049      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1050      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1051      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1052      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1053      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1054      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1055      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1056      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1057      & ' (SS bridges & dist. cnstr.)'/
1058      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1059      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1060      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1061      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1062      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1063      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1064      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1065      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1066      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1067      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1068      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1069      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1070      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1071      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1072      & 'ETOT=  ',1pE16.6,' (total)')
1073
1074 #else
1075       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1076      &  estr,wbond,ebe,wang,
1077      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1078      &  ecorr,wcorr,
1079      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1080      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1081      &  ehomology_constr,ebr*nss,Uconst,
1082      &  eliptran,wliptran,Eafmforc,
1083      &  etot
1084    10 format (/'Virtual-chain energies:'//
1085      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1086      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1087      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1088      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1089      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1090      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1091      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1092      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1093      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1094      & ' (SS bridges & dist. cnstr.)'/
1095      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1096      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1097      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1098      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1099      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1100      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1101      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1102      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1103      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1104      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1105      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1106      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1107      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1108      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1109      & 'ETOT=  ',1pE16.6,' (total)')
1110 #endif
1111       return
1112       end
1113 C-----------------------------------------------------------------------
1114       subroutine elj(evdw)
1115 C
1116 C This subroutine calculates the interaction energy of nonbonded side chains
1117 C assuming the LJ potential of interaction.
1118 C
1119       implicit real*8 (a-h,o-z)
1120       include 'DIMENSIONS'
1121       parameter (accur=1.0d-10)
1122       include 'COMMON.GEO'
1123       include 'COMMON.VAR'
1124       include 'COMMON.LOCAL'
1125       include 'COMMON.CHAIN'
1126       include 'COMMON.DERIV'
1127       include 'COMMON.INTERACT'
1128       include 'COMMON.TORSION'
1129       include 'COMMON.SBRIDGE'
1130       include 'COMMON.NAMES'
1131       include 'COMMON.IOUNITS'
1132       include 'COMMON.CONTACTS'
1133       dimension gg(3)
1134 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1135       evdw=0.0D0
1136       do i=iatsc_s,iatsc_e
1137         itypi=iabs(itype(i))
1138         if (itypi.eq.ntyp1) cycle
1139         itypi1=iabs(itype(i+1))
1140         xi=c(1,nres+i)
1141         yi=c(2,nres+i)
1142         zi=c(3,nres+i)
1143 C Change 12/1/95
1144         num_conti=0
1145 C
1146 C Calculate SC interaction energy.
1147 C
1148         do iint=1,nint_gr(i)
1149 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1150 cd   &                  'iend=',iend(i,iint)
1151           do j=istart(i,iint),iend(i,iint)
1152             itypj=iabs(itype(j))
1153             if (itypj.eq.ntyp1) cycle
1154             xj=c(1,nres+j)-xi
1155             yj=c(2,nres+j)-yi
1156             zj=c(3,nres+j)-zi
1157 C Change 12/1/95 to calculate four-body interactions
1158             rij=xj*xj+yj*yj+zj*zj
1159             rrij=1.0D0/rij
1160 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1161             eps0ij=eps(itypi,itypj)
1162             fac=rrij**expon2
1163 C have you changed here?
1164             e1=fac*fac*aa
1165             e2=fac*bb
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173             evdw=evdw+evdwij
1174 C
1175 C Calculate the components of the gradient in DC and X
1176 C
1177             fac=-rrij*(e1+evdwij)
1178             gg(1)=xj*fac
1179             gg(2)=yj*fac
1180             gg(3)=zj*fac
1181             do k=1,3
1182               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1183               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1184               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1185               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1186             enddo
1187 cgrad            do k=i,j-1
1188 cgrad              do l=1,3
1189 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1190 cgrad              enddo
1191 cgrad            enddo
1192 C
1193 C 12/1/95, revised on 5/20/97
1194 C
1195 C Calculate the contact function. The ith column of the array JCONT will
1196 C contain the numbers of atoms that make contacts with the atom I (of numbers
1197 C greater than I). The arrays FACONT and GACONT will contain the values of
1198 C the contact function and its derivative.
1199 C
1200 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1201 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1202 C Uncomment next line, if the correlation interactions are contact function only
1203             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1204               rij=dsqrt(rij)
1205               sigij=sigma(itypi,itypj)
1206               r0ij=rs0(itypi,itypj)
1207 C
1208 C Check whether the SC's are not too far to make a contact.
1209 C
1210               rcut=1.5d0*r0ij
1211               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1212 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1213 C
1214               if (fcont.gt.0.0D0) then
1215 C If the SC-SC distance if close to sigma, apply spline.
1216 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1217 cAdam &             fcont1,fprimcont1)
1218 cAdam           fcont1=1.0d0-fcont1
1219 cAdam           if (fcont1.gt.0.0d0) then
1220 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1221 cAdam             fcont=fcont*fcont1
1222 cAdam           endif
1223 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1224 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1225 cga             do k=1,3
1226 cga               gg(k)=gg(k)*eps0ij
1227 cga             enddo
1228 cga             eps0ij=-evdwij*eps0ij
1229 C Uncomment for AL's type of SC correlation interactions.
1230 cadam           eps0ij=-evdwij
1231                 num_conti=num_conti+1
1232                 jcont(num_conti,i)=j
1233                 facont(num_conti,i)=fcont*eps0ij
1234                 fprimcont=eps0ij*fprimcont/rij
1235                 fcont=expon*fcont
1236 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1237 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1238 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1239 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1240                 gacont(1,num_conti,i)=-fprimcont*xj
1241                 gacont(2,num_conti,i)=-fprimcont*yj
1242                 gacont(3,num_conti,i)=-fprimcont*zj
1243 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1244 cd              write (iout,'(2i3,3f10.5)')
1245 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1246               endif
1247             endif
1248           enddo      ! j
1249         enddo        ! iint
1250 C Change 12/1/95
1251         num_cont(i)=num_conti
1252       enddo          ! i
1253       do i=1,nct
1254         do j=1,3
1255           gvdwc(j,i)=expon*gvdwc(j,i)
1256           gvdwx(j,i)=expon*gvdwx(j,i)
1257         enddo
1258       enddo
1259 C******************************************************************************
1260 C
1261 C                              N O T E !!!
1262 C
1263 C To save time, the factor of EXPON has been extracted from ALL components
1264 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1265 C use!
1266 C
1267 C******************************************************************************
1268       return
1269       end
1270 C-----------------------------------------------------------------------------
1271       subroutine eljk(evdw)
1272 C
1273 C This subroutine calculates the interaction energy of nonbonded side chains
1274 C assuming the LJK potential of interaction.
1275 C
1276       implicit real*8 (a-h,o-z)
1277       include 'DIMENSIONS'
1278       include 'COMMON.GEO'
1279       include 'COMMON.VAR'
1280       include 'COMMON.LOCAL'
1281       include 'COMMON.CHAIN'
1282       include 'COMMON.DERIV'
1283       include 'COMMON.INTERACT'
1284       include 'COMMON.IOUNITS'
1285       include 'COMMON.NAMES'
1286       dimension gg(3)
1287       logical scheck
1288 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1289       evdw=0.0D0
1290       do i=iatsc_s,iatsc_e
1291         itypi=iabs(itype(i))
1292         if (itypi.eq.ntyp1) cycle
1293         itypi1=iabs(itype(i+1))
1294         xi=c(1,nres+i)
1295         yi=c(2,nres+i)
1296         zi=c(3,nres+i)
1297 C
1298 C Calculate SC interaction energy.
1299 C
1300         do iint=1,nint_gr(i)
1301           do j=istart(i,iint),iend(i,iint)
1302             itypj=iabs(itype(j))
1303             if (itypj.eq.ntyp1) cycle
1304             xj=c(1,nres+j)-xi
1305             yj=c(2,nres+j)-yi
1306             zj=c(3,nres+j)-zi
1307             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1308             fac_augm=rrij**expon
1309             e_augm=augm(itypi,itypj)*fac_augm
1310             r_inv_ij=dsqrt(rrij)
1311             rij=1.0D0/r_inv_ij
1312             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1313             fac=r_shift_inv**expon
1314 C have you changed here?
1315             e1=fac*fac*aa
1316             e2=fac*bb
1317             evdwij=e_augm+e1+e2
1318 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1319 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1320 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1321 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1322 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1323 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1324 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1325             evdw=evdw+evdwij
1326 C
1327 C Calculate the components of the gradient in DC and X
1328 C
1329             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1330             gg(1)=xj*fac
1331             gg(2)=yj*fac
1332             gg(3)=zj*fac
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 cgrad            do k=i,j-1
1340 cgrad              do l=1,3
1341 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1342 cgrad              enddo
1343 cgrad            enddo
1344           enddo      ! j
1345         enddo        ! iint
1346       enddo          ! i
1347       do i=1,nct
1348         do j=1,3
1349           gvdwc(j,i)=expon*gvdwc(j,i)
1350           gvdwx(j,i)=expon*gvdwx(j,i)
1351         enddo
1352       enddo
1353       return
1354       end
1355 C-----------------------------------------------------------------------------
1356       subroutine ebp(evdw)
1357 C
1358 C This subroutine calculates the interaction energy of nonbonded side chains
1359 C assuming the Berne-Pechukas potential of interaction.
1360 C
1361       implicit real*8 (a-h,o-z)
1362       include 'DIMENSIONS'
1363       include 'COMMON.GEO'
1364       include 'COMMON.VAR'
1365       include 'COMMON.LOCAL'
1366       include 'COMMON.CHAIN'
1367       include 'COMMON.DERIV'
1368       include 'COMMON.NAMES'
1369       include 'COMMON.INTERACT'
1370       include 'COMMON.IOUNITS'
1371       include 'COMMON.CALC'
1372       common /srutu/ icall
1373 c     double precision rrsave(maxdim)
1374       logical lprn
1375       evdw=0.0D0
1376 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1377       evdw=0.0D0
1378 c     if (icall.eq.0) then
1379 c       lprn=.true.
1380 c     else
1381         lprn=.false.
1382 c     endif
1383       ind=0
1384       do i=iatsc_s,iatsc_e
1385         itypi=iabs(itype(i))
1386         if (itypi.eq.ntyp1) cycle
1387         itypi1=iabs(itype(i+1))
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=iabs(itype(j))
1403             if (itypj.eq.ntyp1) cycle
1404 c            dscj_inv=dsc_inv(itypj)
1405             dscj_inv=vbld_inv(j+nres)
1406             chi1=chi(itypi,itypj)
1407             chi2=chi(itypj,itypi)
1408             chi12=chi1*chi2
1409             chip1=chip(itypi)
1410             chip2=chip(itypj)
1411             chip12=chip1*chip2
1412             alf1=alp(itypi)
1413             alf2=alp(itypj)
1414             alf12=0.5D0*(alf1+alf2)
1415 C For diagnostics only!!!
1416 c           chi1=0.0D0
1417 c           chi2=0.0D0
1418 c           chi12=0.0D0
1419 c           chip1=0.0D0
1420 c           chip2=0.0D0
1421 c           chip12=0.0D0
1422 c           alf1=0.0D0
1423 c           alf2=0.0D0
1424 c           alf12=0.0D0
1425             xj=c(1,nres+j)-xi
1426             yj=c(2,nres+j)-yi
1427             zj=c(3,nres+j)-zi
1428             dxj=dc_norm(1,nres+j)
1429             dyj=dc_norm(2,nres+j)
1430             dzj=dc_norm(3,nres+j)
1431             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1432 cd          if (icall.eq.0) then
1433 cd            rrsave(ind)=rrij
1434 cd          else
1435 cd            rrij=rrsave(ind)
1436 cd          endif
1437             rij=dsqrt(rrij)
1438 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1439             call sc_angular
1440 C Calculate whole angle-dependent part of epsilon and contributions
1441 C to its derivatives
1442 C have you changed here?
1443             fac=(rrij*sigsq)**expon2
1444             e1=fac*fac*aa
1445             e2=fac*bb
1446             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1447             eps2der=evdwij*eps3rt
1448             eps3der=evdwij*eps2rt
1449             evdwij=evdwij*eps2rt*eps3rt
1450             evdw=evdw+evdwij
1451             if (lprn) then
1452             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1453             epsi=bb**2/aa
1454 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1455 cd     &        restyp(itypi),i,restyp(itypj),j,
1456 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1457 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1458 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1459 cd     &        evdwij
1460             endif
1461 C Calculate gradient components.
1462             e1=e1*eps1*eps2rt**2*eps3rt**2
1463             fac=-expon*(e1+evdwij)
1464             sigder=fac/sigsq
1465             fac=rrij*fac
1466 C Calculate radial part of the gradient
1467             gg(1)=xj*fac
1468             gg(2)=yj*fac
1469             gg(3)=zj*fac
1470 C Calculate the angular part of the gradient and sum add the contributions
1471 C to the appropriate components of the Cartesian gradient.
1472             call sc_grad
1473           enddo      ! j
1474         enddo        ! iint
1475       enddo          ! i
1476 c     stop
1477       return
1478       end
1479 C-----------------------------------------------------------------------------
1480       subroutine egb(evdw)
1481 C
1482 C This subroutine calculates the interaction energy of nonbonded side chains
1483 C assuming the Gay-Berne potential of interaction.
1484 C
1485       implicit real*8 (a-h,o-z)
1486       include 'DIMENSIONS'
1487       include 'COMMON.GEO'
1488       include 'COMMON.VAR'
1489       include 'COMMON.LOCAL'
1490       include 'COMMON.CHAIN'
1491       include 'COMMON.DERIV'
1492       include 'COMMON.NAMES'
1493       include 'COMMON.INTERACT'
1494       include 'COMMON.IOUNITS'
1495       include 'COMMON.CALC'
1496       include 'COMMON.CONTROL'
1497       include 'COMMON.SPLITELE'
1498       include 'COMMON.SBRIDGE'
1499       logical lprn
1500       integer xshift,yshift,zshift
1501       evdw=0.0D0
1502 ccccc      energy_dec=.false.
1503 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1504       evdw=0.0D0
1505       lprn=.false.
1506 c     if (icall.eq.0) lprn=.false.
1507       ind=0
1508 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1509 C we have the original box)
1510 C      do xshift=-1,1
1511 C      do yshift=-1,1
1512 C      do zshift=-1,1
1513       do i=iatsc_s,iatsc_e
1514         itypi=iabs(itype(i))
1515         if (itypi.eq.ntyp1) cycle
1516         itypi1=iabs(itype(i+1))
1517         xi=c(1,nres+i)
1518         yi=c(2,nres+i)
1519         zi=c(3,nres+i)
1520 C Return atom into box, boxxsize is size of box in x dimension
1521 c  134   continue
1522 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1523 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1524 C Condition for being inside the proper box
1525 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1526 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1527 c        go to 134
1528 c        endif
1529 c  135   continue
1530 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1531 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1532 C Condition for being inside the proper box
1533 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1534 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1535 c        go to 135
1536 c        endif
1537 c  136   continue
1538 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1539 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1540 C Condition for being inside the proper box
1541 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1542 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1543 c        go to 136
1544 c        endif
1545           xi=mod(xi,boxxsize)
1546           if (xi.lt.0) xi=xi+boxxsize
1547           yi=mod(yi,boxysize)
1548           if (yi.lt.0) yi=yi+boxysize
1549           zi=mod(zi,boxzsize)
1550           if (zi.lt.0) zi=zi+boxzsize
1551 C define scaling factor for lipids
1552
1553 C        if (positi.le.0) positi=positi+boxzsize
1554 C        print *,i
1555 C first for peptide groups
1556 c for each residue check if it is in lipid or lipid water border area
1557        if ((zi.gt.bordlipbot)
1558      &.and.(zi.lt.bordliptop)) then
1559 C the energy transfer exist
1560         if (zi.lt.buflipbot) then
1561 C what fraction I am in
1562          fracinbuf=1.0d0-
1563      &        ((zi-bordlipbot)/lipbufthick)
1564 C lipbufthick is thickenes of lipid buffore
1565          sslipi=sscalelip(fracinbuf)
1566          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1567         elseif (zi.gt.bufliptop) then
1568          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1569          sslipi=sscalelip(fracinbuf)
1570          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1571         else
1572          sslipi=1.0d0
1573          ssgradlipi=0.0
1574         endif
1575        else
1576          sslipi=0.0d0
1577          ssgradlipi=0.0
1578        endif
1579
1580 C          xi=xi+xshift*boxxsize
1581 C          yi=yi+yshift*boxysize
1582 C          zi=zi+zshift*boxzsize
1583
1584         dxi=dc_norm(1,nres+i)
1585         dyi=dc_norm(2,nres+i)
1586         dzi=dc_norm(3,nres+i)
1587 c        dsci_inv=dsc_inv(itypi)
1588         dsci_inv=vbld_inv(i+nres)
1589 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1590 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1591 C
1592 C Calculate SC interaction energy.
1593 C
1594         do iint=1,nint_gr(i)
1595           do j=istart(i,iint),iend(i,iint)
1596             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1597               call dyn_ssbond_ene(i,j,evdwij)
1598               evdw=evdw+evdwij
1599               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1600      &                        'evdw',i,j,evdwij,' ss'
1601             ELSE
1602             ind=ind+1
1603             itypj=iabs(itype(j))
1604             if (itypj.eq.ntyp1) cycle
1605 c            dscj_inv=dsc_inv(itypj)
1606             dscj_inv=vbld_inv(j+nres)
1607 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1608 c     &       1.0d0/vbld(j+nres)
1609 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1610             sig0ij=sigma(itypi,itypj)
1611             chi1=chi(itypi,itypj)
1612             chi2=chi(itypj,itypi)
1613             chi12=chi1*chi2
1614             chip1=chip(itypi)
1615             chip2=chip(itypj)
1616             chip12=chip1*chip2
1617             alf1=alp(itypi)
1618             alf2=alp(itypj)
1619             alf12=0.5D0*(alf1+alf2)
1620 C For diagnostics only!!!
1621 c           chi1=0.0D0
1622 c           chi2=0.0D0
1623 c           chi12=0.0D0
1624 c           chip1=0.0D0
1625 c           chip2=0.0D0
1626 c           chip12=0.0D0
1627 c           alf1=0.0D0
1628 c           alf2=0.0D0
1629 c           alf12=0.0D0
1630             xj=c(1,nres+j)
1631             yj=c(2,nres+j)
1632             zj=c(3,nres+j)
1633 C Return atom J into box the original box
1634 c  137   continue
1635 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1636 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1637 C Condition for being inside the proper box
1638 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1639 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1640 c        go to 137
1641 c        endif
1642 c  138   continue
1643 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1644 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1645 C Condition for being inside the proper box
1646 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1647 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1648 c        go to 138
1649 c        endif
1650 c  139   continue
1651 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1652 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1653 C Condition for being inside the proper box
1654 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1655 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1656 c        go to 139
1657 c        endif
1658           xj=mod(xj,boxxsize)
1659           if (xj.lt.0) xj=xj+boxxsize
1660           yj=mod(yj,boxysize)
1661           if (yj.lt.0) yj=yj+boxysize
1662           zj=mod(zj,boxzsize)
1663           if (zj.lt.0) zj=zj+boxzsize
1664        if ((zj.gt.bordlipbot)
1665      &.and.(zj.lt.bordliptop)) then
1666 C the energy transfer exist
1667         if (zj.lt.buflipbot) then
1668 C what fraction I am in
1669          fracinbuf=1.0d0-
1670      &        ((zj-bordlipbot)/lipbufthick)
1671 C lipbufthick is thickenes of lipid buffore
1672          sslipj=sscalelip(fracinbuf)
1673          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1674         elseif (zj.gt.bufliptop) then
1675          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1676          sslipj=sscalelip(fracinbuf)
1677          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1678         else
1679          sslipj=1.0d0
1680          ssgradlipj=0.0
1681         endif
1682        else
1683          sslipj=0.0d0
1684          ssgradlipj=0.0
1685        endif
1686       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1687      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1688       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1689      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1690 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1691 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1692 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1693 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1694       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1695       xj_safe=xj
1696       yj_safe=yj
1697       zj_safe=zj
1698       subchap=0
1699       do xshift=-1,1
1700       do yshift=-1,1
1701       do zshift=-1,1
1702           xj=xj_safe+xshift*boxxsize
1703           yj=yj_safe+yshift*boxysize
1704           zj=zj_safe+zshift*boxzsize
1705           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1706           if(dist_temp.lt.dist_init) then
1707             dist_init=dist_temp
1708             xj_temp=xj
1709             yj_temp=yj
1710             zj_temp=zj
1711             subchap=1
1712           endif
1713        enddo
1714        enddo
1715        enddo
1716        if (subchap.eq.1) then
1717           xj=xj_temp-xi
1718           yj=yj_temp-yi
1719           zj=zj_temp-zi
1720        else
1721           xj=xj_safe-xi
1722           yj=yj_safe-yi
1723           zj=zj_safe-zi
1724        endif
1725             dxj=dc_norm(1,nres+j)
1726             dyj=dc_norm(2,nres+j)
1727             dzj=dc_norm(3,nres+j)
1728 C            xj=xj-xi
1729 C            yj=yj-yi
1730 C            zj=zj-zi
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1737             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1738
1739 c            write (iout,'(a7,4f8.3)')
1740 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1741             if (sss.gt.0.0d0) then
1742 C Calculate angle-dependent terms of energy and contributions to their
1743 C derivatives.
1744             call sc_angular
1745             sigsq=1.0D0/sigsq
1746             sig=sig0ij*dsqrt(sigsq)
1747             rij_shift=1.0D0/rij-sig+sig0ij
1748 c for diagnostics; uncomment
1749 c            rij_shift=1.2*sig0ij
1750 C I hate to put IF's in the loops, but here don't have another choice!!!!
1751             if (rij_shift.le.0.0D0) then
1752               evdw=1.0D20
1753 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1754 cd     &        restyp(itypi),i,restyp(itypj),j,
1755 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1756               return
1757             endif
1758             sigder=-sig*sigsq
1759 c---------------------------------------------------------------
1760             rij_shift=1.0D0/rij_shift
1761             fac=rij_shift**expon
1762 C here to start with
1763 C            if (c(i,3).gt.
1764             faclip=fac
1765             e1=fac*fac*aa
1766             e2=fac*bb
1767             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1768             eps2der=evdwij*eps3rt
1769             eps3der=evdwij*eps2rt
1770 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1771 C     &((sslipi+sslipj)/2.0d0+
1772 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1773 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1774 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1775             evdwij=evdwij*eps2rt*eps3rt
1776             evdw=evdw+evdwij*sss
1777             if (lprn) then
1778             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1779             epsi=bb**2/aa
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,chi1,chi2,chip1,chip2,
1783      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1784      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1785      &        evdwij
1786             endif
1787
1788             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1789      &                        'evdw',i,j,evdwij
1790
1791 C Calculate gradient components.
1792             e1=e1*eps1*eps2rt**2*eps3rt**2
1793             fac=-expon*(e1+evdwij)*rij_shift
1794             sigder=fac*sigder
1795             fac=rij*fac
1796 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1797 c     &      evdwij,fac,sigma(itypi,itypj),expon
1798             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1799 c            fac=0.0d0
1800 C Calculate the radial part of the gradient
1801             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1802      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1803      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1804      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1805             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1806             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1807 C            gg_lipi(3)=0.0d0
1808 C            gg_lipj(3)=0.0d0
1809             gg(1)=xj*fac
1810             gg(2)=yj*fac
1811             gg(3)=zj*fac
1812 C Calculate angular part of the gradient.
1813             call sc_grad
1814             endif
1815             ENDIF    ! dyn_ss
1816           enddo      ! j
1817         enddo        ! iint
1818       enddo          ! i
1819 C      enddo          ! zshift
1820 C      enddo          ! yshift
1821 C      enddo          ! xshift
1822 c      write (iout,*) "Number of loop steps in EGB:",ind
1823 cccc      energy_dec=.false.
1824       return
1825       end
1826 C-----------------------------------------------------------------------------
1827       subroutine egbv(evdw)
1828 C
1829 C This subroutine calculates the interaction energy of nonbonded side chains
1830 C assuming the Gay-Berne-Vorobjev potential of interaction.
1831 C
1832       implicit real*8 (a-h,o-z)
1833       include 'DIMENSIONS'
1834       include 'COMMON.GEO'
1835       include 'COMMON.VAR'
1836       include 'COMMON.LOCAL'
1837       include 'COMMON.CHAIN'
1838       include 'COMMON.DERIV'
1839       include 'COMMON.NAMES'
1840       include 'COMMON.INTERACT'
1841       include 'COMMON.IOUNITS'
1842       include 'COMMON.CALC'
1843       common /srutu/ icall
1844       logical lprn
1845       evdw=0.0D0
1846 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1847       evdw=0.0D0
1848       lprn=.false.
1849 c     if (icall.eq.0) lprn=.true.
1850       ind=0
1851       do i=iatsc_s,iatsc_e
1852         itypi=iabs(itype(i))
1853         if (itypi.eq.ntyp1) cycle
1854         itypi1=iabs(itype(i+1))
1855         xi=c(1,nres+i)
1856         yi=c(2,nres+i)
1857         zi=c(3,nres+i)
1858           xi=mod(xi,boxxsize)
1859           if (xi.lt.0) xi=xi+boxxsize
1860           yi=mod(yi,boxysize)
1861           if (yi.lt.0) yi=yi+boxysize
1862           zi=mod(zi,boxzsize)
1863           if (zi.lt.0) zi=zi+boxzsize
1864 C define scaling factor for lipids
1865
1866 C        if (positi.le.0) positi=positi+boxzsize
1867 C        print *,i
1868 C first for peptide groups
1869 c for each residue check if it is in lipid or lipid water border area
1870        if ((zi.gt.bordlipbot)
1871      &.and.(zi.lt.bordliptop)) then
1872 C the energy transfer exist
1873         if (zi.lt.buflipbot) then
1874 C what fraction I am in
1875          fracinbuf=1.0d0-
1876      &        ((zi-bordlipbot)/lipbufthick)
1877 C lipbufthick is thickenes of lipid buffore
1878          sslipi=sscalelip(fracinbuf)
1879          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1880         elseif (zi.gt.bufliptop) then
1881          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1882          sslipi=sscalelip(fracinbuf)
1883          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1884         else
1885          sslipi=1.0d0
1886          ssgradlipi=0.0
1887         endif
1888        else
1889          sslipi=0.0d0
1890          ssgradlipi=0.0
1891        endif
1892
1893         dxi=dc_norm(1,nres+i)
1894         dyi=dc_norm(2,nres+i)
1895         dzi=dc_norm(3,nres+i)
1896 c        dsci_inv=dsc_inv(itypi)
1897         dsci_inv=vbld_inv(i+nres)
1898 C
1899 C Calculate SC interaction energy.
1900 C
1901         do iint=1,nint_gr(i)
1902           do j=istart(i,iint),iend(i,iint)
1903             ind=ind+1
1904             itypj=iabs(itype(j))
1905             if (itypj.eq.ntyp1) cycle
1906 c            dscj_inv=dsc_inv(itypj)
1907             dscj_inv=vbld_inv(j+nres)
1908             sig0ij=sigma(itypi,itypj)
1909             r0ij=r0(itypi,itypj)
1910             chi1=chi(itypi,itypj)
1911             chi2=chi(itypj,itypi)
1912             chi12=chi1*chi2
1913             chip1=chip(itypi)
1914             chip2=chip(itypj)
1915             chip12=chip1*chip2
1916             alf1=alp(itypi)
1917             alf2=alp(itypj)
1918             alf12=0.5D0*(alf1+alf2)
1919 C For diagnostics only!!!
1920 c           chi1=0.0D0
1921 c           chi2=0.0D0
1922 c           chi12=0.0D0
1923 c           chip1=0.0D0
1924 c           chip2=0.0D0
1925 c           chip12=0.0D0
1926 c           alf1=0.0D0
1927 c           alf2=0.0D0
1928 c           alf12=0.0D0
1929 C            xj=c(1,nres+j)-xi
1930 C            yj=c(2,nres+j)-yi
1931 C            zj=c(3,nres+j)-zi
1932           xj=mod(xj,boxxsize)
1933           if (xj.lt.0) xj=xj+boxxsize
1934           yj=mod(yj,boxysize)
1935           if (yj.lt.0) yj=yj+boxysize
1936           zj=mod(zj,boxzsize)
1937           if (zj.lt.0) zj=zj+boxzsize
1938        if ((zj.gt.bordlipbot)
1939      &.and.(zj.lt.bordliptop)) then
1940 C the energy transfer exist
1941         if (zj.lt.buflipbot) then
1942 C what fraction I am in
1943          fracinbuf=1.0d0-
1944      &        ((zj-bordlipbot)/lipbufthick)
1945 C lipbufthick is thickenes of lipid buffore
1946          sslipj=sscalelip(fracinbuf)
1947          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1948         elseif (zj.gt.bufliptop) then
1949          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1950          sslipj=sscalelip(fracinbuf)
1951          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1952         else
1953          sslipj=1.0d0
1954          ssgradlipj=0.0
1955         endif
1956        else
1957          sslipj=0.0d0
1958          ssgradlipj=0.0
1959        endif
1960       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1961      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1962       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1963      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1964 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1965 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1966       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1967       xj_safe=xj
1968       yj_safe=yj
1969       zj_safe=zj
1970       subchap=0
1971       do xshift=-1,1
1972       do yshift=-1,1
1973       do zshift=-1,1
1974           xj=xj_safe+xshift*boxxsize
1975           yj=yj_safe+yshift*boxysize
1976           zj=zj_safe+zshift*boxzsize
1977           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1978           if(dist_temp.lt.dist_init) then
1979             dist_init=dist_temp
1980             xj_temp=xj
1981             yj_temp=yj
1982             zj_temp=zj
1983             subchap=1
1984           endif
1985        enddo
1986        enddo
1987        enddo
1988        if (subchap.eq.1) then
1989           xj=xj_temp-xi
1990           yj=yj_temp-yi
1991           zj=zj_temp-zi
1992        else
1993           xj=xj_safe-xi
1994           yj=yj_safe-yi
1995           zj=zj_safe-zi
1996        endif
1997             dxj=dc_norm(1,nres+j)
1998             dyj=dc_norm(2,nres+j)
1999             dzj=dc_norm(3,nres+j)
2000             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2001             rij=dsqrt(rrij)
2002 C Calculate angle-dependent terms of energy and contributions to their
2003 C derivatives.
2004             call sc_angular
2005             sigsq=1.0D0/sigsq
2006             sig=sig0ij*dsqrt(sigsq)
2007             rij_shift=1.0D0/rij-sig+r0ij
2008 C I hate to put IF's in the loops, but here don't have another choice!!!!
2009             if (rij_shift.le.0.0D0) then
2010               evdw=1.0D20
2011               return
2012             endif
2013             sigder=-sig*sigsq
2014 c---------------------------------------------------------------
2015             rij_shift=1.0D0/rij_shift
2016             fac=rij_shift**expon
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022             fac_augm=rrij**expon
2023             e_augm=augm(itypi,itypj)*fac_augm
2024             evdwij=evdwij*eps2rt*eps3rt
2025             evdw=evdw+evdwij+e_augm
2026             if (lprn) then
2027             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2028             epsi=bb**2/aa
2029             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2030      &        restyp(itypi),i,restyp(itypj),j,
2031      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2032      &        chi1,chi2,chip1,chip2,
2033      &        eps1,eps2rt**2,eps3rt**2,
2034      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2035      &        evdwij+e_augm
2036             endif
2037 C Calculate gradient components.
2038             e1=e1*eps1*eps2rt**2*eps3rt**2
2039             fac=-expon*(e1+evdwij)*rij_shift
2040             sigder=fac*sigder
2041             fac=rij*fac-2*expon*rrij*e_augm
2042             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2043 C Calculate the radial part of the gradient
2044             gg(1)=xj*fac
2045             gg(2)=yj*fac
2046             gg(3)=zj*fac
2047 C Calculate angular part of the gradient.
2048             call sc_grad
2049           enddo      ! j
2050         enddo        ! iint
2051       enddo          ! i
2052       end
2053 C-----------------------------------------------------------------------------
2054       subroutine sc_angular
2055 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2056 C om12. Called by ebp, egb, and egbv.
2057       implicit none
2058       include 'COMMON.CALC'
2059       include 'COMMON.IOUNITS'
2060       erij(1)=xj*rij
2061       erij(2)=yj*rij
2062       erij(3)=zj*rij
2063       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2064       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2065       om12=dxi*dxj+dyi*dyj+dzi*dzj
2066       chiom12=chi12*om12
2067 C Calculate eps1(om12) and its derivative in om12
2068       faceps1=1.0D0-om12*chiom12
2069       faceps1_inv=1.0D0/faceps1
2070       eps1=dsqrt(faceps1_inv)
2071 C Following variable is eps1*deps1/dom12
2072       eps1_om12=faceps1_inv*chiom12
2073 c diagnostics only
2074 c      faceps1_inv=om12
2075 c      eps1=om12
2076 c      eps1_om12=1.0d0
2077 c      write (iout,*) "om12",om12," eps1",eps1
2078 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2079 C and om12.
2080       om1om2=om1*om2
2081       chiom1=chi1*om1
2082       chiom2=chi2*om2
2083       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2084       sigsq=1.0D0-facsig*faceps1_inv
2085       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2086       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2087       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2088 c diagnostics only
2089 c      sigsq=1.0d0
2090 c      sigsq_om1=0.0d0
2091 c      sigsq_om2=0.0d0
2092 c      sigsq_om12=0.0d0
2093 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2094 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2095 c     &    " eps1",eps1
2096 C Calculate eps2 and its derivatives in om1, om2, and om12.
2097       chipom1=chip1*om1
2098       chipom2=chip2*om2
2099       chipom12=chip12*om12
2100       facp=1.0D0-om12*chipom12
2101       facp_inv=1.0D0/facp
2102       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2103 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2104 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2105 C Following variable is the square root of eps2
2106       eps2rt=1.0D0-facp1*facp_inv
2107 C Following three variables are the derivatives of the square root of eps
2108 C in om1, om2, and om12.
2109       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2110       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2111       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2112 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2113       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2114 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2115 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2116 c     &  " eps2rt_om12",eps2rt_om12
2117 C Calculate whole angle-dependent part of epsilon and contributions
2118 C to its derivatives
2119       return
2120       end
2121 C----------------------------------------------------------------------------
2122       subroutine sc_grad
2123       implicit real*8 (a-h,o-z)
2124       include 'DIMENSIONS'
2125       include 'COMMON.CHAIN'
2126       include 'COMMON.DERIV'
2127       include 'COMMON.CALC'
2128       include 'COMMON.IOUNITS'
2129       double precision dcosom1(3),dcosom2(3)
2130 cc      print *,'sss=',sss
2131       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2132       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2133       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2134      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2135 c diagnostics only
2136 c      eom1=0.0d0
2137 c      eom2=0.0d0
2138 c      eom12=evdwij*eps1_om12
2139 c end diagnostics
2140 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2141 c     &  " sigder",sigder
2142 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2143 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2144       do k=1,3
2145         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2146         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2147       enddo
2148       do k=1,3
2149         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2150       enddo
2151 c      write (iout,*) "gg",(gg(k),k=1,3)
2152       do k=1,3
2153         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2154      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2155      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2156         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2157      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2158      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2159 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2160 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2161 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2162 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2163       enddo
2164 C
2165 C Calculate the components of the gradient in DC and X
2166 C
2167 cgrad      do k=i,j-1
2168 cgrad        do l=1,3
2169 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2170 cgrad        enddo
2171 cgrad      enddo
2172       do l=1,3
2173         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2174         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2175       enddo
2176       return
2177       end
2178 C-----------------------------------------------------------------------
2179       subroutine e_softsphere(evdw)
2180 C
2181 C This subroutine calculates the interaction energy of nonbonded side chains
2182 C assuming the LJ potential of interaction.
2183 C
2184       implicit real*8 (a-h,o-z)
2185       include 'DIMENSIONS'
2186       parameter (accur=1.0d-10)
2187       include 'COMMON.GEO'
2188       include 'COMMON.VAR'
2189       include 'COMMON.LOCAL'
2190       include 'COMMON.CHAIN'
2191       include 'COMMON.DERIV'
2192       include 'COMMON.INTERACT'
2193       include 'COMMON.TORSION'
2194       include 'COMMON.SBRIDGE'
2195       include 'COMMON.NAMES'
2196       include 'COMMON.IOUNITS'
2197       include 'COMMON.CONTACTS'
2198       dimension gg(3)
2199 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2200       evdw=0.0D0
2201       do i=iatsc_s,iatsc_e
2202         itypi=iabs(itype(i))
2203         if (itypi.eq.ntyp1) cycle
2204         itypi1=iabs(itype(i+1))
2205         xi=c(1,nres+i)
2206         yi=c(2,nres+i)
2207         zi=c(3,nres+i)
2208 C
2209 C Calculate SC interaction energy.
2210 C
2211         do iint=1,nint_gr(i)
2212 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2213 cd   &                  'iend=',iend(i,iint)
2214           do j=istart(i,iint),iend(i,iint)
2215             itypj=iabs(itype(j))
2216             if (itypj.eq.ntyp1) cycle
2217             xj=c(1,nres+j)-xi
2218             yj=c(2,nres+j)-yi
2219             zj=c(3,nres+j)-zi
2220             rij=xj*xj+yj*yj+zj*zj
2221 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2222             r0ij=r0(itypi,itypj)
2223             r0ijsq=r0ij*r0ij
2224 c            print *,i,j,r0ij,dsqrt(rij)
2225             if (rij.lt.r0ijsq) then
2226               evdwij=0.25d0*(rij-r0ijsq)**2
2227               fac=rij-r0ijsq
2228             else
2229               evdwij=0.0d0
2230               fac=0.0d0
2231             endif
2232             evdw=evdw+evdwij
2233 C
2234 C Calculate the components of the gradient in DC and X
2235 C
2236             gg(1)=xj*fac
2237             gg(2)=yj*fac
2238             gg(3)=zj*fac
2239             do k=1,3
2240               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2241               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2242               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2243               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2244             enddo
2245 cgrad            do k=i,j-1
2246 cgrad              do l=1,3
2247 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2248 cgrad              enddo
2249 cgrad            enddo
2250           enddo ! j
2251         enddo ! iint
2252       enddo ! i
2253       return
2254       end
2255 C--------------------------------------------------------------------------
2256       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2257      &              eello_turn4)
2258 C
2259 C Soft-sphere potential of p-p interaction
2260 C
2261       implicit real*8 (a-h,o-z)
2262       include 'DIMENSIONS'
2263       include 'COMMON.CONTROL'
2264       include 'COMMON.IOUNITS'
2265       include 'COMMON.GEO'
2266       include 'COMMON.VAR'
2267       include 'COMMON.LOCAL'
2268       include 'COMMON.CHAIN'
2269       include 'COMMON.DERIV'
2270       include 'COMMON.INTERACT'
2271       include 'COMMON.CONTACTS'
2272       include 'COMMON.TORSION'
2273       include 'COMMON.VECTORS'
2274       include 'COMMON.FFIELD'
2275       dimension ggg(3)
2276 C      write(iout,*) 'In EELEC_soft_sphere'
2277       ees=0.0D0
2278       evdw1=0.0D0
2279       eel_loc=0.0d0
2280       eello_turn3=0.0d0
2281       eello_turn4=0.0d0
2282       ind=0
2283       do i=iatel_s,iatel_e
2284         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2285         dxi=dc(1,i)
2286         dyi=dc(2,i)
2287         dzi=dc(3,i)
2288         xmedi=c(1,i)+0.5d0*dxi
2289         ymedi=c(2,i)+0.5d0*dyi
2290         zmedi=c(3,i)+0.5d0*dzi
2291           xmedi=mod(xmedi,boxxsize)
2292           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2293           ymedi=mod(ymedi,boxysize)
2294           if (ymedi.lt.0) ymedi=ymedi+boxysize
2295           zmedi=mod(zmedi,boxzsize)
2296           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2297         num_conti=0
2298 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2299         do j=ielstart(i),ielend(i)
2300           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2301           ind=ind+1
2302           iteli=itel(i)
2303           itelj=itel(j)
2304           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2305           r0ij=rpp(iteli,itelj)
2306           r0ijsq=r0ij*r0ij
2307           dxj=dc(1,j)
2308           dyj=dc(2,j)
2309           dzj=dc(3,j)
2310           xj=c(1,j)+0.5D0*dxj
2311           yj=c(2,j)+0.5D0*dyj
2312           zj=c(3,j)+0.5D0*dzj
2313           xj=mod(xj,boxxsize)
2314           if (xj.lt.0) xj=xj+boxxsize
2315           yj=mod(yj,boxysize)
2316           if (yj.lt.0) yj=yj+boxysize
2317           zj=mod(zj,boxzsize)
2318           if (zj.lt.0) zj=zj+boxzsize
2319       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2320       xj_safe=xj
2321       yj_safe=yj
2322       zj_safe=zj
2323       isubchap=0
2324       do xshift=-1,1
2325       do yshift=-1,1
2326       do zshift=-1,1
2327           xj=xj_safe+xshift*boxxsize
2328           yj=yj_safe+yshift*boxysize
2329           zj=zj_safe+zshift*boxzsize
2330           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2331           if(dist_temp.lt.dist_init) then
2332             dist_init=dist_temp
2333             xj_temp=xj
2334             yj_temp=yj
2335             zj_temp=zj
2336             isubchap=1
2337           endif
2338        enddo
2339        enddo
2340        enddo
2341        if (isubchap.eq.1) then
2342           xj=xj_temp-xmedi
2343           yj=yj_temp-ymedi
2344           zj=zj_temp-zmedi
2345        else
2346           xj=xj_safe-xmedi
2347           yj=yj_safe-ymedi
2348           zj=zj_safe-zmedi
2349        endif
2350           rij=xj*xj+yj*yj+zj*zj
2351             sss=sscale(sqrt(rij))
2352             sssgrad=sscagrad(sqrt(rij))
2353           if (rij.lt.r0ijsq) then
2354             evdw1ij=0.25d0*(rij-r0ijsq)**2
2355             fac=rij-r0ijsq
2356           else
2357             evdw1ij=0.0d0
2358             fac=0.0d0
2359           endif
2360           evdw1=evdw1+evdw1ij*sss
2361 C
2362 C Calculate contributions to the Cartesian gradient.
2363 C
2364           ggg(1)=fac*xj*sssgrad
2365           ggg(2)=fac*yj*sssgrad
2366           ggg(3)=fac*zj*sssgrad
2367           do k=1,3
2368             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2369             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2370           enddo
2371 *
2372 * Loop over residues i+1 thru j-1.
2373 *
2374 cgrad          do k=i+1,j-1
2375 cgrad            do l=1,3
2376 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2377 cgrad            enddo
2378 cgrad          enddo
2379         enddo ! j
2380       enddo   ! i
2381 cgrad      do i=nnt,nct-1
2382 cgrad        do k=1,3
2383 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2384 cgrad        enddo
2385 cgrad        do j=i+1,nct-1
2386 cgrad          do k=1,3
2387 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2388 cgrad          enddo
2389 cgrad        enddo
2390 cgrad      enddo
2391       return
2392       end
2393 c------------------------------------------------------------------------------
2394       subroutine vec_and_deriv
2395       implicit real*8 (a-h,o-z)
2396       include 'DIMENSIONS'
2397 #ifdef MPI
2398       include 'mpif.h'
2399 #endif
2400       include 'COMMON.IOUNITS'
2401       include 'COMMON.GEO'
2402       include 'COMMON.VAR'
2403       include 'COMMON.LOCAL'
2404       include 'COMMON.CHAIN'
2405       include 'COMMON.VECTORS'
2406       include 'COMMON.SETUP'
2407       include 'COMMON.TIME1'
2408       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2409 C Compute the local reference systems. For reference system (i), the
2410 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2411 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2412 #ifdef PARVEC
2413       do i=ivec_start,ivec_end
2414 #else
2415       do i=1,nres-1
2416 #endif
2417           if (i.eq.nres-1) then
2418 C Case of the last full residue
2419 C Compute the Z-axis
2420             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2421             costh=dcos(pi-theta(nres))
2422             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2423             do k=1,3
2424               uz(k,i)=fac*uz(k,i)
2425             enddo
2426 C Compute the derivatives of uz
2427             uzder(1,1,1)= 0.0d0
2428             uzder(2,1,1)=-dc_norm(3,i-1)
2429             uzder(3,1,1)= dc_norm(2,i-1)
2430             uzder(1,2,1)= dc_norm(3,i-1)
2431             uzder(2,2,1)= 0.0d0
2432             uzder(3,2,1)=-dc_norm(1,i-1)
2433             uzder(1,3,1)=-dc_norm(2,i-1)
2434             uzder(2,3,1)= dc_norm(1,i-1)
2435             uzder(3,3,1)= 0.0d0
2436             uzder(1,1,2)= 0.0d0
2437             uzder(2,1,2)= dc_norm(3,i)
2438             uzder(3,1,2)=-dc_norm(2,i)
2439             uzder(1,2,2)=-dc_norm(3,i)
2440             uzder(2,2,2)= 0.0d0
2441             uzder(3,2,2)= dc_norm(1,i)
2442             uzder(1,3,2)= dc_norm(2,i)
2443             uzder(2,3,2)=-dc_norm(1,i)
2444             uzder(3,3,2)= 0.0d0
2445 C Compute the Y-axis
2446             facy=fac
2447             do k=1,3
2448               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2449             enddo
2450 C Compute the derivatives of uy
2451             do j=1,3
2452               do k=1,3
2453                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2454      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2455                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2456               enddo
2457               uyder(j,j,1)=uyder(j,j,1)-costh
2458               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2459             enddo
2460             do j=1,2
2461               do k=1,3
2462                 do l=1,3
2463                   uygrad(l,k,j,i)=uyder(l,k,j)
2464                   uzgrad(l,k,j,i)=uzder(l,k,j)
2465                 enddo
2466               enddo
2467             enddo
2468             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2469             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2470             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2471             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2472           else
2473 C Other residues
2474 C Compute the Z-axis
2475             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2476             costh=dcos(pi-theta(i+2))
2477             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2478             do k=1,3
2479               uz(k,i)=fac*uz(k,i)
2480             enddo
2481 C Compute the derivatives of uz
2482             uzder(1,1,1)= 0.0d0
2483             uzder(2,1,1)=-dc_norm(3,i+1)
2484             uzder(3,1,1)= dc_norm(2,i+1)
2485             uzder(1,2,1)= dc_norm(3,i+1)
2486             uzder(2,2,1)= 0.0d0
2487             uzder(3,2,1)=-dc_norm(1,i+1)
2488             uzder(1,3,1)=-dc_norm(2,i+1)
2489             uzder(2,3,1)= dc_norm(1,i+1)
2490             uzder(3,3,1)= 0.0d0
2491             uzder(1,1,2)= 0.0d0
2492             uzder(2,1,2)= dc_norm(3,i)
2493             uzder(3,1,2)=-dc_norm(2,i)
2494             uzder(1,2,2)=-dc_norm(3,i)
2495             uzder(2,2,2)= 0.0d0
2496             uzder(3,2,2)= dc_norm(1,i)
2497             uzder(1,3,2)= dc_norm(2,i)
2498             uzder(2,3,2)=-dc_norm(1,i)
2499             uzder(3,3,2)= 0.0d0
2500 C Compute the Y-axis
2501             facy=fac
2502             do k=1,3
2503               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2504             enddo
2505 C Compute the derivatives of uy
2506             do j=1,3
2507               do k=1,3
2508                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2509      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2510                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2511               enddo
2512               uyder(j,j,1)=uyder(j,j,1)-costh
2513               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2514             enddo
2515             do j=1,2
2516               do k=1,3
2517                 do l=1,3
2518                   uygrad(l,k,j,i)=uyder(l,k,j)
2519                   uzgrad(l,k,j,i)=uzder(l,k,j)
2520                 enddo
2521               enddo
2522             enddo
2523             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2524             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2525             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2526             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2527           endif
2528       enddo
2529       do i=1,nres-1
2530         vbld_inv_temp(1)=vbld_inv(i+1)
2531         if (i.lt.nres-1) then
2532           vbld_inv_temp(2)=vbld_inv(i+2)
2533           else
2534           vbld_inv_temp(2)=vbld_inv(i)
2535           endif
2536         do j=1,2
2537           do k=1,3
2538             do l=1,3
2539               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2540               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2541             enddo
2542           enddo
2543         enddo
2544       enddo
2545 #if defined(PARVEC) && defined(MPI)
2546       if (nfgtasks1.gt.1) then
2547         time00=MPI_Wtime()
2548 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2551         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2553      &   FG_COMM1,IERR)
2554         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2558      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2559      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2560         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2561      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2562      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2563         time_gather=time_gather+MPI_Wtime()-time00
2564       endif
2565 c      if (fg_rank.eq.0) then
2566 c        write (iout,*) "Arrays UY and UZ"
2567 c        do i=1,nres-1
2568 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2569 c     &     (uz(k,i),k=1,3)
2570 c        enddo
2571 c      endif
2572 #endif
2573       return
2574       end
2575 C-----------------------------------------------------------------------------
2576       subroutine check_vecgrad
2577       implicit real*8 (a-h,o-z)
2578       include 'DIMENSIONS'
2579       include 'COMMON.IOUNITS'
2580       include 'COMMON.GEO'
2581       include 'COMMON.VAR'
2582       include 'COMMON.LOCAL'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.VECTORS'
2585       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2586       dimension uyt(3,maxres),uzt(3,maxres)
2587       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2588       double precision delta /1.0d-7/
2589       call vec_and_deriv
2590 cd      do i=1,nres
2591 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2592 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2593 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2594 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2595 cd     &     (dc_norm(if90,i),if90=1,3)
2596 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2597 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2598 cd          write(iout,'(a)')
2599 cd      enddo
2600       do i=1,nres
2601         do j=1,2
2602           do k=1,3
2603             do l=1,3
2604               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2605               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2606             enddo
2607           enddo
2608         enddo
2609       enddo
2610       call vec_and_deriv
2611       do i=1,nres
2612         do j=1,3
2613           uyt(j,i)=uy(j,i)
2614           uzt(j,i)=uz(j,i)
2615         enddo
2616       enddo
2617       do i=1,nres
2618 cd        write (iout,*) 'i=',i
2619         do k=1,3
2620           erij(k)=dc_norm(k,i)
2621         enddo
2622         do j=1,3
2623           do k=1,3
2624             dc_norm(k,i)=erij(k)
2625           enddo
2626           dc_norm(j,i)=dc_norm(j,i)+delta
2627 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2628 c          do k=1,3
2629 c            dc_norm(k,i)=dc_norm(k,i)/fac
2630 c          enddo
2631 c          write (iout,*) (dc_norm(k,i),k=1,3)
2632 c          write (iout,*) (erij(k),k=1,3)
2633           call vec_and_deriv
2634           do k=1,3
2635             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2636             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2637             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2638             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2639           enddo
2640 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2641 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2642 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2643         enddo
2644         do k=1,3
2645           dc_norm(k,i)=erij(k)
2646         enddo
2647 cd        do k=1,3
2648 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2649 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2650 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2651 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2652 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2653 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2654 cd          write (iout,'(a)')
2655 cd        enddo
2656       enddo
2657       return
2658       end
2659 C--------------------------------------------------------------------------
2660       subroutine set_matrices
2661       implicit real*8 (a-h,o-z)
2662       include 'DIMENSIONS'
2663 #ifdef MPI
2664       include "mpif.h"
2665       include "COMMON.SETUP"
2666       integer IERR
2667       integer status(MPI_STATUS_SIZE)
2668 #endif
2669       include 'COMMON.IOUNITS'
2670       include 'COMMON.GEO'
2671       include 'COMMON.VAR'
2672       include 'COMMON.LOCAL'
2673       include 'COMMON.CHAIN'
2674       include 'COMMON.DERIV'
2675       include 'COMMON.INTERACT'
2676       include 'COMMON.CONTACTS'
2677       include 'COMMON.TORSION'
2678       include 'COMMON.VECTORS'
2679       include 'COMMON.FFIELD'
2680       double precision auxvec(2),auxmat(2,2)
2681 C
2682 C Compute the virtual-bond-torsional-angle dependent quantities needed
2683 C to calculate the el-loc multibody terms of various order.
2684 C
2685 c      write(iout,*) 'nphi=',nphi,nres
2686 #ifdef PARMAT
2687       do i=ivec_start+2,ivec_end+2
2688 #else
2689       do i=3,nres+1
2690 #endif
2691 #ifdef NEWCORR
2692         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2693           iti = itortyp(itype(i-2))
2694         else
2695           iti=ntortyp+1
2696         endif
2697 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2698         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2699           iti1 = itortyp(itype(i-1))
2700         else
2701           iti1=ntortyp+1
2702         endif
2703 c        write(iout,*),i
2704         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2705      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2706      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2707         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2708      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2709      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2710 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2711 c     &*(cos(theta(i)/2.0)
2712         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2713      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2714      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2715 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2716 c     &*(cos(theta(i)/2.0)
2717         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2718      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2719      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2720 c        if (ggb1(1,i).eq.0.0d0) then
2721 c        write(iout,*) 'i=',i,ggb1(1,i),
2722 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2723 c     &bnew1(2,1,iti)*cos(theta(i)),
2724 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2725 c        endif
2726         b1(2,i-2)=bnew1(1,2,iti)
2727         gtb1(2,i-2)=0.0
2728         b2(2,i-2)=bnew2(1,2,iti)
2729         gtb2(2,i-2)=0.0
2730         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2731         EE(1,2,i-2)=eeold(1,2,iti)
2732         EE(2,1,i-2)=eeold(2,1,iti)
2733         EE(2,2,i-2)=eeold(2,2,iti)
2734         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2735         gtEE(1,2,i-2)=0.0d0
2736         gtEE(2,2,i-2)=0.0d0
2737         gtEE(2,1,i-2)=0.0d0
2738 c        EE(2,2,iti)=0.0d0
2739 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2740 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2741 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2742 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2743        b1tilde(1,i-2)=b1(1,i-2)
2744        b1tilde(2,i-2)=-b1(2,i-2)
2745        b2tilde(1,i-2)=b2(1,i-2)
2746        b2tilde(2,i-2)=-b2(2,i-2)
2747 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2748 c       write(iout,*)  'b1=',b1(1,i-2)
2749 c       write (iout,*) 'theta=', theta(i-1)
2750        enddo
2751 #else
2752         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2753           iti = itortyp(itype(i-2))
2754         else
2755           iti=ntortyp+1
2756         endif
2757 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2758         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2759           iti1 = itortyp(itype(i-1))
2760         else
2761           iti1=ntortyp+1
2762         endif
2763         b1(1,i-2)=b(3,iti)
2764         b1(2,i-2)=b(5,iti)
2765         b2(1,i-2)=b(2,iti)
2766         b2(2,i-2)=b(4,iti)
2767        b1tilde(1,i-2)=b1(1,i-2)
2768        b1tilde(2,i-2)=-b1(2,i-2)
2769        b2tilde(1,i-2)=b2(1,i-2)
2770        b2tilde(2,i-2)=-b2(2,i-2)
2771         EE(1,2,i-2)=eeold(1,2,iti)
2772         EE(2,1,i-2)=eeold(2,1,iti)
2773         EE(2,2,i-2)=eeold(2,2,iti)
2774         EE(1,1,i-2)=eeold(1,1,iti)
2775       enddo
2776 #endif
2777 #ifdef PARMAT
2778       do i=ivec_start+2,ivec_end+2
2779 #else
2780       do i=3,nres+1
2781 #endif
2782         if (i .lt. nres+1) then
2783           sin1=dsin(phi(i))
2784           cos1=dcos(phi(i))
2785           sintab(i-2)=sin1
2786           costab(i-2)=cos1
2787           obrot(1,i-2)=cos1
2788           obrot(2,i-2)=sin1
2789           sin2=dsin(2*phi(i))
2790           cos2=dcos(2*phi(i))
2791           sintab2(i-2)=sin2
2792           costab2(i-2)=cos2
2793           obrot2(1,i-2)=cos2
2794           obrot2(2,i-2)=sin2
2795           Ug(1,1,i-2)=-cos1
2796           Ug(1,2,i-2)=-sin1
2797           Ug(2,1,i-2)=-sin1
2798           Ug(2,2,i-2)= cos1
2799           Ug2(1,1,i-2)=-cos2
2800           Ug2(1,2,i-2)=-sin2
2801           Ug2(2,1,i-2)=-sin2
2802           Ug2(2,2,i-2)= cos2
2803         else
2804           costab(i-2)=1.0d0
2805           sintab(i-2)=0.0d0
2806           obrot(1,i-2)=1.0d0
2807           obrot(2,i-2)=0.0d0
2808           obrot2(1,i-2)=0.0d0
2809           obrot2(2,i-2)=0.0d0
2810           Ug(1,1,i-2)=1.0d0
2811           Ug(1,2,i-2)=0.0d0
2812           Ug(2,1,i-2)=0.0d0
2813           Ug(2,2,i-2)=1.0d0
2814           Ug2(1,1,i-2)=0.0d0
2815           Ug2(1,2,i-2)=0.0d0
2816           Ug2(2,1,i-2)=0.0d0
2817           Ug2(2,2,i-2)=0.0d0
2818         endif
2819         if (i .gt. 3 .and. i .lt. nres+1) then
2820           obrot_der(1,i-2)=-sin1
2821           obrot_der(2,i-2)= cos1
2822           Ugder(1,1,i-2)= sin1
2823           Ugder(1,2,i-2)=-cos1
2824           Ugder(2,1,i-2)=-cos1
2825           Ugder(2,2,i-2)=-sin1
2826           dwacos2=cos2+cos2
2827           dwasin2=sin2+sin2
2828           obrot2_der(1,i-2)=-dwasin2
2829           obrot2_der(2,i-2)= dwacos2
2830           Ug2der(1,1,i-2)= dwasin2
2831           Ug2der(1,2,i-2)=-dwacos2
2832           Ug2der(2,1,i-2)=-dwacos2
2833           Ug2der(2,2,i-2)=-dwasin2
2834         else
2835           obrot_der(1,i-2)=0.0d0
2836           obrot_der(2,i-2)=0.0d0
2837           Ugder(1,1,i-2)=0.0d0
2838           Ugder(1,2,i-2)=0.0d0
2839           Ugder(2,1,i-2)=0.0d0
2840           Ugder(2,2,i-2)=0.0d0
2841           obrot2_der(1,i-2)=0.0d0
2842           obrot2_der(2,i-2)=0.0d0
2843           Ug2der(1,1,i-2)=0.0d0
2844           Ug2der(1,2,i-2)=0.0d0
2845           Ug2der(2,1,i-2)=0.0d0
2846           Ug2der(2,2,i-2)=0.0d0
2847         endif
2848 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2849         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2850           iti = itortyp(itype(i-2))
2851         else
2852           iti=ntortyp
2853         endif
2854 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2855         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2856           iti1 = itortyp(itype(i-1))
2857         else
2858           iti1=ntortyp
2859         endif
2860 cd        write (iout,*) '*******i',i,' iti1',iti
2861 cd        write (iout,*) 'b1',b1(:,iti)
2862 cd        write (iout,*) 'b2',b2(:,iti)
2863 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2864 c        if (i .gt. iatel_s+2) then
2865         if (i .gt. nnt+2) then
2866           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2867 #ifdef NEWCORR
2868           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2869 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2870 #endif
2871 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2872 c     &    EE(1,2,iti),EE(2,2,iti)
2873           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2874           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2875 c          write(iout,*) "Macierz EUG",
2876 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2877 c     &    eug(2,2,i-2)
2878           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2879      &    then
2880           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2881           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2882           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2883           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2884           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2885           endif
2886         else
2887           do k=1,2
2888             Ub2(k,i-2)=0.0d0
2889             Ctobr(k,i-2)=0.0d0
2890             Dtobr2(k,i-2)=0.0d0
2891             do l=1,2
2892               EUg(l,k,i-2)=0.0d0
2893               CUg(l,k,i-2)=0.0d0
2894               DUg(l,k,i-2)=0.0d0
2895               DtUg2(l,k,i-2)=0.0d0
2896             enddo
2897           enddo
2898         endif
2899         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2900         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2901         do k=1,2
2902           muder(k,i-2)=Ub2der(k,i-2)
2903         enddo
2904 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2905         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2906           if (itype(i-1).le.ntyp) then
2907             iti1 = itortyp(itype(i-1))
2908           else
2909             iti1=ntortyp
2910           endif
2911         else
2912           iti1=ntortyp
2913         endif
2914         do k=1,2
2915           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2916         enddo
2917 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2918 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2919 cd        write (iout,*) 'mu1',mu1(:,i-2)
2920 cd        write (iout,*) 'mu2',mu2(:,i-2)
2921         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2922      &  then
2923         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2924         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2925         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2926         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2927         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2928 C Vectors and matrices dependent on a single virtual-bond dihedral.
2929         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2930         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2931         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2932         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2933         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2934         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2935         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2936         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2937         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2938         endif
2939       enddo
2940 C Matrices dependent on two consecutive virtual-bond dihedrals.
2941 C The order of matrices is from left to right.
2942       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2943      &then
2944 c      do i=max0(ivec_start,2),ivec_end
2945       do i=2,nres-1
2946         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2947         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2948         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2949         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2950         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2951         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2952         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2953         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2954       enddo
2955       endif
2956 #if defined(MPI) && defined(PARMAT)
2957 #ifdef DEBUG
2958 c      if (fg_rank.eq.0) then
2959         write (iout,*) "Arrays UG and UGDER before GATHER"
2960         do i=1,nres-1
2961           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2962      &     ((ug(l,k,i),l=1,2),k=1,2),
2963      &     ((ugder(l,k,i),l=1,2),k=1,2)
2964         enddo
2965         write (iout,*) "Arrays UG2 and UG2DER"
2966         do i=1,nres-1
2967           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2968      &     ((ug2(l,k,i),l=1,2),k=1,2),
2969      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2970         enddo
2971         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2972         do i=1,nres-1
2973           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2974      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2975      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2976         enddo
2977         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2978         do i=1,nres-1
2979           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2980      &     costab(i),sintab(i),costab2(i),sintab2(i)
2981         enddo
2982         write (iout,*) "Array MUDER"
2983         do i=1,nres-1
2984           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2985         enddo
2986 c      endif
2987 #endif
2988       if (nfgtasks.gt.1) then
2989         time00=MPI_Wtime()
2990 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2991 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2992 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2993 #ifdef MATGATHER
2994         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2995      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2996      &   FG_COMM1,IERR)
2997         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2998      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2999      &   FG_COMM1,IERR)
3000         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3001      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3002      &   FG_COMM1,IERR)
3003         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3004      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3005      &   FG_COMM1,IERR)
3006         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3007      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3008      &   FG_COMM1,IERR)
3009         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3010      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3011      &   FG_COMM1,IERR)
3012         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3013      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3014      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3015         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3016      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3017      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3018         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3019      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3020      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3021         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3022      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3023      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3024         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3025      &  then
3026         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3027      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3028      &   FG_COMM1,IERR)
3029         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3030      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3031      &   FG_COMM1,IERR)
3032         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3033      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3034      &   FG_COMM1,IERR)
3035        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3036      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3037      &   FG_COMM1,IERR)
3038         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3039      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3040      &   FG_COMM1,IERR)
3041         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3042      &   ivec_count(fg_rank1),
3043      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3044      &   FG_COMM1,IERR)
3045         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3046      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3047      &   FG_COMM1,IERR)
3048         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3049      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3050      &   FG_COMM1,IERR)
3051         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3052      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3053      &   FG_COMM1,IERR)
3054         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3055      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3056      &   FG_COMM1,IERR)
3057         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3058      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3061      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3062      &   FG_COMM1,IERR)
3063         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3064      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3065      &   FG_COMM1,IERR)
3066         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3067      &   ivec_count(fg_rank1),
3068      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3069      &   FG_COMM1,IERR)
3070         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3071      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3072      &   FG_COMM1,IERR)
3073        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3074      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3078      &   FG_COMM1,IERR)
3079        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3083      &   ivec_count(fg_rank1),
3084      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3085      &   FG_COMM1,IERR)
3086         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3087      &   ivec_count(fg_rank1),
3088      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3089      &   FG_COMM1,IERR)
3090         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3091      &   ivec_count(fg_rank1),
3092      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3093      &   MPI_MAT2,FG_COMM1,IERR)
3094         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3095      &   ivec_count(fg_rank1),
3096      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3097      &   MPI_MAT2,FG_COMM1,IERR)
3098         endif
3099 #else
3100 c Passes matrix info through the ring
3101       isend=fg_rank1
3102       irecv=fg_rank1-1
3103       if (irecv.lt.0) irecv=nfgtasks1-1
3104       iprev=irecv
3105       inext=fg_rank1+1
3106       if (inext.ge.nfgtasks1) inext=0
3107       do i=1,nfgtasks1-1
3108 c        write (iout,*) "isend",isend," irecv",irecv
3109 c        call flush(iout)
3110         lensend=lentyp(isend)
3111         lenrecv=lentyp(irecv)
3112 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3113 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3114 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3115 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3116 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3117 c        write (iout,*) "Gather ROTAT1"
3118 c        call flush(iout)
3119 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3120 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3121 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3122 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3123 c        write (iout,*) "Gather ROTAT2"
3124 c        call flush(iout)
3125         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3126      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3127      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3128      &   iprev,4400+irecv,FG_COMM,status,IERR)
3129 c        write (iout,*) "Gather ROTAT_OLD"
3130 c        call flush(iout)
3131         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3132      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3133      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3134      &   iprev,5500+irecv,FG_COMM,status,IERR)
3135 c        write (iout,*) "Gather PRECOMP11"
3136 c        call flush(iout)
3137         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3138      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3139      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3140      &   iprev,6600+irecv,FG_COMM,status,IERR)
3141 c        write (iout,*) "Gather PRECOMP12"
3142 c        call flush(iout)
3143         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3144      &  then
3145         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3146      &   MPI_ROTAT2(lensend),inext,7700+isend,
3147      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3148      &   iprev,7700+irecv,FG_COMM,status,IERR)
3149 c        write (iout,*) "Gather PRECOMP21"
3150 c        call flush(iout)
3151         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3152      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3153      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3154      &   iprev,8800+irecv,FG_COMM,status,IERR)
3155 c        write (iout,*) "Gather PRECOMP22"
3156 c        call flush(iout)
3157         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3158      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3159      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3160      &   MPI_PRECOMP23(lenrecv),
3161      &   iprev,9900+irecv,FG_COMM,status,IERR)
3162 c        write (iout,*) "Gather PRECOMP23"
3163 c        call flush(iout)
3164         endif
3165         isend=irecv
3166         irecv=irecv-1
3167         if (irecv.lt.0) irecv=nfgtasks1-1
3168       enddo
3169 #endif
3170         time_gather=time_gather+MPI_Wtime()-time00
3171       endif
3172 #ifdef DEBUG
3173 c      if (fg_rank.eq.0) then
3174         write (iout,*) "Arrays UG and UGDER"
3175         do i=1,nres-1
3176           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3177      &     ((ug(l,k,i),l=1,2),k=1,2),
3178      &     ((ugder(l,k,i),l=1,2),k=1,2)
3179         enddo
3180         write (iout,*) "Arrays UG2 and UG2DER"
3181         do i=1,nres-1
3182           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3183      &     ((ug2(l,k,i),l=1,2),k=1,2),
3184      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3185         enddo
3186         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3187         do i=1,nres-1
3188           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3189      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3190      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3191         enddo
3192         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3193         do i=1,nres-1
3194           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3195      &     costab(i),sintab(i),costab2(i),sintab2(i)
3196         enddo
3197         write (iout,*) "Array MUDER"
3198         do i=1,nres-1
3199           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3200         enddo
3201 c      endif
3202 #endif
3203 #endif
3204 cd      do i=1,nres
3205 cd        iti = itortyp(itype(i))
3206 cd        write (iout,*) i
3207 cd        do j=1,2
3208 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3209 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3210 cd        enddo
3211 cd      enddo
3212       return
3213       end
3214 C--------------------------------------------------------------------------
3215       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3216 C
3217 C This subroutine calculates the average interaction energy and its gradient
3218 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3219 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3220 C The potential depends both on the distance of peptide-group centers and on
3221 C the orientation of the CA-CA virtual bonds.
3222 C
3223       implicit real*8 (a-h,o-z)
3224 #ifdef MPI
3225       include 'mpif.h'
3226 #endif
3227       include 'DIMENSIONS'
3228       include 'COMMON.CONTROL'
3229       include 'COMMON.SETUP'
3230       include 'COMMON.IOUNITS'
3231       include 'COMMON.GEO'
3232       include 'COMMON.VAR'
3233       include 'COMMON.LOCAL'
3234       include 'COMMON.CHAIN'
3235       include 'COMMON.DERIV'
3236       include 'COMMON.INTERACT'
3237       include 'COMMON.CONTACTS'
3238       include 'COMMON.TORSION'
3239       include 'COMMON.VECTORS'
3240       include 'COMMON.FFIELD'
3241       include 'COMMON.TIME1'
3242       include 'COMMON.SPLITELE'
3243       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3244      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3245       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3246      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3247       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3248      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3249      &    num_conti,j1,j2
3250 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3251 #ifdef MOMENT
3252       double precision scal_el /1.0d0/
3253 #else
3254       double precision scal_el /0.5d0/
3255 #endif
3256 C 12/13/98
3257 C 13-go grudnia roku pamietnego...
3258       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3259      &                   0.0d0,1.0d0,0.0d0,
3260      &                   0.0d0,0.0d0,1.0d0/
3261 cd      write(iout,*) 'In EELEC'
3262 cd      do i=1,nloctyp
3263 cd        write(iout,*) 'Type',i
3264 cd        write(iout,*) 'B1',B1(:,i)
3265 cd        write(iout,*) 'B2',B2(:,i)
3266 cd        write(iout,*) 'CC',CC(:,:,i)
3267 cd        write(iout,*) 'DD',DD(:,:,i)
3268 cd        write(iout,*) 'EE',EE(:,:,i)
3269 cd      enddo
3270 cd      call check_vecgrad
3271 cd      stop
3272       if (icheckgrad.eq.1) then
3273         do i=1,nres-1
3274           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3275           do k=1,3
3276             dc_norm(k,i)=dc(k,i)*fac
3277           enddo
3278 c          write (iout,*) 'i',i,' fac',fac
3279         enddo
3280       endif
3281       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3282      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3283      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3284 c        call vec_and_deriv
3285 #ifdef TIMING
3286         time01=MPI_Wtime()
3287 #endif
3288         call set_matrices
3289 #ifdef TIMING
3290         time_mat=time_mat+MPI_Wtime()-time01
3291 #endif
3292       endif
3293 cd      do i=1,nres-1
3294 cd        write (iout,*) 'i=',i
3295 cd        do k=1,3
3296 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3297 cd        enddo
3298 cd        do k=1,3
3299 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3300 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3301 cd        enddo
3302 cd      enddo
3303       t_eelecij=0.0d0
3304       ees=0.0D0
3305       evdw1=0.0D0
3306       eel_loc=0.0d0
3307       eello_turn3=0.0d0
3308       eello_turn4=0.0d0
3309       ind=0
3310       do i=1,nres
3311         num_cont_hb(i)=0
3312       enddo
3313 cd      print '(a)','Enter EELEC'
3314 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3315       do i=1,nres
3316         gel_loc_loc(i)=0.0d0
3317         gcorr_loc(i)=0.0d0
3318       enddo
3319 c
3320 c
3321 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3322 C
3323 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3324 C
3325 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3326       do i=iturn3_start,iturn3_end
3327         if (i.le.1) cycle
3328 C        write(iout,*) "tu jest i",i
3329         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3330 C changes suggested by Ana to avoid out of bounds
3331      & .or.((i+4).gt.nres)
3332      & .or.((i-1).le.0)
3333 C end of changes by Ana
3334      &  .or. itype(i+2).eq.ntyp1
3335      &  .or. itype(i+3).eq.ntyp1) cycle
3336         if(i.gt.1)then
3337           if(itype(i-1).eq.ntyp1)cycle
3338         end if
3339         if(i.LT.nres-3)then
3340           if (itype(i+4).eq.ntyp1) cycle
3341         end if
3342         dxi=dc(1,i)
3343         dyi=dc(2,i)
3344         dzi=dc(3,i)
3345         dx_normi=dc_norm(1,i)
3346         dy_normi=dc_norm(2,i)
3347         dz_normi=dc_norm(3,i)
3348         xmedi=c(1,i)+0.5d0*dxi
3349         ymedi=c(2,i)+0.5d0*dyi
3350         zmedi=c(3,i)+0.5d0*dzi
3351           xmedi=mod(xmedi,boxxsize)
3352           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3353           ymedi=mod(ymedi,boxysize)
3354           if (ymedi.lt.0) ymedi=ymedi+boxysize
3355           zmedi=mod(zmedi,boxzsize)
3356           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3357         num_conti=0
3358         call eelecij(i,i+2,ees,evdw1,eel_loc)
3359         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3360         num_cont_hb(i)=num_conti
3361       enddo
3362       do i=iturn4_start,iturn4_end
3363         if (i.le.1) cycle
3364         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3365 C changes suggested by Ana to avoid out of bounds
3366      & .or.((i+5).gt.nres)
3367      & .or.((i-1).le.0)
3368 C end of changes suggested by Ana
3369      &    .or. itype(i+3).eq.ntyp1
3370      &    .or. itype(i+4).eq.ntyp1
3371      &    .or. itype(i+5).eq.ntyp1
3372      &    .or. itype(i).eq.ntyp1
3373      &    .or. itype(i-1).eq.ntyp1
3374      &                             ) cycle
3375         dxi=dc(1,i)
3376         dyi=dc(2,i)
3377         dzi=dc(3,i)
3378         dx_normi=dc_norm(1,i)
3379         dy_normi=dc_norm(2,i)
3380         dz_normi=dc_norm(3,i)
3381         xmedi=c(1,i)+0.5d0*dxi
3382         ymedi=c(2,i)+0.5d0*dyi
3383         zmedi=c(3,i)+0.5d0*dzi
3384 C Return atom into box, boxxsize is size of box in x dimension
3385 c  194   continue
3386 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3387 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3388 C Condition for being inside the proper box
3389 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3390 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3391 c        go to 194
3392 c        endif
3393 c  195   continue
3394 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3395 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3396 C Condition for being inside the proper box
3397 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3398 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3399 c        go to 195
3400 c        endif
3401 c  196   continue
3402 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3403 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3404 C Condition for being inside the proper box
3405 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3406 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3407 c        go to 196
3408 c        endif
3409           xmedi=mod(xmedi,boxxsize)
3410           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3411           ymedi=mod(ymedi,boxysize)
3412           if (ymedi.lt.0) ymedi=ymedi+boxysize
3413           zmedi=mod(zmedi,boxzsize)
3414           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3415
3416         num_conti=num_cont_hb(i)
3417 c        write(iout,*) "JESTEM W PETLI"
3418         call eelecij(i,i+3,ees,evdw1,eel_loc)
3419         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3420      &   call eturn4(i,eello_turn4)
3421         num_cont_hb(i)=num_conti
3422       enddo   ! i
3423 C Loop over all neighbouring boxes
3424 C      do xshift=-1,1
3425 C      do yshift=-1,1
3426 C      do zshift=-1,1
3427 c
3428 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3429 c
3430       do i=iatel_s,iatel_e
3431         if (i.le.1) cycle
3432         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3433 C changes suggested by Ana to avoid out of bounds
3434      & .or.((i+2).gt.nres)
3435      & .or.((i-1).le.0)
3436 C end of changes by Ana
3437      &  .or. itype(i+2).eq.ntyp1
3438      &  .or. itype(i-1).eq.ntyp1
3439      &                ) cycle
3440         dxi=dc(1,i)
3441         dyi=dc(2,i)
3442         dzi=dc(3,i)
3443         dx_normi=dc_norm(1,i)
3444         dy_normi=dc_norm(2,i)
3445         dz_normi=dc_norm(3,i)
3446         xmedi=c(1,i)+0.5d0*dxi
3447         ymedi=c(2,i)+0.5d0*dyi
3448         zmedi=c(3,i)+0.5d0*dzi
3449           xmedi=mod(xmedi,boxxsize)
3450           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3451           ymedi=mod(ymedi,boxysize)
3452           if (ymedi.lt.0) ymedi=ymedi+boxysize
3453           zmedi=mod(zmedi,boxzsize)
3454           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3455 C          xmedi=xmedi+xshift*boxxsize
3456 C          ymedi=ymedi+yshift*boxysize
3457 C          zmedi=zmedi+zshift*boxzsize
3458
3459 C Return tom into box, boxxsize is size of box in x dimension
3460 c  164   continue
3461 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3462 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3463 C Condition for being inside the proper box
3464 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3465 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3466 c        go to 164
3467 c        endif
3468 c  165   continue
3469 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3470 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3471 C Condition for being inside the proper box
3472 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3473 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3474 c        go to 165
3475 c        endif
3476 c  166   continue
3477 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3478 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3479 cC Condition for being inside the proper box
3480 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3481 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3482 c        go to 166
3483 c        endif
3484
3485 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3486         num_conti=num_cont_hb(i)
3487         do j=ielstart(i),ielend(i)
3488 C          write (iout,*) i,j
3489          if (j.le.1) cycle
3490           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3491 C changes suggested by Ana to avoid out of bounds
3492      & .or.((j+2).gt.nres)
3493      & .or.((j-1).le.0)
3494 C end of changes by Ana
3495      & .or.itype(j+2).eq.ntyp1
3496      & .or.itype(j-1).eq.ntyp1
3497      &) cycle
3498           call eelecij(i,j,ees,evdw1,eel_loc)
3499         enddo ! j
3500         num_cont_hb(i)=num_conti
3501       enddo   ! i
3502 C     enddo   ! zshift
3503 C      enddo   ! yshift
3504 C      enddo   ! xshift
3505
3506 c      write (iout,*) "Number of loop steps in EELEC:",ind
3507 cd      do i=1,nres
3508 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3509 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3510 cd      enddo
3511 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3512 ccc      eel_loc=eel_loc+eello_turn3
3513 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3514       return
3515       end
3516 C-------------------------------------------------------------------------------
3517       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3518       implicit real*8 (a-h,o-z)
3519       include 'DIMENSIONS'
3520 #ifdef MPI
3521       include "mpif.h"
3522 #endif
3523       include 'COMMON.CONTROL'
3524       include 'COMMON.IOUNITS'
3525       include 'COMMON.GEO'
3526       include 'COMMON.VAR'
3527       include 'COMMON.LOCAL'
3528       include 'COMMON.CHAIN'
3529       include 'COMMON.DERIV'
3530       include 'COMMON.INTERACT'
3531       include 'COMMON.CONTACTS'
3532       include 'COMMON.TORSION'
3533       include 'COMMON.VECTORS'
3534       include 'COMMON.FFIELD'
3535       include 'COMMON.TIME1'
3536       include 'COMMON.SPLITELE'
3537       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3538      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3539       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3540      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3541      &    gmuij2(4),gmuji2(4)
3542       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3543      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3544      &    num_conti,j1,j2
3545 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3546 #ifdef MOMENT
3547       double precision scal_el /1.0d0/
3548 #else
3549       double precision scal_el /0.5d0/
3550 #endif
3551 C 12/13/98
3552 C 13-go grudnia roku pamietnego...
3553       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3554      &                   0.0d0,1.0d0,0.0d0,
3555      &                   0.0d0,0.0d0,1.0d0/
3556 c          time00=MPI_Wtime()
3557 cd      write (iout,*) "eelecij",i,j
3558 c          ind=ind+1
3559           iteli=itel(i)
3560           itelj=itel(j)
3561           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3562           aaa=app(iteli,itelj)
3563           bbb=bpp(iteli,itelj)
3564           ael6i=ael6(iteli,itelj)
3565           ael3i=ael3(iteli,itelj)
3566           dxj=dc(1,j)
3567           dyj=dc(2,j)
3568           dzj=dc(3,j)
3569           dx_normj=dc_norm(1,j)
3570           dy_normj=dc_norm(2,j)
3571           dz_normj=dc_norm(3,j)
3572 C          xj=c(1,j)+0.5D0*dxj-xmedi
3573 C          yj=c(2,j)+0.5D0*dyj-ymedi
3574 C          zj=c(3,j)+0.5D0*dzj-zmedi
3575           xj=c(1,j)+0.5D0*dxj
3576           yj=c(2,j)+0.5D0*dyj
3577           zj=c(3,j)+0.5D0*dzj
3578           xj=mod(xj,boxxsize)
3579           if (xj.lt.0) xj=xj+boxxsize
3580           yj=mod(yj,boxysize)
3581           if (yj.lt.0) yj=yj+boxysize
3582           zj=mod(zj,boxzsize)
3583           if (zj.lt.0) zj=zj+boxzsize
3584           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3585       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3586       xj_safe=xj
3587       yj_safe=yj
3588       zj_safe=zj
3589       isubchap=0
3590       do xshift=-1,1
3591       do yshift=-1,1
3592       do zshift=-1,1
3593           xj=xj_safe+xshift*boxxsize
3594           yj=yj_safe+yshift*boxysize
3595           zj=zj_safe+zshift*boxzsize
3596           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3597           if(dist_temp.lt.dist_init) then
3598             dist_init=dist_temp
3599             xj_temp=xj
3600             yj_temp=yj
3601             zj_temp=zj
3602             isubchap=1
3603           endif
3604        enddo
3605        enddo
3606        enddo
3607        if (isubchap.eq.1) then
3608           xj=xj_temp-xmedi
3609           yj=yj_temp-ymedi
3610           zj=zj_temp-zmedi
3611        else
3612           xj=xj_safe-xmedi
3613           yj=yj_safe-ymedi
3614           zj=zj_safe-zmedi
3615        endif
3616 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3617 c  174   continue
3618 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3619 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3620 C Condition for being inside the proper box
3621 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3622 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3623 c        go to 174
3624 c        endif
3625 c  175   continue
3626 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3627 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3628 C Condition for being inside the proper box
3629 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3630 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3631 c        go to 175
3632 c        endif
3633 c  176   continue
3634 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3635 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3636 C Condition for being inside the proper box
3637 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3638 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3639 c        go to 176
3640 c        endif
3641 C        endif !endPBC condintion
3642 C        xj=xj-xmedi
3643 C        yj=yj-ymedi
3644 C        zj=zj-zmedi
3645           rij=xj*xj+yj*yj+zj*zj
3646
3647             sss=sscale(sqrt(rij))
3648             sssgrad=sscagrad(sqrt(rij))
3649 c            if (sss.gt.0.0d0) then
3650           rrmij=1.0D0/rij
3651           rij=dsqrt(rij)
3652           rmij=1.0D0/rij
3653           r3ij=rrmij*rmij
3654           r6ij=r3ij*r3ij
3655           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3656           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3657           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3658           fac=cosa-3.0D0*cosb*cosg
3659           ev1=aaa*r6ij*r6ij
3660 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3661           if (j.eq.i+2) ev1=scal_el*ev1
3662           ev2=bbb*r6ij
3663           fac3=ael6i*r6ij
3664           fac4=ael3i*r3ij
3665           evdwij=(ev1+ev2)
3666           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3667           el2=fac4*fac
3668 C MARYSIA
3669           eesij=(el1+el2)
3670 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3671           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3672           ees=ees+eesij
3673           evdw1=evdw1+evdwij*sss
3674 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3675 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3676 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3677 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3678
3679           if (energy_dec) then
3680               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3681      &'evdw1',i,j,evdwij
3682 c     &,iteli,itelj,aaa,evdw1
3683               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3684           endif
3685
3686 C
3687 C Calculate contributions to the Cartesian gradient.
3688 C
3689 #ifdef SPLITELE
3690           facvdw=-6*rrmij*(ev1+evdwij)*sss
3691           facel=-3*rrmij*(el1+eesij)
3692           fac1=fac
3693           erij(1)=xj*rmij
3694           erij(2)=yj*rmij
3695           erij(3)=zj*rmij
3696 *
3697 * Radial derivatives. First process both termini of the fragment (i,j)
3698 *
3699           ggg(1)=facel*xj
3700           ggg(2)=facel*yj
3701           ggg(3)=facel*zj
3702 c          do k=1,3
3703 c            ghalf=0.5D0*ggg(k)
3704 c            gelc(k,i)=gelc(k,i)+ghalf
3705 c            gelc(k,j)=gelc(k,j)+ghalf
3706 c          enddo
3707 c 9/28/08 AL Gradient compotents will be summed only at the end
3708           do k=1,3
3709             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3710             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3711           enddo
3712 *
3713 * Loop over residues i+1 thru j-1.
3714 *
3715 cgrad          do k=i+1,j-1
3716 cgrad            do l=1,3
3717 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3718 cgrad            enddo
3719 cgrad          enddo
3720           if (sss.gt.0.0) then
3721           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3722           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3723           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3724           else
3725           ggg(1)=0.0
3726           ggg(2)=0.0
3727           ggg(3)=0.0
3728           endif
3729 c          do k=1,3
3730 c            ghalf=0.5D0*ggg(k)
3731 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3732 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3733 c          enddo
3734 c 9/28/08 AL Gradient compotents will be summed only at the end
3735           do k=1,3
3736             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3737             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3738           enddo
3739 *
3740 * Loop over residues i+1 thru j-1.
3741 *
3742 cgrad          do k=i+1,j-1
3743 cgrad            do l=1,3
3744 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3745 cgrad            enddo
3746 cgrad          enddo
3747 #else
3748 C MARYSIA
3749           facvdw=(ev1+evdwij)*sss
3750           facel=(el1+eesij)
3751           fac1=fac
3752           fac=-3*rrmij*(facvdw+facvdw+facel)
3753           erij(1)=xj*rmij
3754           erij(2)=yj*rmij
3755           erij(3)=zj*rmij
3756 *
3757 * Radial derivatives. First process both termini of the fragment (i,j)
3758 *
3759           ggg(1)=fac*xj
3760           ggg(2)=fac*yj
3761           ggg(3)=fac*zj
3762 c          do k=1,3
3763 c            ghalf=0.5D0*ggg(k)
3764 c            gelc(k,i)=gelc(k,i)+ghalf
3765 c            gelc(k,j)=gelc(k,j)+ghalf
3766 c          enddo
3767 c 9/28/08 AL Gradient compotents will be summed only at the end
3768           do k=1,3
3769             gelc_long(k,j)=gelc(k,j)+ggg(k)
3770             gelc_long(k,i)=gelc(k,i)-ggg(k)
3771           enddo
3772 *
3773 * Loop over residues i+1 thru j-1.
3774 *
3775 cgrad          do k=i+1,j-1
3776 cgrad            do l=1,3
3777 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3778 cgrad            enddo
3779 cgrad          enddo
3780 c 9/28/08 AL Gradient compotents will be summed only at the end
3781           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3782           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3783           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3784           do k=1,3
3785             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3786             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3787           enddo
3788 #endif
3789 *
3790 * Angular part
3791 *
3792           ecosa=2.0D0*fac3*fac1+fac4
3793           fac4=-3.0D0*fac4
3794           fac3=-6.0D0*fac3
3795           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3796           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3797           do k=1,3
3798             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3799             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3800           enddo
3801 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3802 cd   &          (dcosg(k),k=1,3)
3803           do k=1,3
3804             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3805           enddo
3806 c          do k=1,3
3807 c            ghalf=0.5D0*ggg(k)
3808 c            gelc(k,i)=gelc(k,i)+ghalf
3809 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3810 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3811 c            gelc(k,j)=gelc(k,j)+ghalf
3812 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3813 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3814 c          enddo
3815 cgrad          do k=i+1,j-1
3816 cgrad            do l=1,3
3817 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3818 cgrad            enddo
3819 cgrad          enddo
3820           do k=1,3
3821             gelc(k,i)=gelc(k,i)
3822      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3823      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3824             gelc(k,j)=gelc(k,j)
3825      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3826      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3827             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3828             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3829           enddo
3830 C MARYSIA
3831 c          endif !sscale
3832           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3833      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3834      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3835 C
3836 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3837 C   energy of a peptide unit is assumed in the form of a second-order
3838 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3839 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3840 C   are computed for EVERY pair of non-contiguous peptide groups.
3841 C
3842
3843           if (j.lt.nres-1) then
3844             j1=j+1
3845             j2=j-1
3846           else
3847             j1=j-1
3848             j2=j-2
3849           endif
3850           kkk=0
3851           lll=0
3852           do k=1,2
3853             do l=1,2
3854               kkk=kkk+1
3855               muij(kkk)=mu(k,i)*mu(l,j)
3856 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3857 #ifdef NEWCORR
3858              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3859 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3860              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3861              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3862 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3863              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3864 #endif
3865             enddo
3866           enddo
3867 cd         write (iout,*) 'EELEC: i',i,' j',j
3868 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3869 cd          write(iout,*) 'muij',muij
3870           ury=scalar(uy(1,i),erij)
3871           urz=scalar(uz(1,i),erij)
3872           vry=scalar(uy(1,j),erij)
3873           vrz=scalar(uz(1,j),erij)
3874           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3875           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3876           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3877           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3878           fac=dsqrt(-ael6i)*r3ij
3879           a22=a22*fac
3880           a23=a23*fac
3881           a32=a32*fac
3882           a33=a33*fac
3883 cd          write (iout,'(4i5,4f10.5)')
3884 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3885 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3886 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3887 cd     &      uy(:,j),uz(:,j)
3888 cd          write (iout,'(4f10.5)')
3889 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3890 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3891 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3892 cd           write (iout,'(9f10.5/)')
3893 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3894 C Derivatives of the elements of A in virtual-bond vectors
3895           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3896           do k=1,3
3897             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3898             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3899             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3900             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3901             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3902             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3903             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3904             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3905             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3906             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3907             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3908             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3909           enddo
3910 C Compute radial contributions to the gradient
3911           facr=-3.0d0*rrmij
3912           a22der=a22*facr
3913           a23der=a23*facr
3914           a32der=a32*facr
3915           a33der=a33*facr
3916           agg(1,1)=a22der*xj
3917           agg(2,1)=a22der*yj
3918           agg(3,1)=a22der*zj
3919           agg(1,2)=a23der*xj
3920           agg(2,2)=a23der*yj
3921           agg(3,2)=a23der*zj
3922           agg(1,3)=a32der*xj
3923           agg(2,3)=a32der*yj
3924           agg(3,3)=a32der*zj
3925           agg(1,4)=a33der*xj
3926           agg(2,4)=a33der*yj
3927           agg(3,4)=a33der*zj
3928 C Add the contributions coming from er
3929           fac3=-3.0d0*fac
3930           do k=1,3
3931             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3932             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3933             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3934             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3935           enddo
3936           do k=1,3
3937 C Derivatives in DC(i)
3938 cgrad            ghalf1=0.5d0*agg(k,1)
3939 cgrad            ghalf2=0.5d0*agg(k,2)
3940 cgrad            ghalf3=0.5d0*agg(k,3)
3941 cgrad            ghalf4=0.5d0*agg(k,4)
3942             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3943      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3944             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3945      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3946             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3947      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3948             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3949      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3950 C Derivatives in DC(i+1)
3951             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3952      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3953             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3954      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3955             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3956      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3957             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3958      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3959 C Derivatives in DC(j)
3960             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3961      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3962             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3963      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3964             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3965      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3966             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3967      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3968 C Derivatives in DC(j+1) or DC(nres-1)
3969             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3970      &      -3.0d0*vryg(k,3)*ury)
3971             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3972      &      -3.0d0*vrzg(k,3)*ury)
3973             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3974      &      -3.0d0*vryg(k,3)*urz)
3975             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3976      &      -3.0d0*vrzg(k,3)*urz)
3977 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3978 cgrad              do l=1,4
3979 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3980 cgrad              enddo
3981 cgrad            endif
3982           enddo
3983           acipa(1,1)=a22
3984           acipa(1,2)=a23
3985           acipa(2,1)=a32
3986           acipa(2,2)=a33
3987           a22=-a22
3988           a23=-a23
3989           do l=1,2
3990             do k=1,3
3991               agg(k,l)=-agg(k,l)
3992               aggi(k,l)=-aggi(k,l)
3993               aggi1(k,l)=-aggi1(k,l)
3994               aggj(k,l)=-aggj(k,l)
3995               aggj1(k,l)=-aggj1(k,l)
3996             enddo
3997           enddo
3998           if (j.lt.nres-1) then
3999             a22=-a22
4000             a32=-a32
4001             do l=1,3,2
4002               do k=1,3
4003                 agg(k,l)=-agg(k,l)
4004                 aggi(k,l)=-aggi(k,l)
4005                 aggi1(k,l)=-aggi1(k,l)
4006                 aggj(k,l)=-aggj(k,l)
4007                 aggj1(k,l)=-aggj1(k,l)
4008               enddo
4009             enddo
4010           else
4011             a22=-a22
4012             a23=-a23
4013             a32=-a32
4014             a33=-a33
4015             do l=1,4
4016               do k=1,3
4017                 agg(k,l)=-agg(k,l)
4018                 aggi(k,l)=-aggi(k,l)
4019                 aggi1(k,l)=-aggi1(k,l)
4020                 aggj(k,l)=-aggj(k,l)
4021                 aggj1(k,l)=-aggj1(k,l)
4022               enddo
4023             enddo
4024           endif
4025           ENDIF ! WCORR
4026           IF (wel_loc.gt.0.0d0) THEN
4027 C Contribution to the local-electrostatic energy coming from the i-j pair
4028           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4029      &     +a33*muij(4)
4030 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4031 c     &                     ' eel_loc_ij',eel_loc_ij
4032 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4033 C Calculate patrial derivative for theta angle
4034 #ifdef NEWCORR
4035          geel_loc_ij=a22*gmuij1(1)
4036      &     +a23*gmuij1(2)
4037      &     +a32*gmuij1(3)
4038      &     +a33*gmuij1(4)
4039 c         write(iout,*) "derivative over thatai"
4040 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4041 c     &   a33*gmuij1(4)
4042          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4043      &      geel_loc_ij*wel_loc
4044 c         write(iout,*) "derivative over thatai-1"
4045 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4046 c     &   a33*gmuij2(4)
4047          geel_loc_ij=
4048      &     a22*gmuij2(1)
4049      &     +a23*gmuij2(2)
4050      &     +a32*gmuij2(3)
4051      &     +a33*gmuij2(4)
4052          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4053      &      geel_loc_ij*wel_loc
4054 c  Derivative over j residue
4055          geel_loc_ji=a22*gmuji1(1)
4056      &     +a23*gmuji1(2)
4057      &     +a32*gmuji1(3)
4058      &     +a33*gmuji1(4)
4059 c         write(iout,*) "derivative over thataj"
4060 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4061 c     &   a33*gmuji1(4)
4062
4063         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4064      &      geel_loc_ji*wel_loc
4065          geel_loc_ji=
4066      &     +a22*gmuji2(1)
4067      &     +a23*gmuji2(2)
4068      &     +a32*gmuji2(3)
4069      &     +a33*gmuji2(4)
4070 c         write(iout,*) "derivative over thataj-1"
4071 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4072 c     &   a33*gmuji2(4)
4073          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4074      &      geel_loc_ji*wel_loc
4075 #endif
4076 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4077
4078           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4079      &            'eelloc',i,j,eel_loc_ij
4080 c           if (eel_loc_ij.ne.0)
4081 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4082 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4083
4084           eel_loc=eel_loc+eel_loc_ij
4085 C Partial derivatives in virtual-bond dihedral angles gamma
4086           if (i.gt.1)
4087      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4088      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4089      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4090           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4091      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4092      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4093 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4094           do l=1,3
4095             ggg(l)=agg(l,1)*muij(1)+
4096      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4097             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4098             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4099 cgrad            ghalf=0.5d0*ggg(l)
4100 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4101 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4102           enddo
4103 cgrad          do k=i+1,j2
4104 cgrad            do l=1,3
4105 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4106 cgrad            enddo
4107 cgrad          enddo
4108 C Remaining derivatives of eello
4109           do l=1,3
4110             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4111      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4112             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4113      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4114             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4115      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4116             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4117      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4118           enddo
4119           ENDIF
4120 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4121 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4122           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4123      &       .and. num_conti.le.maxconts) then
4124 c            write (iout,*) i,j," entered corr"
4125 C
4126 C Calculate the contact function. The ith column of the array JCONT will
4127 C contain the numbers of atoms that make contacts with the atom I (of numbers
4128 C greater than I). The arrays FACONT and GACONT will contain the values of
4129 C the contact function and its derivative.
4130 c           r0ij=1.02D0*rpp(iteli,itelj)
4131 c           r0ij=1.11D0*rpp(iteli,itelj)
4132             r0ij=2.20D0*rpp(iteli,itelj)
4133 c           r0ij=1.55D0*rpp(iteli,itelj)
4134             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4135             if (fcont.gt.0.0D0) then
4136               num_conti=num_conti+1
4137               if (num_conti.gt.maxconts) then
4138                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4139      &                         ' will skip next contacts for this conf.'
4140               else
4141                 jcont_hb(num_conti,i)=j
4142 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4143 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4144                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4145      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4146 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4147 C  terms.
4148                 d_cont(num_conti,i)=rij
4149 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4150 C     --- Electrostatic-interaction matrix ---
4151                 a_chuj(1,1,num_conti,i)=a22
4152                 a_chuj(1,2,num_conti,i)=a23
4153                 a_chuj(2,1,num_conti,i)=a32
4154                 a_chuj(2,2,num_conti,i)=a33
4155 C     --- Gradient of rij
4156                 do kkk=1,3
4157                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4158                 enddo
4159                 kkll=0
4160                 do k=1,2
4161                   do l=1,2
4162                     kkll=kkll+1
4163                     do m=1,3
4164                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4165                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4166                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4167                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4168                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4169                     enddo
4170                   enddo
4171                 enddo
4172                 ENDIF
4173                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4174 C Calculate contact energies
4175                 cosa4=4.0D0*cosa
4176                 wij=cosa-3.0D0*cosb*cosg
4177                 cosbg1=cosb+cosg
4178                 cosbg2=cosb-cosg
4179 c               fac3=dsqrt(-ael6i)/r0ij**3
4180                 fac3=dsqrt(-ael6i)*r3ij
4181 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4182                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4183                 if (ees0tmp.gt.0) then
4184                   ees0pij=dsqrt(ees0tmp)
4185                 else
4186                   ees0pij=0
4187                 endif
4188 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4189                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4190                 if (ees0tmp.gt.0) then
4191                   ees0mij=dsqrt(ees0tmp)
4192                 else
4193                   ees0mij=0
4194                 endif
4195 c               ees0mij=0.0D0
4196                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4197                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4198 C Diagnostics. Comment out or remove after debugging!
4199 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4200 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4201 c               ees0m(num_conti,i)=0.0D0
4202 C End diagnostics.
4203 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4204 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4205 C Angular derivatives of the contact function
4206                 ees0pij1=fac3/ees0pij
4207                 ees0mij1=fac3/ees0mij
4208                 fac3p=-3.0D0*fac3*rrmij
4209                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4210                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4211 c               ees0mij1=0.0D0
4212                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4213                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4214                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4215                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4216                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4217                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4218                 ecosap=ecosa1+ecosa2
4219                 ecosbp=ecosb1+ecosb2
4220                 ecosgp=ecosg1+ecosg2
4221                 ecosam=ecosa1-ecosa2
4222                 ecosbm=ecosb1-ecosb2
4223                 ecosgm=ecosg1-ecosg2
4224 C Diagnostics
4225 c               ecosap=ecosa1
4226 c               ecosbp=ecosb1
4227 c               ecosgp=ecosg1
4228 c               ecosam=0.0D0
4229 c               ecosbm=0.0D0
4230 c               ecosgm=0.0D0
4231 C End diagnostics
4232                 facont_hb(num_conti,i)=fcont
4233                 fprimcont=fprimcont/rij
4234 cd              facont_hb(num_conti,i)=1.0D0
4235 C Following line is for diagnostics.
4236 cd              fprimcont=0.0D0
4237                 do k=1,3
4238                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4239                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4240                 enddo
4241                 do k=1,3
4242                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4243                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4244                 enddo
4245                 gggp(1)=gggp(1)+ees0pijp*xj
4246                 gggp(2)=gggp(2)+ees0pijp*yj
4247                 gggp(3)=gggp(3)+ees0pijp*zj
4248                 gggm(1)=gggm(1)+ees0mijp*xj
4249                 gggm(2)=gggm(2)+ees0mijp*yj
4250                 gggm(3)=gggm(3)+ees0mijp*zj
4251 C Derivatives due to the contact function
4252                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4253                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4254                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4255                 do k=1,3
4256 c
4257 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4258 c          following the change of gradient-summation algorithm.
4259 c
4260 cgrad                  ghalfp=0.5D0*gggp(k)
4261 cgrad                  ghalfm=0.5D0*gggm(k)
4262                   gacontp_hb1(k,num_conti,i)=!ghalfp
4263      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4264      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4265                   gacontp_hb2(k,num_conti,i)=!ghalfp
4266      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4267      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4268                   gacontp_hb3(k,num_conti,i)=gggp(k)
4269                   gacontm_hb1(k,num_conti,i)=!ghalfm
4270      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4271      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4272                   gacontm_hb2(k,num_conti,i)=!ghalfm
4273      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4274      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4275                   gacontm_hb3(k,num_conti,i)=gggm(k)
4276                 enddo
4277 C Diagnostics. Comment out or remove after debugging!
4278 cdiag           do k=1,3
4279 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4280 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4281 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4282 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4283 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4284 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4285 cdiag           enddo
4286               ENDIF ! wcorr
4287               endif  ! num_conti.le.maxconts
4288             endif  ! fcont.gt.0
4289           endif    ! j.gt.i+1
4290           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4291             do k=1,4
4292               do l=1,3
4293                 ghalf=0.5d0*agg(l,k)
4294                 aggi(l,k)=aggi(l,k)+ghalf
4295                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4296                 aggj(l,k)=aggj(l,k)+ghalf
4297               enddo
4298             enddo
4299             if (j.eq.nres-1 .and. i.lt.j-2) then
4300               do k=1,4
4301                 do l=1,3
4302                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4303                 enddo
4304               enddo
4305             endif
4306           endif
4307 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4308       return
4309       end
4310 C-----------------------------------------------------------------------------
4311       subroutine eturn3(i,eello_turn3)
4312 C Third- and fourth-order contributions from turns
4313       implicit real*8 (a-h,o-z)
4314       include 'DIMENSIONS'
4315       include 'COMMON.IOUNITS'
4316       include 'COMMON.GEO'
4317       include 'COMMON.VAR'
4318       include 'COMMON.LOCAL'
4319       include 'COMMON.CHAIN'
4320       include 'COMMON.DERIV'
4321       include 'COMMON.INTERACT'
4322       include 'COMMON.CONTACTS'
4323       include 'COMMON.TORSION'
4324       include 'COMMON.VECTORS'
4325       include 'COMMON.FFIELD'
4326       include 'COMMON.CONTROL'
4327       dimension ggg(3)
4328       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4329      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4330      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4331      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4332      &  auxgmat2(2,2),auxgmatt2(2,2)
4333       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4334      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4335       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4336      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4337      &    num_conti,j1,j2
4338       j=i+2
4339 c      write (iout,*) "eturn3",i,j,j1,j2
4340       a_temp(1,1)=a22
4341       a_temp(1,2)=a23
4342       a_temp(2,1)=a32
4343       a_temp(2,2)=a33
4344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4345 C
4346 C               Third-order contributions
4347 C
4348 C                 (i+2)o----(i+3)
4349 C                      | |
4350 C                      | |
4351 C                 (i+1)o----i
4352 C
4353 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4354 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4355         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4356 c auxalary matices for theta gradient
4357 c auxalary matrix for i+1 and constant i+2
4358         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4359 c auxalary matrix for i+2 and constant i+1
4360         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4361         call transpose2(auxmat(1,1),auxmat1(1,1))
4362         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4363         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4364         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4365         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4366         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4367         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4368 C Derivatives in theta
4369         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4370      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4371         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4372      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4373
4374         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4375      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4376 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4377 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4378 cd     &    ' eello_turn3_num',4*eello_turn3_num
4379 C Derivatives in gamma(i)
4380         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4381         call transpose2(auxmat2(1,1),auxmat3(1,1))
4382         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4383         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4384 C Derivatives in gamma(i+1)
4385         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4386         call transpose2(auxmat2(1,1),auxmat3(1,1))
4387         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4388         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4389      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4390 C Cartesian derivatives
4391         do l=1,3
4392 c            ghalf1=0.5d0*agg(l,1)
4393 c            ghalf2=0.5d0*agg(l,2)
4394 c            ghalf3=0.5d0*agg(l,3)
4395 c            ghalf4=0.5d0*agg(l,4)
4396           a_temp(1,1)=aggi(l,1)!+ghalf1
4397           a_temp(1,2)=aggi(l,2)!+ghalf2
4398           a_temp(2,1)=aggi(l,3)!+ghalf3
4399           a_temp(2,2)=aggi(l,4)!+ghalf4
4400           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4401           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4402      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4403           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4404           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4405           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4406           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4407           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4408           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4409      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4410           a_temp(1,1)=aggj(l,1)!+ghalf1
4411           a_temp(1,2)=aggj(l,2)!+ghalf2
4412           a_temp(2,1)=aggj(l,3)!+ghalf3
4413           a_temp(2,2)=aggj(l,4)!+ghalf4
4414           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4415           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4416      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4417           a_temp(1,1)=aggj1(l,1)
4418           a_temp(1,2)=aggj1(l,2)
4419           a_temp(2,1)=aggj1(l,3)
4420           a_temp(2,2)=aggj1(l,4)
4421           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4422           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4423      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4424         enddo
4425       return
4426       end
4427 C-------------------------------------------------------------------------------
4428       subroutine eturn4(i,eello_turn4)
4429 C Third- and fourth-order contributions from turns
4430       implicit real*8 (a-h,o-z)
4431       include 'DIMENSIONS'
4432       include 'COMMON.IOUNITS'
4433       include 'COMMON.GEO'
4434       include 'COMMON.VAR'
4435       include 'COMMON.LOCAL'
4436       include 'COMMON.CHAIN'
4437       include 'COMMON.DERIV'
4438       include 'COMMON.INTERACT'
4439       include 'COMMON.CONTACTS'
4440       include 'COMMON.TORSION'
4441       include 'COMMON.VECTORS'
4442       include 'COMMON.FFIELD'
4443       include 'COMMON.CONTROL'
4444       dimension ggg(3)
4445       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4446      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4447      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4448      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4449      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4450      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4451      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4452       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4453      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4454       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4455      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4456      &    num_conti,j1,j2
4457       j=i+3
4458 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4459 C
4460 C               Fourth-order contributions
4461 C
4462 C                 (i+3)o----(i+4)
4463 C                     /  |
4464 C               (i+2)o   |
4465 C                     \  |
4466 C                 (i+1)o----i
4467 C
4468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4469 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4470 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4471 c        write(iout,*)"WCHODZE W PROGRAM"
4472         a_temp(1,1)=a22
4473         a_temp(1,2)=a23
4474         a_temp(2,1)=a32
4475         a_temp(2,2)=a33
4476         iti1=itortyp(itype(i+1))
4477         iti2=itortyp(itype(i+2))
4478         iti3=itortyp(itype(i+3))
4479 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4480         call transpose2(EUg(1,1,i+1),e1t(1,1))
4481         call transpose2(Eug(1,1,i+2),e2t(1,1))
4482         call transpose2(Eug(1,1,i+3),e3t(1,1))
4483 C Ematrix derivative in theta
4484         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4485         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4486         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4487         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4488 c       eta1 in derivative theta
4489         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4490         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4491 c       auxgvec is derivative of Ub2 so i+3 theta
4492         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4493 c       auxalary matrix of E i+1
4494         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4495 c        s1=0.0
4496 c        gs1=0.0
4497         s1=scalar2(b1(1,i+2),auxvec(1))
4498 c derivative of theta i+2 with constant i+3
4499         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4500 c derivative of theta i+2 with constant i+2
4501         gs32=scalar2(b1(1,i+2),auxgvec(1))
4502 c derivative of E matix in theta of i+1
4503         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4504
4505         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4506 c       ea31 in derivative theta
4507         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4508         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4509 c auxilary matrix auxgvec of Ub2 with constant E matirx
4510         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4511 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4512         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4513
4514 c        s2=0.0
4515 c        gs2=0.0
4516         s2=scalar2(b1(1,i+1),auxvec(1))
4517 c derivative of theta i+1 with constant i+3
4518         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4519 c derivative of theta i+2 with constant i+1
4520         gs21=scalar2(b1(1,i+1),auxgvec(1))
4521 c derivative of theta i+3 with constant i+1
4522         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4523 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4524 c     &  gtb1(1,i+1)
4525         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4526 c two derivatives over diffetent matrices
4527 c gtae3e2 is derivative over i+3
4528         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4529 c ae3gte2 is derivative over i+2
4530         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4531         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4532 c three possible derivative over theta E matices
4533 c i+1
4534         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4535 c i+2
4536         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4537 c i+3
4538         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4539         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4540
4541         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4542         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4543         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4544
4545         eello_turn4=eello_turn4-(s1+s2+s3)
4546 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4547 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4548 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4549 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4550 cd     &    ' eello_turn4_num',8*eello_turn4_num
4551 #ifdef NEWCORR
4552         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4553      &                  -(gs13+gsE13+gsEE1)*wturn4
4554         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4555      &                    -(gs23+gs21+gsEE2)*wturn4
4556         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4557      &                    -(gs32+gsE31+gsEE3)*wturn4
4558 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4559 c     &   gs2
4560 #endif
4561         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4562      &      'eturn4',i,j,-(s1+s2+s3)
4563 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4564 c     &    ' eello_turn4_num',8*eello_turn4_num
4565 C Derivatives in gamma(i)
4566         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4567         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4568         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4569         s1=scalar2(b1(1,i+2),auxvec(1))
4570         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4571         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4572         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4573 C Derivatives in gamma(i+1)
4574         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4575         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4576         s2=scalar2(b1(1,i+1),auxvec(1))
4577         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4578         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4579         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4580         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4581 C Derivatives in gamma(i+2)
4582         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4583         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4584         s1=scalar2(b1(1,i+2),auxvec(1))
4585         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4586         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4587         s2=scalar2(b1(1,i+1),auxvec(1))
4588         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4589         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4590         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4591         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4592 C Cartesian derivatives
4593 C Derivatives of this turn contributions in DC(i+2)
4594         if (j.lt.nres-1) then
4595           do l=1,3
4596             a_temp(1,1)=agg(l,1)
4597             a_temp(1,2)=agg(l,2)
4598             a_temp(2,1)=agg(l,3)
4599             a_temp(2,2)=agg(l,4)
4600             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4601             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4602             s1=scalar2(b1(1,i+2),auxvec(1))
4603             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4604             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4605             s2=scalar2(b1(1,i+1),auxvec(1))
4606             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4607             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4608             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4609             ggg(l)=-(s1+s2+s3)
4610             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4611           enddo
4612         endif
4613 C Remaining derivatives of this turn contribution
4614         do l=1,3
4615           a_temp(1,1)=aggi(l,1)
4616           a_temp(1,2)=aggi(l,2)
4617           a_temp(2,1)=aggi(l,3)
4618           a_temp(2,2)=aggi(l,4)
4619           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4620           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4621           s1=scalar2(b1(1,i+2),auxvec(1))
4622           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4623           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4624           s2=scalar2(b1(1,i+1),auxvec(1))
4625           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4626           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4627           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4628           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4629           a_temp(1,1)=aggi1(l,1)
4630           a_temp(1,2)=aggi1(l,2)
4631           a_temp(2,1)=aggi1(l,3)
4632           a_temp(2,2)=aggi1(l,4)
4633           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4634           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4635           s1=scalar2(b1(1,i+2),auxvec(1))
4636           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4637           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4638           s2=scalar2(b1(1,i+1),auxvec(1))
4639           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4640           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4641           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4642           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4643           a_temp(1,1)=aggj(l,1)
4644           a_temp(1,2)=aggj(l,2)
4645           a_temp(2,1)=aggj(l,3)
4646           a_temp(2,2)=aggj(l,4)
4647           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4648           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4649           s1=scalar2(b1(1,i+2),auxvec(1))
4650           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4651           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4652           s2=scalar2(b1(1,i+1),auxvec(1))
4653           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4654           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4655           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4656           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4657           a_temp(1,1)=aggj1(l,1)
4658           a_temp(1,2)=aggj1(l,2)
4659           a_temp(2,1)=aggj1(l,3)
4660           a_temp(2,2)=aggj1(l,4)
4661           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4662           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4663           s1=scalar2(b1(1,i+2),auxvec(1))
4664           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4665           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4666           s2=scalar2(b1(1,i+1),auxvec(1))
4667           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4668           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4669           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4670 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4671           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4672         enddo
4673       return
4674       end
4675 C-----------------------------------------------------------------------------
4676       subroutine vecpr(u,v,w)
4677       implicit real*8(a-h,o-z)
4678       dimension u(3),v(3),w(3)
4679       w(1)=u(2)*v(3)-u(3)*v(2)
4680       w(2)=-u(1)*v(3)+u(3)*v(1)
4681       w(3)=u(1)*v(2)-u(2)*v(1)
4682       return
4683       end
4684 C-----------------------------------------------------------------------------
4685       subroutine unormderiv(u,ugrad,unorm,ungrad)
4686 C This subroutine computes the derivatives of a normalized vector u, given
4687 C the derivatives computed without normalization conditions, ugrad. Returns
4688 C ungrad.
4689       implicit none
4690       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4691       double precision vec(3)
4692       double precision scalar
4693       integer i,j
4694 c      write (2,*) 'ugrad',ugrad
4695 c      write (2,*) 'u',u
4696       do i=1,3
4697         vec(i)=scalar(ugrad(1,i),u(1))
4698       enddo
4699 c      write (2,*) 'vec',vec
4700       do i=1,3
4701         do j=1,3
4702           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4703         enddo
4704       enddo
4705 c      write (2,*) 'ungrad',ungrad
4706       return
4707       end
4708 C-----------------------------------------------------------------------------
4709       subroutine escp_soft_sphere(evdw2,evdw2_14)
4710 C
4711 C This subroutine calculates the excluded-volume interaction energy between
4712 C peptide-group centers and side chains and its gradient in virtual-bond and
4713 C side-chain vectors.
4714 C
4715       implicit real*8 (a-h,o-z)
4716       include 'DIMENSIONS'
4717       include 'COMMON.GEO'
4718       include 'COMMON.VAR'
4719       include 'COMMON.LOCAL'
4720       include 'COMMON.CHAIN'
4721       include 'COMMON.DERIV'
4722       include 'COMMON.INTERACT'
4723       include 'COMMON.FFIELD'
4724       include 'COMMON.IOUNITS'
4725       include 'COMMON.CONTROL'
4726       dimension ggg(3)
4727       evdw2=0.0D0
4728       evdw2_14=0.0d0
4729       r0_scp=4.5d0
4730 cd    print '(a)','Enter ESCP'
4731 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4732 C      do xshift=-1,1
4733 C      do yshift=-1,1
4734 C      do zshift=-1,1
4735       do i=iatscp_s,iatscp_e
4736         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4737         iteli=itel(i)
4738         xi=0.5D0*(c(1,i)+c(1,i+1))
4739         yi=0.5D0*(c(2,i)+c(2,i+1))
4740         zi=0.5D0*(c(3,i)+c(3,i+1))
4741 C Return atom into box, boxxsize is size of box in x dimension
4742 c  134   continue
4743 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4744 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4745 C Condition for being inside the proper box
4746 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4747 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4748 c        go to 134
4749 c        endif
4750 c  135   continue
4751 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4752 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4753 C Condition for being inside the proper box
4754 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4755 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4756 c        go to 135
4757 c c       endif
4758 c  136   continue
4759 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4760 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4761 cC Condition for being inside the proper box
4762 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4763 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4764 c        go to 136
4765 c        endif
4766           xi=mod(xi,boxxsize)
4767           if (xi.lt.0) xi=xi+boxxsize
4768           yi=mod(yi,boxysize)
4769           if (yi.lt.0) yi=yi+boxysize
4770           zi=mod(zi,boxzsize)
4771           if (zi.lt.0) zi=zi+boxzsize
4772 C          xi=xi+xshift*boxxsize
4773 C          yi=yi+yshift*boxysize
4774 C          zi=zi+zshift*boxzsize
4775         do iint=1,nscp_gr(i)
4776
4777         do j=iscpstart(i,iint),iscpend(i,iint)
4778           if (itype(j).eq.ntyp1) cycle
4779           itypj=iabs(itype(j))
4780 C Uncomment following three lines for SC-p interactions
4781 c         xj=c(1,nres+j)-xi
4782 c         yj=c(2,nres+j)-yi
4783 c         zj=c(3,nres+j)-zi
4784 C Uncomment following three lines for Ca-p interactions
4785           xj=c(1,j)
4786           yj=c(2,j)
4787           zj=c(3,j)
4788 c  174   continue
4789 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4790 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4791 C Condition for being inside the proper box
4792 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4793 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4794 c        go to 174
4795 c        endif
4796 c  175   continue
4797 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4798 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4799 cC Condition for being inside the proper box
4800 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4801 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4802 c        go to 175
4803 c        endif
4804 c  176   continue
4805 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4806 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4807 C Condition for being inside the proper box
4808 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4809 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4810 c        go to 176
4811           xj=mod(xj,boxxsize)
4812           if (xj.lt.0) xj=xj+boxxsize
4813           yj=mod(yj,boxysize)
4814           if (yj.lt.0) yj=yj+boxysize
4815           zj=mod(zj,boxzsize)
4816           if (zj.lt.0) zj=zj+boxzsize
4817       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4818       xj_safe=xj
4819       yj_safe=yj
4820       zj_safe=zj
4821       subchap=0
4822       do xshift=-1,1
4823       do yshift=-1,1
4824       do zshift=-1,1
4825           xj=xj_safe+xshift*boxxsize
4826           yj=yj_safe+yshift*boxysize
4827           zj=zj_safe+zshift*boxzsize
4828           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4829           if(dist_temp.lt.dist_init) then
4830             dist_init=dist_temp
4831             xj_temp=xj
4832             yj_temp=yj
4833             zj_temp=zj
4834             subchap=1
4835           endif
4836        enddo
4837        enddo
4838        enddo
4839        if (subchap.eq.1) then
4840           xj=xj_temp-xi
4841           yj=yj_temp-yi
4842           zj=zj_temp-zi
4843        else
4844           xj=xj_safe-xi
4845           yj=yj_safe-yi
4846           zj=zj_safe-zi
4847        endif
4848 c c       endif
4849 C          xj=xj-xi
4850 C          yj=yj-yi
4851 C          zj=zj-zi
4852           rij=xj*xj+yj*yj+zj*zj
4853
4854           r0ij=r0_scp
4855           r0ijsq=r0ij*r0ij
4856           if (rij.lt.r0ijsq) then
4857             evdwij=0.25d0*(rij-r0ijsq)**2
4858             fac=rij-r0ijsq
4859           else
4860             evdwij=0.0d0
4861             fac=0.0d0
4862           endif
4863           evdw2=evdw2+evdwij
4864 C
4865 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4866 C
4867           ggg(1)=xj*fac
4868           ggg(2)=yj*fac
4869           ggg(3)=zj*fac
4870 cgrad          if (j.lt.i) then
4871 cd          write (iout,*) 'j<i'
4872 C Uncomment following three lines for SC-p interactions
4873 c           do k=1,3
4874 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4875 c           enddo
4876 cgrad          else
4877 cd          write (iout,*) 'j>i'
4878 cgrad            do k=1,3
4879 cgrad              ggg(k)=-ggg(k)
4880 C Uncomment following line for SC-p interactions
4881 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4882 cgrad            enddo
4883 cgrad          endif
4884 cgrad          do k=1,3
4885 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4886 cgrad          enddo
4887 cgrad          kstart=min0(i+1,j)
4888 cgrad          kend=max0(i-1,j-1)
4889 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4890 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4891 cgrad          do k=kstart,kend
4892 cgrad            do l=1,3
4893 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4894 cgrad            enddo
4895 cgrad          enddo
4896           do k=1,3
4897             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4898             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4899           enddo
4900         enddo
4901
4902         enddo ! iint
4903       enddo ! i
4904 C      enddo !zshift
4905 C      enddo !yshift
4906 C      enddo !xshift
4907       return
4908       end
4909 C-----------------------------------------------------------------------------
4910       subroutine escp(evdw2,evdw2_14)
4911 C
4912 C This subroutine calculates the excluded-volume interaction energy between
4913 C peptide-group centers and side chains and its gradient in virtual-bond and
4914 C side-chain vectors.
4915 C
4916       implicit real*8 (a-h,o-z)
4917       include 'DIMENSIONS'
4918       include 'COMMON.GEO'
4919       include 'COMMON.VAR'
4920       include 'COMMON.LOCAL'
4921       include 'COMMON.CHAIN'
4922       include 'COMMON.DERIV'
4923       include 'COMMON.INTERACT'
4924       include 'COMMON.FFIELD'
4925       include 'COMMON.IOUNITS'
4926       include 'COMMON.CONTROL'
4927       include 'COMMON.SPLITELE'
4928       dimension ggg(3)
4929       evdw2=0.0D0
4930       evdw2_14=0.0d0
4931 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4932 cd    print '(a)','Enter ESCP'
4933 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4934 C      do xshift=-1,1
4935 C      do yshift=-1,1
4936 C      do zshift=-1,1
4937       do i=iatscp_s,iatscp_e
4938         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4939         iteli=itel(i)
4940         xi=0.5D0*(c(1,i)+c(1,i+1))
4941         yi=0.5D0*(c(2,i)+c(2,i+1))
4942         zi=0.5D0*(c(3,i)+c(3,i+1))
4943           xi=mod(xi,boxxsize)
4944           if (xi.lt.0) xi=xi+boxxsize
4945           yi=mod(yi,boxysize)
4946           if (yi.lt.0) yi=yi+boxysize
4947           zi=mod(zi,boxzsize)
4948           if (zi.lt.0) zi=zi+boxzsize
4949 c          xi=xi+xshift*boxxsize
4950 c          yi=yi+yshift*boxysize
4951 c          zi=zi+zshift*boxzsize
4952 c        print *,xi,yi,zi,'polozenie i'
4953 C Return atom into box, boxxsize is size of box in x dimension
4954 c  134   continue
4955 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4956 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4957 C Condition for being inside the proper box
4958 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4959 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4960 c        go to 134
4961 c        endif
4962 c  135   continue
4963 c          print *,xi,boxxsize,"pierwszy"
4964
4965 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4966 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4967 C Condition for being inside the proper box
4968 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4969 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4970 c        go to 135
4971 c        endif
4972 c  136   continue
4973 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4974 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4975 C Condition for being inside the proper box
4976 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4977 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4978 c        go to 136
4979 c        endif
4980         do iint=1,nscp_gr(i)
4981
4982         do j=iscpstart(i,iint),iscpend(i,iint)
4983           itypj=iabs(itype(j))
4984           if (itypj.eq.ntyp1) cycle
4985 C Uncomment following three lines for SC-p interactions
4986 c         xj=c(1,nres+j)-xi
4987 c         yj=c(2,nres+j)-yi
4988 c         zj=c(3,nres+j)-zi
4989 C Uncomment following three lines for Ca-p interactions
4990           xj=c(1,j)
4991           yj=c(2,j)
4992           zj=c(3,j)
4993           xj=mod(xj,boxxsize)
4994           if (xj.lt.0) xj=xj+boxxsize
4995           yj=mod(yj,boxysize)
4996           if (yj.lt.0) yj=yj+boxysize
4997           zj=mod(zj,boxzsize)
4998           if (zj.lt.0) zj=zj+boxzsize
4999 c  174   continue
5000 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5001 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5002 C Condition for being inside the proper box
5003 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5004 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5005 c        go to 174
5006 c        endif
5007 c  175   continue
5008 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5009 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5010 cC Condition for being inside the proper box
5011 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5012 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5013 c        go to 175
5014 c        endif
5015 c  176   continue
5016 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5017 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5018 C Condition for being inside the proper box
5019 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5020 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5021 c        go to 176
5022 c        endif
5023 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5024       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5025       xj_safe=xj
5026       yj_safe=yj
5027       zj_safe=zj
5028       subchap=0
5029       do xshift=-1,1
5030       do yshift=-1,1
5031       do zshift=-1,1
5032           xj=xj_safe+xshift*boxxsize
5033           yj=yj_safe+yshift*boxysize
5034           zj=zj_safe+zshift*boxzsize
5035           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5036           if(dist_temp.lt.dist_init) then
5037             dist_init=dist_temp
5038             xj_temp=xj
5039             yj_temp=yj
5040             zj_temp=zj
5041             subchap=1
5042           endif
5043        enddo
5044        enddo
5045        enddo
5046        if (subchap.eq.1) then
5047           xj=xj_temp-xi
5048           yj=yj_temp-yi
5049           zj=zj_temp-zi
5050        else
5051           xj=xj_safe-xi
5052           yj=yj_safe-yi
5053           zj=zj_safe-zi
5054        endif
5055 c          print *,xj,yj,zj,'polozenie j'
5056           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5057 c          print *,rrij
5058           sss=sscale(1.0d0/(dsqrt(rrij)))
5059 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5060 c          if (sss.eq.0) print *,'czasem jest OK'
5061           if (sss.le.0.0d0) cycle
5062           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5063           fac=rrij**expon2
5064           e1=fac*fac*aad(itypj,iteli)
5065           e2=fac*bad(itypj,iteli)
5066           if (iabs(j-i) .le. 2) then
5067             e1=scal14*e1
5068             e2=scal14*e2
5069             evdw2_14=evdw2_14+(e1+e2)*sss
5070           endif
5071           evdwij=e1+e2
5072           evdw2=evdw2+evdwij*sss
5073           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5074      &        'evdw2',i,j,evdwij
5075 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5076 C
5077 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5078 C
5079           fac=-(evdwij+e1)*rrij*sss
5080           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5081           ggg(1)=xj*fac
5082           ggg(2)=yj*fac
5083           ggg(3)=zj*fac
5084 cgrad          if (j.lt.i) then
5085 cd          write (iout,*) 'j<i'
5086 C Uncomment following three lines for SC-p interactions
5087 c           do k=1,3
5088 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5089 c           enddo
5090 cgrad          else
5091 cd          write (iout,*) 'j>i'
5092 cgrad            do k=1,3
5093 cgrad              ggg(k)=-ggg(k)
5094 C Uncomment following line for SC-p interactions
5095 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5096 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5097 cgrad            enddo
5098 cgrad          endif
5099 cgrad          do k=1,3
5100 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5101 cgrad          enddo
5102 cgrad          kstart=min0(i+1,j)
5103 cgrad          kend=max0(i-1,j-1)
5104 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5105 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5106 cgrad          do k=kstart,kend
5107 cgrad            do l=1,3
5108 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5109 cgrad            enddo
5110 cgrad          enddo
5111           do k=1,3
5112             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5113             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5114           enddo
5115 c        endif !endif for sscale cutoff
5116         enddo ! j
5117
5118         enddo ! iint
5119       enddo ! i
5120 c      enddo !zshift
5121 c      enddo !yshift
5122 c      enddo !xshift
5123       do i=1,nct
5124         do j=1,3
5125           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5126           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5127           gradx_scp(j,i)=expon*gradx_scp(j,i)
5128         enddo
5129       enddo
5130 C******************************************************************************
5131 C
5132 C                              N O T E !!!
5133 C
5134 C To save time the factor EXPON has been extracted from ALL components
5135 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5136 C use!
5137 C
5138 C******************************************************************************
5139       return
5140       end
5141 C--------------------------------------------------------------------------
5142       subroutine edis(ehpb)
5143 C
5144 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5145 C
5146       implicit real*8 (a-h,o-z)
5147       include 'DIMENSIONS'
5148       include 'COMMON.SBRIDGE'
5149       include 'COMMON.CHAIN'
5150       include 'COMMON.DERIV'
5151       include 'COMMON.VAR'
5152       include 'COMMON.INTERACT'
5153       include 'COMMON.IOUNITS'
5154       dimension ggg(3)
5155       ehpb=0.0D0
5156 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5157 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5158       if (link_end.eq.0) return
5159       do i=link_start,link_end
5160 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5161 C CA-CA distance used in regularization of structure.
5162         ii=ihpb(i)
5163         jj=jhpb(i)
5164 C iii and jjj point to the residues for which the distance is assigned.
5165         if (ii.gt.nres) then
5166           iii=ii-nres
5167           jjj=jj-nres
5168         else
5169           iii=ii
5170           jjj=jj
5171         endif
5172 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5173 c     &    dhpb(i),dhpb1(i),forcon(i)
5174 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5175 C    distance and angle dependent SS bond potential.
5176 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5177 C     & iabs(itype(jjj)).eq.1) then
5178 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5179 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5180         if (.not.dyn_ss .and. i.le.nss) then
5181 C 15/02/13 CC dynamic SSbond - additional check
5182          if (ii.gt.nres
5183      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5184           call ssbond_ene(iii,jjj,eij)
5185           ehpb=ehpb+2*eij
5186          endif
5187 cd          write (iout,*) "eij",eij
5188         else
5189 C Calculate the distance between the two points and its difference from the
5190 C target distance.
5191           dd=dist(ii,jj)
5192             rdis=dd-dhpb(i)
5193 C Get the force constant corresponding to this distance.
5194             waga=forcon(i)
5195 C Calculate the contribution to energy.
5196             ehpb=ehpb+waga*rdis*rdis
5197 C
5198 C Evaluate gradient.
5199 C
5200             fac=waga*rdis/dd
5201 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5202 cd   &   ' waga=',waga,' fac=',fac
5203             do j=1,3
5204               ggg(j)=fac*(c(j,jj)-c(j,ii))
5205             enddo
5206 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5207 C If this is a SC-SC distance, we need to calculate the contributions to the
5208 C Cartesian gradient in the SC vectors (ghpbx).
5209           if (iii.lt.ii) then
5210           do j=1,3
5211             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5212             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5213           enddo
5214           endif
5215 cgrad        do j=iii,jjj-1
5216 cgrad          do k=1,3
5217 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5218 cgrad          enddo
5219 cgrad        enddo
5220           do k=1,3
5221             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5222             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5223           enddo
5224         endif
5225       enddo
5226       ehpb=0.5D0*ehpb
5227       return
5228       end
5229 C--------------------------------------------------------------------------
5230       subroutine ssbond_ene(i,j,eij)
5231 C
5232 C Calculate the distance and angle dependent SS-bond potential energy
5233 C using a free-energy function derived based on RHF/6-31G** ab initio
5234 C calculations of diethyl disulfide.
5235 C
5236 C A. Liwo and U. Kozlowska, 11/24/03
5237 C
5238       implicit real*8 (a-h,o-z)
5239       include 'DIMENSIONS'
5240       include 'COMMON.SBRIDGE'
5241       include 'COMMON.CHAIN'
5242       include 'COMMON.DERIV'
5243       include 'COMMON.LOCAL'
5244       include 'COMMON.INTERACT'
5245       include 'COMMON.VAR'
5246       include 'COMMON.IOUNITS'
5247       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5248       itypi=iabs(itype(i))
5249       xi=c(1,nres+i)
5250       yi=c(2,nres+i)
5251       zi=c(3,nres+i)
5252       dxi=dc_norm(1,nres+i)
5253       dyi=dc_norm(2,nres+i)
5254       dzi=dc_norm(3,nres+i)
5255 c      dsci_inv=dsc_inv(itypi)
5256       dsci_inv=vbld_inv(nres+i)
5257       itypj=iabs(itype(j))
5258 c      dscj_inv=dsc_inv(itypj)
5259       dscj_inv=vbld_inv(nres+j)
5260       xj=c(1,nres+j)-xi
5261       yj=c(2,nres+j)-yi
5262       zj=c(3,nres+j)-zi
5263       dxj=dc_norm(1,nres+j)
5264       dyj=dc_norm(2,nres+j)
5265       dzj=dc_norm(3,nres+j)
5266       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5267       rij=dsqrt(rrij)
5268       erij(1)=xj*rij
5269       erij(2)=yj*rij
5270       erij(3)=zj*rij
5271       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5272       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5273       om12=dxi*dxj+dyi*dyj+dzi*dzj
5274       do k=1,3
5275         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5276         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5277       enddo
5278       rij=1.0d0/rij
5279       deltad=rij-d0cm
5280       deltat1=1.0d0-om1
5281       deltat2=1.0d0+om2
5282       deltat12=om2-om1+2.0d0
5283       cosphi=om12-om1*om2
5284       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5285      &  +akct*deltad*deltat12
5286      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5287 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5288 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5289 c     &  " deltat12",deltat12," eij",eij
5290       ed=2*akcm*deltad+akct*deltat12
5291       pom1=akct*deltad
5292       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5293       eom1=-2*akth*deltat1-pom1-om2*pom2
5294       eom2= 2*akth*deltat2+pom1-om1*pom2
5295       eom12=pom2
5296       do k=1,3
5297         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5298         ghpbx(k,i)=ghpbx(k,i)-ggk
5299      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5300      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5301         ghpbx(k,j)=ghpbx(k,j)+ggk
5302      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5303      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5304         ghpbc(k,i)=ghpbc(k,i)-ggk
5305         ghpbc(k,j)=ghpbc(k,j)+ggk
5306       enddo
5307 C
5308 C Calculate the components of the gradient in DC and X
5309 C
5310 cgrad      do k=i,j-1
5311 cgrad        do l=1,3
5312 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5313 cgrad        enddo
5314 cgrad      enddo
5315       return
5316       end
5317 C--------------------------------------------------------------------------
5318       subroutine ebond(estr)
5319 c
5320 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5321 c
5322       implicit real*8 (a-h,o-z)
5323       include 'DIMENSIONS'
5324       include 'COMMON.LOCAL'
5325       include 'COMMON.GEO'
5326       include 'COMMON.INTERACT'
5327       include 'COMMON.DERIV'
5328       include 'COMMON.VAR'
5329       include 'COMMON.CHAIN'
5330       include 'COMMON.IOUNITS'
5331       include 'COMMON.NAMES'
5332       include 'COMMON.FFIELD'
5333       include 'COMMON.CONTROL'
5334       include 'COMMON.SETUP'
5335       double precision u(3),ud(3)
5336       estr=0.0d0
5337       estr1=0.0d0
5338       do i=ibondp_start,ibondp_end
5339         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5340 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5341 c          do j=1,3
5342 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5343 c     &      *dc(j,i-1)/vbld(i)
5344 c          enddo
5345 c          if (energy_dec) write(iout,*)
5346 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5347 c        else
5348 C       Checking if it involves dummy (NH3+ or COO-) group
5349          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5350 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5351         diff = vbld(i)-vbldpDUM
5352          else
5353 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5354         diff = vbld(i)-vbldp0
5355          endif
5356         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5357      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5358         estr=estr+diff*diff
5359         do j=1,3
5360           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5361         enddo
5362 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5363 c        endif
5364       enddo
5365       estr=0.5d0*AKP*estr+estr1
5366 c
5367 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5368 c
5369       do i=ibond_start,ibond_end
5370         iti=iabs(itype(i))
5371         if (iti.ne.10 .and. iti.ne.ntyp1) then
5372           nbi=nbondterm(iti)
5373           if (nbi.eq.1) then
5374             diff=vbld(i+nres)-vbldsc0(1,iti)
5375             if (energy_dec)  write (iout,*)
5376      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5377      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5378             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5379             do j=1,3
5380               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5381             enddo
5382           else
5383             do j=1,nbi
5384               diff=vbld(i+nres)-vbldsc0(j,iti)
5385               ud(j)=aksc(j,iti)*diff
5386               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5387             enddo
5388             uprod=u(1)
5389             do j=2,nbi
5390               uprod=uprod*u(j)
5391             enddo
5392             usum=0.0d0
5393             usumsqder=0.0d0
5394             do j=1,nbi
5395               uprod1=1.0d0
5396               uprod2=1.0d0
5397               do k=1,nbi
5398                 if (k.ne.j) then
5399                   uprod1=uprod1*u(k)
5400                   uprod2=uprod2*u(k)*u(k)
5401                 endif
5402               enddo
5403               usum=usum+uprod1
5404               usumsqder=usumsqder+ud(j)*uprod2
5405             enddo
5406             estr=estr+uprod/usum
5407             do j=1,3
5408              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5409             enddo
5410           endif
5411         endif
5412       enddo
5413       return
5414       end
5415 #ifdef CRYST_THETA
5416 C--------------------------------------------------------------------------
5417       subroutine ebend(etheta)
5418 C
5419 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5420 C angles gamma and its derivatives in consecutive thetas and gammas.
5421 C
5422       implicit real*8 (a-h,o-z)
5423       include 'DIMENSIONS'
5424       include 'COMMON.LOCAL'
5425       include 'COMMON.GEO'
5426       include 'COMMON.INTERACT'
5427       include 'COMMON.DERIV'
5428       include 'COMMON.VAR'
5429       include 'COMMON.CHAIN'
5430       include 'COMMON.IOUNITS'
5431       include 'COMMON.NAMES'
5432       include 'COMMON.FFIELD'
5433       include 'COMMON.CONTROL'
5434       common /calcthet/ term1,term2,termm,diffak,ratak,
5435      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5436      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5437       double precision y(2),z(2)
5438       delta=0.02d0*pi
5439 c      time11=dexp(-2*time)
5440 c      time12=1.0d0
5441       etheta=0.0D0
5442 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5443       do i=ithet_start,ithet_end
5444         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5445      &  .or.itype(i).eq.ntyp1) cycle
5446 C Zero the energy function and its derivative at 0 or pi.
5447         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5448         it=itype(i-1)
5449         ichir1=isign(1,itype(i-2))
5450         ichir2=isign(1,itype(i))
5451          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5452          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5453          if (itype(i-1).eq.10) then
5454           itype1=isign(10,itype(i-2))
5455           ichir11=isign(1,itype(i-2))
5456           ichir12=isign(1,itype(i-2))
5457           itype2=isign(10,itype(i))
5458           ichir21=isign(1,itype(i))
5459           ichir22=isign(1,itype(i))
5460          endif
5461
5462         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5463 #ifdef OSF
5464           phii=phi(i)
5465           if (phii.ne.phii) phii=150.0
5466 #else
5467           phii=phi(i)
5468 #endif
5469           y(1)=dcos(phii)
5470           y(2)=dsin(phii)
5471         else
5472           y(1)=0.0D0
5473           y(2)=0.0D0
5474         endif
5475         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5476 #ifdef OSF
5477           phii1=phi(i+1)
5478           if (phii1.ne.phii1) phii1=150.0
5479           phii1=pinorm(phii1)
5480           z(1)=cos(phii1)
5481 #else
5482           phii1=phi(i+1)
5483 #endif
5484           z(1)=dcos(phii1)
5485           z(2)=dsin(phii1)
5486         else
5487           z(1)=0.0D0
5488           z(2)=0.0D0
5489         endif
5490 C Calculate the "mean" value of theta from the part of the distribution
5491 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5492 C In following comments this theta will be referred to as t_c.
5493         thet_pred_mean=0.0d0
5494         do k=1,2
5495             athetk=athet(k,it,ichir1,ichir2)
5496             bthetk=bthet(k,it,ichir1,ichir2)
5497           if (it.eq.10) then
5498              athetk=athet(k,itype1,ichir11,ichir12)
5499              bthetk=bthet(k,itype2,ichir21,ichir22)
5500           endif
5501          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5502 c         write(iout,*) 'chuj tu', y(k),z(k)
5503         enddo
5504         dthett=thet_pred_mean*ssd
5505         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5506 C Derivatives of the "mean" values in gamma1 and gamma2.
5507         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5508      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5509          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5510      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5511          if (it.eq.10) then
5512       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5513      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5514         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5515      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5516          endif
5517         if (theta(i).gt.pi-delta) then
5518           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5519      &         E_tc0)
5520           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5521           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5522           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5523      &        E_theta)
5524           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5525      &        E_tc)
5526         else if (theta(i).lt.delta) then
5527           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5528           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5529           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5530      &        E_theta)
5531           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5532           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5533      &        E_tc)
5534         else
5535           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5536      &        E_theta,E_tc)
5537         endif
5538         etheta=etheta+ethetai
5539         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5540      &      'ebend',i,ethetai,theta(i),itype(i)
5541         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5542         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5543         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5544       enddo
5545 C Ufff.... We've done all this!!!
5546       return
5547       end
5548 C---------------------------------------------------------------------------
5549       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5550      &     E_tc)
5551       implicit real*8 (a-h,o-z)
5552       include 'DIMENSIONS'
5553       include 'COMMON.LOCAL'
5554       include 'COMMON.IOUNITS'
5555       common /calcthet/ term1,term2,termm,diffak,ratak,
5556      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5557      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5558 C Calculate the contributions to both Gaussian lobes.
5559 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5560 C The "polynomial part" of the "standard deviation" of this part of
5561 C the distributioni.
5562 ccc        write (iout,*) thetai,thet_pred_mean
5563         sig=polthet(3,it)
5564         do j=2,0,-1
5565           sig=sig*thet_pred_mean+polthet(j,it)
5566         enddo
5567 C Derivative of the "interior part" of the "standard deviation of the"
5568 C gamma-dependent Gaussian lobe in t_c.
5569         sigtc=3*polthet(3,it)
5570         do j=2,1,-1
5571           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5572         enddo
5573         sigtc=sig*sigtc
5574 C Set the parameters of both Gaussian lobes of the distribution.
5575 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5576         fac=sig*sig+sigc0(it)
5577         sigcsq=fac+fac
5578         sigc=1.0D0/sigcsq
5579 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5580         sigsqtc=-4.0D0*sigcsq*sigtc
5581 c       print *,i,sig,sigtc,sigsqtc
5582 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5583         sigtc=-sigtc/(fac*fac)
5584 C Following variable is sigma(t_c)**(-2)
5585         sigcsq=sigcsq*sigcsq
5586         sig0i=sig0(it)
5587         sig0inv=1.0D0/sig0i**2
5588         delthec=thetai-thet_pred_mean
5589         delthe0=thetai-theta0i
5590         term1=-0.5D0*sigcsq*delthec*delthec
5591         term2=-0.5D0*sig0inv*delthe0*delthe0
5592 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5593 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5594 C NaNs in taking the logarithm. We extract the largest exponent which is added
5595 C to the energy (this being the log of the distribution) at the end of energy
5596 C term evaluation for this virtual-bond angle.
5597         if (term1.gt.term2) then
5598           termm=term1
5599           term2=dexp(term2-termm)
5600           term1=1.0d0
5601         else
5602           termm=term2
5603           term1=dexp(term1-termm)
5604           term2=1.0d0
5605         endif
5606 C The ratio between the gamma-independent and gamma-dependent lobes of
5607 C the distribution is a Gaussian function of thet_pred_mean too.
5608         diffak=gthet(2,it)-thet_pred_mean
5609         ratak=diffak/gthet(3,it)**2
5610         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5611 C Let's differentiate it in thet_pred_mean NOW.
5612         aktc=ak*ratak
5613 C Now put together the distribution terms to make complete distribution.
5614         termexp=term1+ak*term2
5615         termpre=sigc+ak*sig0i
5616 C Contribution of the bending energy from this theta is just the -log of
5617 C the sum of the contributions from the two lobes and the pre-exponential
5618 C factor. Simple enough, isn't it?
5619         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5620 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5621 C NOW the derivatives!!!
5622 C 6/6/97 Take into account the deformation.
5623         E_theta=(delthec*sigcsq*term1
5624      &       +ak*delthe0*sig0inv*term2)/termexp
5625         E_tc=((sigtc+aktc*sig0i)/termpre
5626      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5627      &       aktc*term2)/termexp)
5628       return
5629       end
5630 c-----------------------------------------------------------------------------
5631       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5632       implicit real*8 (a-h,o-z)
5633       include 'DIMENSIONS'
5634       include 'COMMON.LOCAL'
5635       include 'COMMON.IOUNITS'
5636       common /calcthet/ term1,term2,termm,diffak,ratak,
5637      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5638      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5639       delthec=thetai-thet_pred_mean
5640       delthe0=thetai-theta0i
5641 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5642       t3 = thetai-thet_pred_mean
5643       t6 = t3**2
5644       t9 = term1
5645       t12 = t3*sigcsq
5646       t14 = t12+t6*sigsqtc
5647       t16 = 1.0d0
5648       t21 = thetai-theta0i
5649       t23 = t21**2
5650       t26 = term2
5651       t27 = t21*t26
5652       t32 = termexp
5653       t40 = t32**2
5654       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5655      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5656      & *(-t12*t9-ak*sig0inv*t27)
5657       return
5658       end
5659 #else
5660 C--------------------------------------------------------------------------
5661       subroutine ebend(etheta)
5662 C
5663 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5664 C angles gamma and its derivatives in consecutive thetas and gammas.
5665 C ab initio-derived potentials from
5666 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5667 C
5668       implicit real*8 (a-h,o-z)
5669       include 'DIMENSIONS'
5670       include 'COMMON.LOCAL'
5671       include 'COMMON.GEO'
5672       include 'COMMON.INTERACT'
5673       include 'COMMON.DERIV'
5674       include 'COMMON.VAR'
5675       include 'COMMON.CHAIN'
5676       include 'COMMON.IOUNITS'
5677       include 'COMMON.NAMES'
5678       include 'COMMON.FFIELD'
5679       include 'COMMON.CONTROL'
5680       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5681      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5682      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5683      & sinph1ph2(maxdouble,maxdouble)
5684       logical lprn /.false./, lprn1 /.false./
5685       etheta=0.0D0
5686       do i=ithet_start,ithet_end
5687         if (i.eq.2) cycle
5688 c        print *,i,itype(i-1),itype(i),itype(i-2)
5689         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5690      &  .or.(itype(i).eq.ntyp1)) cycle
5691 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5692
5693         if (iabs(itype(i+1)).eq.20) iblock=2
5694         if (iabs(itype(i+1)).ne.20) iblock=1
5695         dethetai=0.0d0
5696         dephii=0.0d0
5697         dephii1=0.0d0
5698         theti2=0.5d0*theta(i)
5699         ityp2=ithetyp((itype(i-1)))
5700         do k=1,nntheterm
5701           coskt(k)=dcos(k*theti2)
5702           sinkt(k)=dsin(k*theti2)
5703         enddo
5704         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5705 #ifdef OSF
5706           phii=phi(i)
5707           if (phii.ne.phii) phii=150.0
5708 #else
5709           phii=phi(i)
5710 #endif
5711           ityp1=ithetyp((itype(i-2)))
5712 C propagation of chirality for glycine type
5713           do k=1,nsingle
5714             cosph1(k)=dcos(k*phii)
5715             sinph1(k)=dsin(k*phii)
5716           enddo
5717         else
5718           phii=0.0d0
5719           ityp1=nthetyp+1
5720           do k=1,nsingle
5721             cosph1(k)=0.0d0
5722             sinph1(k)=0.0d0
5723           enddo
5724         endif
5725         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5726 #ifdef OSF
5727           phii1=phi(i+1)
5728           if (phii1.ne.phii1) phii1=150.0
5729           phii1=pinorm(phii1)
5730 #else
5731           phii1=phi(i+1)
5732 #endif
5733           ityp3=ithetyp((itype(i)))
5734           do k=1,nsingle
5735             cosph2(k)=dcos(k*phii1)
5736             sinph2(k)=dsin(k*phii1)
5737           enddo
5738         else
5739           phii1=0.0d0
5740           ityp3=nthetyp+1
5741           do k=1,nsingle
5742             cosph2(k)=0.0d0
5743             sinph2(k)=0.0d0
5744           enddo
5745         endif
5746         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5747         do k=1,ndouble
5748           do l=1,k-1
5749             ccl=cosph1(l)*cosph2(k-l)
5750             ssl=sinph1(l)*sinph2(k-l)
5751             scl=sinph1(l)*cosph2(k-l)
5752             csl=cosph1(l)*sinph2(k-l)
5753             cosph1ph2(l,k)=ccl-ssl
5754             cosph1ph2(k,l)=ccl+ssl
5755             sinph1ph2(l,k)=scl+csl
5756             sinph1ph2(k,l)=scl-csl
5757           enddo
5758         enddo
5759         if (lprn) then
5760         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5761      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5762         write (iout,*) "coskt and sinkt"
5763         do k=1,nntheterm
5764           write (iout,*) k,coskt(k),sinkt(k)
5765         enddo
5766         endif
5767         do k=1,ntheterm
5768           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5769           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5770      &      *coskt(k)
5771           if (lprn)
5772      &    write (iout,*) "k",k,"
5773      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5774      &     " ethetai",ethetai
5775         enddo
5776         if (lprn) then
5777         write (iout,*) "cosph and sinph"
5778         do k=1,nsingle
5779           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5780         enddo
5781         write (iout,*) "cosph1ph2 and sinph2ph2"
5782         do k=2,ndouble
5783           do l=1,k-1
5784             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5785      &         sinph1ph2(l,k),sinph1ph2(k,l)
5786           enddo
5787         enddo
5788         write(iout,*) "ethetai",ethetai
5789         endif
5790         do m=1,ntheterm2
5791           do k=1,nsingle
5792             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5793      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5794      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5795      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5796             ethetai=ethetai+sinkt(m)*aux
5797             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5798             dephii=dephii+k*sinkt(m)*(
5799      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5800      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5801             dephii1=dephii1+k*sinkt(m)*(
5802      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5803      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5804             if (lprn)
5805      &      write (iout,*) "m",m," k",k," bbthet",
5806      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5807      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5808      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5809      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5810           enddo
5811         enddo
5812         if (lprn)
5813      &  write(iout,*) "ethetai",ethetai
5814         do m=1,ntheterm3
5815           do k=2,ndouble
5816             do l=1,k-1
5817               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5818      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5819      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5820      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5821               ethetai=ethetai+sinkt(m)*aux
5822               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5823               dephii=dephii+l*sinkt(m)*(
5824      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5825      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5826      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5827      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5828               dephii1=dephii1+(k-l)*sinkt(m)*(
5829      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5830      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5831      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5832      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5833               if (lprn) then
5834               write (iout,*) "m",m," k",k," l",l," ffthet",
5835      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5836      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5837      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5838      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5839      &            " ethetai",ethetai
5840               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5841      &            cosph1ph2(k,l)*sinkt(m),
5842      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5843               endif
5844             enddo
5845           enddo
5846         enddo
5847 10      continue
5848 c        lprn1=.true.
5849         if (lprn1)
5850      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5851      &   i,theta(i)*rad2deg,phii*rad2deg,
5852      &   phii1*rad2deg,ethetai
5853 c        lprn1=.false.
5854         etheta=etheta+ethetai
5855         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5856      &      'ebend',i,ethetai
5857         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5858         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5859         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5860       enddo
5861       return
5862       end
5863 #endif
5864 #ifdef CRYST_SC
5865 c-----------------------------------------------------------------------------
5866       subroutine esc(escloc)
5867 C Calculate the local energy of a side chain and its derivatives in the
5868 C corresponding virtual-bond valence angles THETA and the spherical angles
5869 C ALPHA and OMEGA.
5870       implicit real*8 (a-h,o-z)
5871       include 'DIMENSIONS'
5872       include 'COMMON.GEO'
5873       include 'COMMON.LOCAL'
5874       include 'COMMON.VAR'
5875       include 'COMMON.INTERACT'
5876       include 'COMMON.DERIV'
5877       include 'COMMON.CHAIN'
5878       include 'COMMON.IOUNITS'
5879       include 'COMMON.NAMES'
5880       include 'COMMON.FFIELD'
5881       include 'COMMON.CONTROL'
5882       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5883      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5884       common /sccalc/ time11,time12,time112,theti,it,nlobit
5885       delta=0.02d0*pi
5886       escloc=0.0D0
5887 c     write (iout,'(a)') 'ESC'
5888       do i=loc_start,loc_end
5889         it=itype(i)
5890         if (it.eq.ntyp1) cycle
5891         if (it.eq.10) goto 1
5892         nlobit=nlob(iabs(it))
5893 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5894 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5895         theti=theta(i+1)-pipol
5896         x(1)=dtan(theti)
5897         x(2)=alph(i)
5898         x(3)=omeg(i)
5899
5900         if (x(2).gt.pi-delta) then
5901           xtemp(1)=x(1)
5902           xtemp(2)=pi-delta
5903           xtemp(3)=x(3)
5904           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5905           xtemp(2)=pi
5906           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5907           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5908      &        escloci,dersc(2))
5909           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5910      &        ddersc0(1),dersc(1))
5911           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5912      &        ddersc0(3),dersc(3))
5913           xtemp(2)=pi-delta
5914           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5915           xtemp(2)=pi
5916           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5917           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5918      &            dersc0(2),esclocbi,dersc02)
5919           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5920      &            dersc12,dersc01)
5921           call splinthet(x(2),0.5d0*delta,ss,ssd)
5922           dersc0(1)=dersc01
5923           dersc0(2)=dersc02
5924           dersc0(3)=0.0d0
5925           do k=1,3
5926             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5927           enddo
5928           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5929 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5930 c    &             esclocbi,ss,ssd
5931           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5932 c         escloci=esclocbi
5933 c         write (iout,*) escloci
5934         else if (x(2).lt.delta) then
5935           xtemp(1)=x(1)
5936           xtemp(2)=delta
5937           xtemp(3)=x(3)
5938           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5939           xtemp(2)=0.0d0
5940           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5941           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5942      &        escloci,dersc(2))
5943           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5944      &        ddersc0(1),dersc(1))
5945           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5946      &        ddersc0(3),dersc(3))
5947           xtemp(2)=delta
5948           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5949           xtemp(2)=0.0d0
5950           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5951           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5952      &            dersc0(2),esclocbi,dersc02)
5953           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5954      &            dersc12,dersc01)
5955           dersc0(1)=dersc01
5956           dersc0(2)=dersc02
5957           dersc0(3)=0.0d0
5958           call splinthet(x(2),0.5d0*delta,ss,ssd)
5959           do k=1,3
5960             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5961           enddo
5962           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5963 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5964 c    &             esclocbi,ss,ssd
5965           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5966 c         write (iout,*) escloci
5967         else
5968           call enesc(x,escloci,dersc,ddummy,.false.)
5969         endif
5970
5971         escloc=escloc+escloci
5972         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5973      &     'escloc',i,escloci
5974 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5975
5976         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5977      &   wscloc*dersc(1)
5978         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5979         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5980     1   continue
5981       enddo
5982       return
5983       end
5984 C---------------------------------------------------------------------------
5985       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'COMMON.GEO'
5989       include 'COMMON.LOCAL'
5990       include 'COMMON.IOUNITS'
5991       common /sccalc/ time11,time12,time112,theti,it,nlobit
5992       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5993       double precision contr(maxlob,-1:1)
5994       logical mixed
5995 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5996         escloc_i=0.0D0
5997         do j=1,3
5998           dersc(j)=0.0D0
5999           if (mixed) ddersc(j)=0.0d0
6000         enddo
6001         x3=x(3)
6002
6003 C Because of periodicity of the dependence of the SC energy in omega we have
6004 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6005 C To avoid underflows, first compute & store the exponents.
6006
6007         do iii=-1,1
6008
6009           x(3)=x3+iii*dwapi
6010
6011           do j=1,nlobit
6012             do k=1,3
6013               z(k)=x(k)-censc(k,j,it)
6014             enddo
6015             do k=1,3
6016               Axk=0.0D0
6017               do l=1,3
6018                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6019               enddo
6020               Ax(k,j,iii)=Axk
6021             enddo
6022             expfac=0.0D0
6023             do k=1,3
6024               expfac=expfac+Ax(k,j,iii)*z(k)
6025             enddo
6026             contr(j,iii)=expfac
6027           enddo ! j
6028
6029         enddo ! iii
6030
6031         x(3)=x3
6032 C As in the case of ebend, we want to avoid underflows in exponentiation and
6033 C subsequent NaNs and INFs in energy calculation.
6034 C Find the largest exponent
6035         emin=contr(1,-1)
6036         do iii=-1,1
6037           do j=1,nlobit
6038             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6039           enddo
6040         enddo
6041         emin=0.5D0*emin
6042 cd      print *,'it=',it,' emin=',emin
6043
6044 C Compute the contribution to SC energy and derivatives
6045         do iii=-1,1
6046
6047           do j=1,nlobit
6048 #ifdef OSF
6049             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6050             if(adexp.ne.adexp) adexp=1.0
6051             expfac=dexp(adexp)
6052 #else
6053             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6054 #endif
6055 cd          print *,'j=',j,' expfac=',expfac
6056             escloc_i=escloc_i+expfac
6057             do k=1,3
6058               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6059             enddo
6060             if (mixed) then
6061               do k=1,3,2
6062                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6063      &            +gaussc(k,2,j,it))*expfac
6064               enddo
6065             endif
6066           enddo
6067
6068         enddo ! iii
6069
6070         dersc(1)=dersc(1)/cos(theti)**2
6071         ddersc(1)=ddersc(1)/cos(theti)**2
6072         ddersc(3)=ddersc(3)
6073
6074         escloci=-(dlog(escloc_i)-emin)
6075         do j=1,3
6076           dersc(j)=dersc(j)/escloc_i
6077         enddo
6078         if (mixed) then
6079           do j=1,3,2
6080             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6081           enddo
6082         endif
6083       return
6084       end
6085 C------------------------------------------------------------------------------
6086       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6087       implicit real*8 (a-h,o-z)
6088       include 'DIMENSIONS'
6089       include 'COMMON.GEO'
6090       include 'COMMON.LOCAL'
6091       include 'COMMON.IOUNITS'
6092       common /sccalc/ time11,time12,time112,theti,it,nlobit
6093       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6094       double precision contr(maxlob)
6095       logical mixed
6096
6097       escloc_i=0.0D0
6098
6099       do j=1,3
6100         dersc(j)=0.0D0
6101       enddo
6102
6103       do j=1,nlobit
6104         do k=1,2
6105           z(k)=x(k)-censc(k,j,it)
6106         enddo
6107         z(3)=dwapi
6108         do k=1,3
6109           Axk=0.0D0
6110           do l=1,3
6111             Axk=Axk+gaussc(l,k,j,it)*z(l)
6112           enddo
6113           Ax(k,j)=Axk
6114         enddo
6115         expfac=0.0D0
6116         do k=1,3
6117           expfac=expfac+Ax(k,j)*z(k)
6118         enddo
6119         contr(j)=expfac
6120       enddo ! j
6121
6122 C As in the case of ebend, we want to avoid underflows in exponentiation and
6123 C subsequent NaNs and INFs in energy calculation.
6124 C Find the largest exponent
6125       emin=contr(1)
6126       do j=1,nlobit
6127         if (emin.gt.contr(j)) emin=contr(j)
6128       enddo
6129       emin=0.5D0*emin
6130
6131 C Compute the contribution to SC energy and derivatives
6132
6133       dersc12=0.0d0
6134       do j=1,nlobit
6135         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6136         escloc_i=escloc_i+expfac
6137         do k=1,2
6138           dersc(k)=dersc(k)+Ax(k,j)*expfac
6139         enddo
6140         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6141      &            +gaussc(1,2,j,it))*expfac
6142         dersc(3)=0.0d0
6143       enddo
6144
6145       dersc(1)=dersc(1)/cos(theti)**2
6146       dersc12=dersc12/cos(theti)**2
6147       escloci=-(dlog(escloc_i)-emin)
6148       do j=1,2
6149         dersc(j)=dersc(j)/escloc_i
6150       enddo
6151       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6152       return
6153       end
6154 #else
6155 c----------------------------------------------------------------------------------
6156       subroutine esc(escloc)
6157 C Calculate the local energy of a side chain and its derivatives in the
6158 C corresponding virtual-bond valence angles THETA and the spherical angles
6159 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6160 C added by Urszula Kozlowska. 07/11/2007
6161 C
6162       implicit real*8 (a-h,o-z)
6163       include 'DIMENSIONS'
6164       include 'COMMON.GEO'
6165       include 'COMMON.LOCAL'
6166       include 'COMMON.VAR'
6167       include 'COMMON.SCROT'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.CHAIN'
6171       include 'COMMON.IOUNITS'
6172       include 'COMMON.NAMES'
6173       include 'COMMON.FFIELD'
6174       include 'COMMON.CONTROL'
6175       include 'COMMON.VECTORS'
6176       double precision x_prime(3),y_prime(3),z_prime(3)
6177      &    , sumene,dsc_i,dp2_i,x(65),
6178      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6179      &    de_dxx,de_dyy,de_dzz,de_dt
6180       double precision s1_t,s1_6_t,s2_t,s2_6_t
6181       double precision
6182      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6183      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6184      & dt_dCi(3),dt_dCi1(3)
6185       common /sccalc/ time11,time12,time112,theti,it,nlobit
6186       delta=0.02d0*pi
6187       escloc=0.0D0
6188       do i=loc_start,loc_end
6189         if (itype(i).eq.ntyp1) cycle
6190         costtab(i+1) =dcos(theta(i+1))
6191         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6192         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6193         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6194         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6195         cosfac=dsqrt(cosfac2)
6196         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6197         sinfac=dsqrt(sinfac2)
6198         it=iabs(itype(i))
6199         if (it.eq.10) goto 1
6200 c
6201 C  Compute the axes of tghe local cartesian coordinates system; store in
6202 c   x_prime, y_prime and z_prime
6203 c
6204         do j=1,3
6205           x_prime(j) = 0.00
6206           y_prime(j) = 0.00
6207           z_prime(j) = 0.00
6208         enddo
6209 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6210 C     &   dc_norm(3,i+nres)
6211         do j = 1,3
6212           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6213           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6214         enddo
6215         do j = 1,3
6216           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6217         enddo
6218 c       write (2,*) "i",i
6219 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6220 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6221 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6222 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6223 c      & " xy",scalar(x_prime(1),y_prime(1)),
6224 c      & " xz",scalar(x_prime(1),z_prime(1)),
6225 c      & " yy",scalar(y_prime(1),y_prime(1)),
6226 c      & " yz",scalar(y_prime(1),z_prime(1)),
6227 c      & " zz",scalar(z_prime(1),z_prime(1))
6228 c
6229 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6230 C to local coordinate system. Store in xx, yy, zz.
6231 c
6232         xx=0.0d0
6233         yy=0.0d0
6234         zz=0.0d0
6235         do j = 1,3
6236           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6237           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6238           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6239         enddo
6240
6241         xxtab(i)=xx
6242         yytab(i)=yy
6243         zztab(i)=zz
6244 C
6245 C Compute the energy of the ith side cbain
6246 C
6247 c        write (2,*) "xx",xx," yy",yy," zz",zz
6248         it=iabs(itype(i))
6249         do j = 1,65
6250           x(j) = sc_parmin(j,it)
6251         enddo
6252 #ifdef CHECK_COORD
6253 Cc diagnostics - remove later
6254         xx1 = dcos(alph(2))
6255         yy1 = dsin(alph(2))*dcos(omeg(2))
6256         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6257         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6258      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6259      &    xx1,yy1,zz1
6260 C,"  --- ", xx_w,yy_w,zz_w
6261 c end diagnostics
6262 #endif
6263         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6264      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6265      &   + x(10)*yy*zz
6266         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6267      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6268      & + x(20)*yy*zz
6269         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6270      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6271      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6272      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6273      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6274      &  +x(40)*xx*yy*zz
6275         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6276      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6277      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6278      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6279      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6280      &  +x(60)*xx*yy*zz
6281         dsc_i   = 0.743d0+x(61)
6282         dp2_i   = 1.9d0+x(62)
6283         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6284      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6285         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6286      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6287         s1=(1+x(63))/(0.1d0 + dscp1)
6288         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6289         s2=(1+x(65))/(0.1d0 + dscp2)
6290         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6291         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6292      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6293 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6294 c     &   sumene4,
6295 c     &   dscp1,dscp2,sumene
6296 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6297         escloc = escloc + sumene
6298 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6299 c     & ,zz,xx,yy
6300 c#define DEBUG
6301 #ifdef DEBUG
6302 C
6303 C This section to check the numerical derivatives of the energy of ith side
6304 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6305 C #define DEBUG in the code to turn it on.
6306 C
6307         write (2,*) "sumene               =",sumene
6308         aincr=1.0d-7
6309         xxsave=xx
6310         xx=xx+aincr
6311         write (2,*) xx,yy,zz
6312         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6313         de_dxx_num=(sumenep-sumene)/aincr
6314         xx=xxsave
6315         write (2,*) "xx+ sumene from enesc=",sumenep
6316         yysave=yy
6317         yy=yy+aincr
6318         write (2,*) xx,yy,zz
6319         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6320         de_dyy_num=(sumenep-sumene)/aincr
6321         yy=yysave
6322         write (2,*) "yy+ sumene from enesc=",sumenep
6323         zzsave=zz
6324         zz=zz+aincr
6325         write (2,*) xx,yy,zz
6326         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6327         de_dzz_num=(sumenep-sumene)/aincr
6328         zz=zzsave
6329         write (2,*) "zz+ sumene from enesc=",sumenep
6330         costsave=cost2tab(i+1)
6331         sintsave=sint2tab(i+1)
6332         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6333         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6334         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6335         de_dt_num=(sumenep-sumene)/aincr
6336         write (2,*) " t+ sumene from enesc=",sumenep
6337         cost2tab(i+1)=costsave
6338         sint2tab(i+1)=sintsave
6339 C End of diagnostics section.
6340 #endif
6341 C
6342 C Compute the gradient of esc
6343 C
6344 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6345         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6346         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6347         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6348         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6349         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6350         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6351         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6352         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6353         pom1=(sumene3*sint2tab(i+1)+sumene1)
6354      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6355         pom2=(sumene4*cost2tab(i+1)+sumene2)
6356      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6357         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6358         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6359      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6360      &  +x(40)*yy*zz
6361         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6362         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6363      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6364      &  +x(60)*yy*zz
6365         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6366      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6367      &        +(pom1+pom2)*pom_dx
6368 #ifdef DEBUG
6369         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6370 #endif
6371 C
6372         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6373         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6374      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6375      &  +x(40)*xx*zz
6376         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6377         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6378      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6379      &  +x(59)*zz**2 +x(60)*xx*zz
6380         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6381      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6382      &        +(pom1-pom2)*pom_dy
6383 #ifdef DEBUG
6384         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6385 #endif
6386 C
6387         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6388      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6389      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6390      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6391      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6392      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6393      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6394      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6395 #ifdef DEBUG
6396         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6397 #endif
6398 C
6399         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6400      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6401      &  +pom1*pom_dt1+pom2*pom_dt2
6402 #ifdef DEBUG
6403         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6404 #endif
6405 c#undef DEBUG
6406 c
6407 C
6408        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6409        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6410        cosfac2xx=cosfac2*xx
6411        sinfac2yy=sinfac2*yy
6412        do k = 1,3
6413          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6414      &      vbld_inv(i+1)
6415          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6416      &      vbld_inv(i)
6417          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6418          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6419 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6420 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6421 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6422 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6423          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6424          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6425          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6426          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6427          dZZ_Ci1(k)=0.0d0
6428          dZZ_Ci(k)=0.0d0
6429          do j=1,3
6430            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6431      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6432            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6433      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6434          enddo
6435
6436          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6437          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6438          dZZ_XYZ(k)=vbld_inv(i+nres)*
6439      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6440 c
6441          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6442          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6443        enddo
6444
6445        do k=1,3
6446          dXX_Ctab(k,i)=dXX_Ci(k)
6447          dXX_C1tab(k,i)=dXX_Ci1(k)
6448          dYY_Ctab(k,i)=dYY_Ci(k)
6449          dYY_C1tab(k,i)=dYY_Ci1(k)
6450          dZZ_Ctab(k,i)=dZZ_Ci(k)
6451          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6452          dXX_XYZtab(k,i)=dXX_XYZ(k)
6453          dYY_XYZtab(k,i)=dYY_XYZ(k)
6454          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6455        enddo
6456
6457        do k = 1,3
6458 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6459 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6460 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6461 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6462 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6463 c     &    dt_dci(k)
6464 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6465 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6466          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6467      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6468          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6469      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6470          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6471      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6472        enddo
6473 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6474 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6475
6476 C to check gradient call subroutine check_grad
6477
6478     1 continue
6479       enddo
6480       return
6481       end
6482 c------------------------------------------------------------------------------
6483       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6484       implicit none
6485       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6486      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6487       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6488      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6489      &   + x(10)*yy*zz
6490       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6491      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6492      & + x(20)*yy*zz
6493       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6494      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6495      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6496      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6497      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6498      &  +x(40)*xx*yy*zz
6499       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6500      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6501      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6502      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6503      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6504      &  +x(60)*xx*yy*zz
6505       dsc_i   = 0.743d0+x(61)
6506       dp2_i   = 1.9d0+x(62)
6507       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6508      &          *(xx*cost2+yy*sint2))
6509       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6510      &          *(xx*cost2-yy*sint2))
6511       s1=(1+x(63))/(0.1d0 + dscp1)
6512       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6513       s2=(1+x(65))/(0.1d0 + dscp2)
6514       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6515       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6516      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6517       enesc=sumene
6518       return
6519       end
6520 #endif
6521 c------------------------------------------------------------------------------
6522       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6523 C
6524 C This procedure calculates two-body contact function g(rij) and its derivative:
6525 C
6526 C           eps0ij                                     !       x < -1
6527 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6528 C            0                                         !       x > 1
6529 C
6530 C where x=(rij-r0ij)/delta
6531 C
6532 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6533 C
6534       implicit none
6535       double precision rij,r0ij,eps0ij,fcont,fprimcont
6536       double precision x,x2,x4,delta
6537 c     delta=0.02D0*r0ij
6538 c      delta=0.2D0*r0ij
6539       x=(rij-r0ij)/delta
6540       if (x.lt.-1.0D0) then
6541         fcont=eps0ij
6542         fprimcont=0.0D0
6543       else if (x.le.1.0D0) then
6544         x2=x*x
6545         x4=x2*x2
6546         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6547         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6548       else
6549         fcont=0.0D0
6550         fprimcont=0.0D0
6551       endif
6552       return
6553       end
6554 c------------------------------------------------------------------------------
6555       subroutine splinthet(theti,delta,ss,ssder)
6556       implicit real*8 (a-h,o-z)
6557       include 'DIMENSIONS'
6558       include 'COMMON.VAR'
6559       include 'COMMON.GEO'
6560       thetup=pi-delta
6561       thetlow=delta
6562       if (theti.gt.pipol) then
6563         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6564       else
6565         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6566         ssder=-ssder
6567       endif
6568       return
6569       end
6570 c------------------------------------------------------------------------------
6571       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6572       implicit none
6573       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6574       double precision ksi,ksi2,ksi3,a1,a2,a3
6575       a1=fprim0*delta/(f1-f0)
6576       a2=3.0d0-2.0d0*a1
6577       a3=a1-2.0d0
6578       ksi=(x-x0)/delta
6579       ksi2=ksi*ksi
6580       ksi3=ksi2*ksi
6581       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6582       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6583       return
6584       end
6585 c------------------------------------------------------------------------------
6586       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6587       implicit none
6588       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6589       double precision ksi,ksi2,ksi3,a1,a2,a3
6590       ksi=(x-x0)/delta
6591       ksi2=ksi*ksi
6592       ksi3=ksi2*ksi
6593       a1=fprim0x*delta
6594       a2=3*(f1x-f0x)-2*fprim0x*delta
6595       a3=fprim0x*delta-2*(f1x-f0x)
6596       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6597       return
6598       end
6599 C-----------------------------------------------------------------------------
6600 #ifdef CRYST_TOR
6601 C-----------------------------------------------------------------------------
6602       subroutine etor(etors,edihcnstr)
6603       implicit real*8 (a-h,o-z)
6604       include 'DIMENSIONS'
6605       include 'COMMON.VAR'
6606       include 'COMMON.GEO'
6607       include 'COMMON.LOCAL'
6608       include 'COMMON.TORSION'
6609       include 'COMMON.INTERACT'
6610       include 'COMMON.DERIV'
6611       include 'COMMON.CHAIN'
6612       include 'COMMON.NAMES'
6613       include 'COMMON.IOUNITS'
6614       include 'COMMON.FFIELD'
6615       include 'COMMON.TORCNSTR'
6616       include 'COMMON.CONTROL'
6617       logical lprn
6618 C Set lprn=.true. for debugging
6619       lprn=.false.
6620 c      lprn=.true.
6621       etors=0.0D0
6622       do i=iphi_start,iphi_end
6623       etors_ii=0.0D0
6624         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6625      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6626         itori=itortyp(itype(i-2))
6627         itori1=itortyp(itype(i-1))
6628         phii=phi(i)
6629         gloci=0.0D0
6630 C Proline-Proline pair is a special case...
6631         if (itori.eq.3 .and. itori1.eq.3) then
6632           if (phii.gt.-dwapi3) then
6633             cosphi=dcos(3*phii)
6634             fac=1.0D0/(1.0D0-cosphi)
6635             etorsi=v1(1,3,3)*fac
6636             etorsi=etorsi+etorsi
6637             etors=etors+etorsi-v1(1,3,3)
6638             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6639             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6640           endif
6641           do j=1,3
6642             v1ij=v1(j+1,itori,itori1)
6643             v2ij=v2(j+1,itori,itori1)
6644             cosphi=dcos(j*phii)
6645             sinphi=dsin(j*phii)
6646             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6647             if (energy_dec) etors_ii=etors_ii+
6648      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6649             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6650           enddo
6651         else
6652           do j=1,nterm_old
6653             v1ij=v1(j,itori,itori1)
6654             v2ij=v2(j,itori,itori1)
6655             cosphi=dcos(j*phii)
6656             sinphi=dsin(j*phii)
6657             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6658             if (energy_dec) etors_ii=etors_ii+
6659      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6660             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6661           enddo
6662         endif
6663         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6664              'etor',i,etors_ii
6665         if (lprn)
6666      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6667      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6668      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6669         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6670 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6671       enddo
6672 ! 6/20/98 - dihedral angle constraints
6673       edihcnstr=0.0d0
6674       do i=1,ndih_constr
6675         itori=idih_constr(i)
6676         phii=phi(itori)
6677         difi=phii-phi0(i)
6678         if (difi.gt.drange(i)) then
6679           difi=difi-drange(i)
6680           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6681           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6682         else if (difi.lt.-drange(i)) then
6683           difi=difi+drange(i)
6684           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6685           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6686         endif
6687 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6688 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6689       enddo
6690 !      write (iout,*) 'edihcnstr',edihcnstr
6691       return
6692       end
6693 c------------------------------------------------------------------------------
6694 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6695       subroutine e_modeller(ehomology_constr)
6696       ehomology_constr=0.0d0
6697       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6698       return
6699       end
6700 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6701
6702 c------------------------------------------------------------------------------
6703       subroutine etor_d(etors_d)
6704       etors_d=0.0d0
6705       return
6706       end
6707 c----------------------------------------------------------------------------
6708 #else
6709       subroutine etor(etors,edihcnstr)
6710       implicit real*8 (a-h,o-z)
6711       include 'DIMENSIONS'
6712       include 'COMMON.VAR'
6713       include 'COMMON.GEO'
6714       include 'COMMON.LOCAL'
6715       include 'COMMON.TORSION'
6716       include 'COMMON.INTERACT'
6717       include 'COMMON.DERIV'
6718       include 'COMMON.CHAIN'
6719       include 'COMMON.NAMES'
6720       include 'COMMON.IOUNITS'
6721       include 'COMMON.FFIELD'
6722       include 'COMMON.TORCNSTR'
6723       include 'COMMON.CONTROL'
6724       logical lprn
6725 C Set lprn=.true. for debugging
6726       lprn=.false.
6727 c     lprn=.true.
6728       etors=0.0D0
6729       do i=iphi_start,iphi_end
6730 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6731 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6732 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6733 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6734         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6735      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6736 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6737 C For introducing the NH3+ and COO- group please check the etor_d for reference
6738 C and guidance
6739         etors_ii=0.0D0
6740          if (iabs(itype(i)).eq.20) then
6741          iblock=2
6742          else
6743          iblock=1
6744          endif
6745         itori=itortyp(itype(i-2))
6746         itori1=itortyp(itype(i-1))
6747         phii=phi(i)
6748         gloci=0.0D0
6749 C Regular cosine and sine terms
6750         do j=1,nterm(itori,itori1,iblock)
6751           v1ij=v1(j,itori,itori1,iblock)
6752           v2ij=v2(j,itori,itori1,iblock)
6753           cosphi=dcos(j*phii)
6754           sinphi=dsin(j*phii)
6755           etors=etors+v1ij*cosphi+v2ij*sinphi
6756           if (energy_dec) etors_ii=etors_ii+
6757      &                v1ij*cosphi+v2ij*sinphi
6758           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6759         enddo
6760 C Lorentz terms
6761 C                         v1
6762 C  E = SUM ----------------------------------- - v1
6763 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6764 C
6765         cosphi=dcos(0.5d0*phii)
6766         sinphi=dsin(0.5d0*phii)
6767         do j=1,nlor(itori,itori1,iblock)
6768           vl1ij=vlor1(j,itori,itori1)
6769           vl2ij=vlor2(j,itori,itori1)
6770           vl3ij=vlor3(j,itori,itori1)
6771           pom=vl2ij*cosphi+vl3ij*sinphi
6772           pom1=1.0d0/(pom*pom+1.0d0)
6773           etors=etors+vl1ij*pom1
6774           if (energy_dec) etors_ii=etors_ii+
6775      &                vl1ij*pom1
6776           pom=-pom*pom1*pom1
6777           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6778         enddo
6779 C Subtract the constant term
6780         etors=etors-v0(itori,itori1,iblock)
6781           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6782      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6783         if (lprn)
6784      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6785      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6786      &  (v1(j,itori,itori1,iblock),j=1,6),
6787      &  (v2(j,itori,itori1,iblock),j=1,6)
6788         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6789 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6790       enddo
6791 ! 6/20/98 - dihedral angle constraints
6792       edihcnstr=0.0d0
6793 c      do i=1,ndih_constr
6794       do i=idihconstr_start,idihconstr_end
6795         itori=idih_constr(i)
6796         phii=phi(itori)
6797         difi=pinorm(phii-phi0(i))
6798         if (difi.gt.drange(i)) then
6799           difi=difi-drange(i)
6800           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6801           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6802         else if (difi.lt.-drange(i)) then
6803           difi=difi+drange(i)
6804           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6806         else
6807           difi=0.0
6808         endif
6809 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6810 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6811 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6812       enddo
6813 cd       write (iout,*) 'edihcnstr',edihcnstr
6814       return
6815       end
6816 c----------------------------------------------------------------------------
6817 c MODELLER restraint function
6818       subroutine e_modeller(ehomology_constr)
6819       implicit real*8 (a-h,o-z)
6820       include 'DIMENSIONS'
6821
6822       integer nnn, i, j, k, ki, irec, l
6823       integer katy, odleglosci, test7
6824       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6825       real*8 Eval,Erot
6826       real*8 distance(max_template),distancek(max_template),
6827      &    min_odl,godl(max_template),dih_diff(max_template)
6828
6829 c
6830 c     FP - 30/10/2014 Temporary specifications for homology restraints
6831 c
6832       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6833      &                 sgtheta
6834       double precision, dimension (maxres) :: guscdiff,usc_diff
6835       double precision, dimension (max_template) ::
6836      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6837      &           theta_diff
6838 c
6839
6840       include 'COMMON.SBRIDGE'
6841       include 'COMMON.CHAIN'
6842       include 'COMMON.GEO'
6843       include 'COMMON.DERIV'
6844       include 'COMMON.LOCAL'
6845       include 'COMMON.INTERACT'
6846       include 'COMMON.VAR'
6847       include 'COMMON.IOUNITS'
6848       include 'COMMON.MD'
6849       include 'COMMON.CONTROL'
6850 c
6851 c     From subroutine Econstr_back
6852 c
6853       include 'COMMON.NAMES'
6854       include 'COMMON.TIME1'
6855 c
6856
6857
6858       do i=1,19
6859         distancek(i)=9999999.9
6860       enddo
6861
6862
6863       odleg=0.0d0
6864
6865 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6866 c function)
6867 C AL 5/2/14 - Introduce list of restraints
6868 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6869 #ifdef DEBUG
6870       write(iout,*) "------- dist restrs start -------"
6871 #endif
6872       do ii = link_start_homo,link_end_homo
6873          i = ires_homo(ii)
6874          j = jres_homo(ii)
6875          dij=dist(i,j)
6876 c        write (iout,*) "dij(",i,j,") =",dij
6877          do k=1,constr_homology
6878 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6879            if(.not.l_homo(k,ii)) cycle
6880            distance(k)=odl(k,ii)-dij
6881 c          write (iout,*) "distance(",k,") =",distance(k)
6882 c
6883 c          For Gaussian-type Urestr
6884 c
6885            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6886 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6887 c          write (iout,*) "distancek(",k,") =",distancek(k)
6888 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6889 c
6890 c          For Lorentzian-type Urestr
6891 c
6892            if (waga_dist.lt.0.0d0) then
6893               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6894               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6895      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6896            endif
6897          enddo
6898
6899          min_odl=minval(distancek)
6900 c        write (iout,* )"min_odl",min_odl
6901 #ifdef DEBUG
6902          write (iout,*) "ij dij",i,j,dij
6903          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6904          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6905          write (iout,* )"min_odl",min_odl
6906 #endif
6907          odleg2=0.0d0
6908          do k=1,constr_homology
6909 c Nie wiem po co to liczycie jeszcze raz!
6910 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6911 c     &              (2*(sigma_odl(i,j,k))**2))
6912            if(.not.l_homo(k,ii)) cycle
6913            if (waga_dist.ge.0.0d0) then
6914 c
6915 c          For Gaussian-type Urestr
6916 c
6917             godl(k)=dexp(-distancek(k)+min_odl)
6918             odleg2=odleg2+godl(k)
6919 c
6920 c          For Lorentzian-type Urestr
6921 c
6922            else
6923             odleg2=odleg2+distancek(k)
6924            endif
6925
6926 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6927 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6928 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6929 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6930
6931          enddo
6932 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6933 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6934 #ifdef DEBUG
6935          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6936          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6937 #endif
6938            if (waga_dist.ge.0.0d0) then
6939 c
6940 c          For Gaussian-type Urestr
6941 c
6942               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6943 c
6944 c          For Lorentzian-type Urestr
6945 c
6946            else
6947               odleg=odleg+odleg2/constr_homology
6948            endif
6949 c
6950 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6951 c Gradient
6952 c
6953 c          For Gaussian-type Urestr
6954 c
6955          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6956          sum_sgodl=0.0d0
6957          do k=1,constr_homology
6958 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6959 c     &           *waga_dist)+min_odl
6960 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6961 c
6962          if(.not.l_homo(k,ii)) cycle
6963          if (waga_dist.ge.0.0d0) then
6964 c          For Gaussian-type Urestr
6965 c
6966            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6967 c
6968 c          For Lorentzian-type Urestr
6969 c
6970          else
6971            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6972      &           sigma_odlir(k,ii)**2)**2)
6973          endif
6974            sum_sgodl=sum_sgodl+sgodl
6975
6976 c            sgodl2=sgodl2+sgodl
6977 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6978 c      write(iout,*) "constr_homology=",constr_homology
6979 c      write(iout,*) i, j, k, "TEST K"
6980          enddo
6981          if (waga_dist.ge.0.0d0) then
6982 c
6983 c          For Gaussian-type Urestr
6984 c
6985             grad_odl3=waga_homology(iset)*waga_dist
6986      &                *sum_sgodl/(sum_godl*dij)
6987 c
6988 c          For Lorentzian-type Urestr
6989 c
6990          else
6991 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6992 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6993             grad_odl3=-waga_homology(iset)*waga_dist*
6994      &                sum_sgodl/(constr_homology*dij)
6995          endif
6996 c
6997 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6998
6999
7000 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7001 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7002 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7003
7004 ccc      write(iout,*) godl, sgodl, grad_odl3
7005
7006 c          grad_odl=grad_odl+grad_odl3
7007
7008          do jik=1,3
7009             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7010 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7011 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7012 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7013             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7014             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7015 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7016 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7017 c         if (i.eq.25.and.j.eq.27) then
7018 c         write(iout,*) "jik",jik,"i",i,"j",j
7019 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7020 c         write(iout,*) "grad_odl3",grad_odl3
7021 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7022 c         write(iout,*) "ggodl",ggodl
7023 c         write(iout,*) "ghpbc(",jik,i,")",
7024 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7025 c     &                 ghpbc(jik,j)
7026 c         endif
7027          enddo
7028 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7029 ccc     & dLOG(odleg2),"-odleg=", -odleg
7030
7031       enddo ! ii-loop for dist
7032 #ifdef DEBUG
7033       write(iout,*) "------- dist restrs end -------"
7034 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7035 c    &     waga_d.eq.1.0d0) call sum_gradient
7036 #endif
7037 c Pseudo-energy and gradient from dihedral-angle restraints from
7038 c homology templates
7039 c      write (iout,*) "End of distance loop"
7040 c      call flush(iout)
7041       kat=0.0d0
7042 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7043 #ifdef DEBUG
7044       write(iout,*) "------- dih restrs start -------"
7045       do i=idihconstr_start_homo,idihconstr_end_homo
7046         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7047       enddo
7048 #endif
7049       do i=idihconstr_start_homo,idihconstr_end_homo
7050         kat2=0.0d0
7051 c        betai=beta(i,i+1,i+2,i+3)
7052         betai = phi(i+3)
7053 c       write (iout,*) "betai =",betai
7054         do k=1,constr_homology
7055           dih_diff(k)=pinorm(dih(k,i)-betai)
7056 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
7057 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7058 c     &                                   -(6.28318-dih_diff(i,k))
7059 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7060 c     &                                   6.28318+dih_diff(i,k)
7061
7062           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7063 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7064           gdih(k)=dexp(kat3)
7065           kat2=kat2+gdih(k)
7066 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7067 c          write(*,*)""
7068         enddo
7069 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7070 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7071 #ifdef DEBUG
7072         write (iout,*) "i",i," betai",betai," kat2",kat2
7073         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7074 #endif
7075         if (kat2.le.1.0d-14) cycle
7076         kat=kat-dLOG(kat2/constr_homology)
7077 c       write (iout,*) "kat",kat ! sum of -ln-s
7078
7079 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7080 ccc     & dLOG(kat2), "-kat=", -kat
7081
7082 c ----------------------------------------------------------------------
7083 c Gradient
7084 c ----------------------------------------------------------------------
7085
7086         sum_gdih=kat2
7087         sum_sgdih=0.0d0
7088         do k=1,constr_homology
7089           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7090 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7091           sum_sgdih=sum_sgdih+sgdih
7092         enddo
7093 c       grad_dih3=sum_sgdih/sum_gdih
7094         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7095
7096 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7097 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7098 ccc     & gloc(nphi+i-3,icg)
7099         gloc(i,icg)=gloc(i,icg)+grad_dih3
7100 c        if (i.eq.25) then
7101 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7102 c        endif
7103 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7104 ccc     & gloc(nphi+i-3,icg)
7105
7106       enddo ! i-loop for dih
7107 #ifdef DEBUG
7108       write(iout,*) "------- dih restrs end -------"
7109 #endif
7110
7111 c Pseudo-energy and gradient for theta angle restraints from
7112 c homology templates
7113 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7114 c adapted
7115
7116 c
7117 c     For constr_homology reference structures (FP)
7118 c
7119 c     Uconst_back_tot=0.0d0
7120       Eval=0.0d0
7121       Erot=0.0d0
7122 c     Econstr_back legacy
7123       do i=1,nres
7124 c     do i=ithet_start,ithet_end
7125        dutheta(i)=0.0d0
7126 c     enddo
7127 c     do i=loc_start,loc_end
7128         do j=1,3
7129           duscdiff(j,i)=0.0d0
7130           duscdiffx(j,i)=0.0d0
7131         enddo
7132       enddo
7133 c
7134 c     do iref=1,nref
7135 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7136 c     write (iout,*) "waga_theta",waga_theta
7137       if (waga_theta.gt.0.0d0) then
7138 #ifdef DEBUG
7139       write (iout,*) "usampl",usampl
7140       write(iout,*) "------- theta restrs start -------"
7141 c     do i=ithet_start,ithet_end
7142 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7143 c     enddo
7144 #endif
7145 c     write (iout,*) "maxres",maxres,"nres",nres
7146
7147       do i=ithet_start,ithet_end
7148 c
7149 c     do i=1,nfrag_back
7150 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7151 c
7152 c Deviation of theta angles wrt constr_homology ref structures
7153 c
7154         utheta_i=0.0d0 ! argument of Gaussian for single k
7155         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7156 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7157 c       over residues in a fragment
7158 c       write (iout,*) "theta(",i,")=",theta(i)
7159         do k=1,constr_homology
7160 c
7161 c         dtheta_i=theta(j)-thetaref(j,iref)
7162 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7163           theta_diff(k)=thetatpl(k,i)-theta(i)
7164 c
7165           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7166 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7167           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7168           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
7169 c         Gradient for single Gaussian restraint in subr Econstr_back
7170 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7171 c
7172         enddo
7173 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7174 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7175
7176 c
7177 c         Gradient for multiple Gaussian restraint
7178         sum_gtheta=gutheta_i
7179         sum_sgtheta=0.0d0
7180         do k=1,constr_homology
7181 c        New generalized expr for multiple Gaussian from Econstr_back
7182          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7183 c
7184 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7185           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7186         enddo
7187 c       Final value of gradient using same var as in Econstr_back
7188         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7189      &      +sum_sgtheta/sum_gtheta*waga_theta
7190      &               *waga_homology(iset)
7191 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7192 c     &               *waga_homology(iset)
7193 c       dutheta(i)=sum_sgtheta/sum_gtheta
7194 c
7195 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7196         Eval=Eval-dLOG(gutheta_i/constr_homology)
7197 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7198 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7199 c       Uconst_back=Uconst_back+utheta(i)
7200       enddo ! (i-loop for theta)
7201 #ifdef DEBUG
7202       write(iout,*) "------- theta restrs end -------"
7203 #endif
7204       endif
7205 c
7206 c Deviation of local SC geometry
7207 c
7208 c Separation of two i-loops (instructed by AL - 11/3/2014)
7209 c
7210 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7211 c     write (iout,*) "waga_d",waga_d
7212
7213 #ifdef DEBUG
7214       write(iout,*) "------- SC restrs start -------"
7215       write (iout,*) "Initial duscdiff,duscdiffx"
7216       do i=loc_start,loc_end
7217         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7218      &                 (duscdiffx(jik,i),jik=1,3)
7219       enddo
7220 #endif
7221       do i=loc_start,loc_end
7222         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7223         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7224 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7225 c       write(iout,*) "xxtab, yytab, zztab"
7226 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7227         do k=1,constr_homology
7228 c
7229           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7230 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7231           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7232           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7233 c         write(iout,*) "dxx, dyy, dzz"
7234 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7235 c
7236           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7237 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7238 c         uscdiffk(k)=usc_diff(i)
7239           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7240           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
7241 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7242 c     &      xxref(j),yyref(j),zzref(j)
7243         enddo
7244 c
7245 c       Gradient
7246 c
7247 c       Generalized expression for multiple Gaussian acc to that for a single
7248 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7249 c
7250 c       Original implementation
7251 c       sum_guscdiff=guscdiff(i)
7252 c
7253 c       sum_sguscdiff=0.0d0
7254 c       do k=1,constr_homology
7255 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7256 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7257 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7258 c       enddo
7259 c
7260 c       Implementation of new expressions for gradient (Jan. 2015)
7261 c
7262 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7263         do k=1,constr_homology
7264 c
7265 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7266 c       before. Now the drivatives should be correct
7267 c
7268           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7269 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7270           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7271           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7272 c
7273 c         New implementation
7274 c
7275           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7276      &                 sigma_d(k,i) ! for the grad wrt r'
7277 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7278 c
7279 c
7280 c        New implementation
7281          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7282          do jik=1,3
7283             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7284      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7285      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7286             duscdiff(jik,i)=duscdiff(jik,i)+
7287      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7288      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7289             duscdiffx(jik,i)=duscdiffx(jik,i)+
7290      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7291      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7292 c
7293 #ifdef DEBUG
7294              write(iout,*) "jik",jik,"i",i
7295              write(iout,*) "dxx, dyy, dzz"
7296              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7297              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7298 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7299 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7300 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7301 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7302 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7303 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7304 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7305 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7306 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7307 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7308 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7309 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7310 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7311 c            endif
7312 #endif
7313          enddo
7314         enddo
7315 c
7316 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7317 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7318 c
7319 c        write (iout,*) i," uscdiff",uscdiff(i)
7320 c
7321 c Put together deviations from local geometry
7322
7323 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7324 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7325         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7326 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7327 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7328 c       Uconst_back=Uconst_back+usc_diff(i)
7329 c
7330 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7331 c
7332 c     New implment: multiplied by sum_sguscdiff
7333 c
7334
7335       enddo ! (i-loop for dscdiff)
7336
7337 c      endif
7338
7339 #ifdef DEBUG
7340       write(iout,*) "------- SC restrs end -------"
7341         write (iout,*) "------ After SC loop in e_modeller ------"
7342         do i=loc_start,loc_end
7343          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7344          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7345         enddo
7346       if (waga_theta.eq.1.0d0) then
7347       write (iout,*) "in e_modeller after SC restr end: dutheta"
7348       do i=ithet_start,ithet_end
7349         write (iout,*) i,dutheta(i)
7350       enddo
7351       endif
7352       if (waga_d.eq.1.0d0) then
7353       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7354       do i=1,nres
7355         write (iout,*) i,(duscdiff(j,i),j=1,3)
7356         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7357       enddo
7358       endif
7359 #endif
7360
7361 c Total energy from homology restraints
7362 #ifdef DEBUG
7363       write (iout,*) "odleg",odleg," kat",kat
7364 #endif
7365 c
7366 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7367 c
7368 c     ehomology_constr=odleg+kat
7369 c
7370 c     For Lorentzian-type Urestr
7371 c
7372
7373       if (waga_dist.ge.0.0d0) then
7374 c
7375 c          For Gaussian-type Urestr
7376 c
7377         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7378      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7379 c     write (iout,*) "ehomology_constr=",ehomology_constr
7380       else
7381 c
7382 c          For Lorentzian-type Urestr
7383 c
7384         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7385      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7386 c     write (iout,*) "ehomology_constr=",ehomology_constr
7387       endif
7388 #ifdef DEBUG
7389       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7390      & "Eval",waga_theta,eval,
7391      &   "Erot",waga_d,Erot
7392       write (iout,*) "ehomology_constr",ehomology_constr
7393 #endif
7394       return
7395 c
7396 c FP 01/15 end
7397 c
7398   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7399   747 format(a12,i4,i4,i4,f8.3,f8.3)
7400   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7401   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7402   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7403      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7404       end
7405
7406 c------------------------------------------------------------------------------
7407       subroutine etor_d(etors_d)
7408 C 6/23/01 Compute double torsional energy
7409       implicit real*8 (a-h,o-z)
7410       include 'DIMENSIONS'
7411       include 'COMMON.VAR'
7412       include 'COMMON.GEO'
7413       include 'COMMON.LOCAL'
7414       include 'COMMON.TORSION'
7415       include 'COMMON.INTERACT'
7416       include 'COMMON.DERIV'
7417       include 'COMMON.CHAIN'
7418       include 'COMMON.NAMES'
7419       include 'COMMON.IOUNITS'
7420       include 'COMMON.FFIELD'
7421       include 'COMMON.TORCNSTR'
7422       include 'COMMON.CONTROL'
7423       logical lprn
7424 C Set lprn=.true. for debugging
7425       lprn=.false.
7426 c     lprn=.true.
7427       etors_d=0.0D0
7428 c      write(iout,*) "a tu??"
7429       do i=iphid_start,iphid_end
7430 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7431 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7432 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7433 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7434 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7435          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7436      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7437      &  (itype(i+1).eq.ntyp1)) cycle
7438 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7439         etors_d_ii=0.0D0
7440         itori=itortyp(itype(i-2))
7441         itori1=itortyp(itype(i-1))
7442         itori2=itortyp(itype(i))
7443         phii=phi(i)
7444         phii1=phi(i+1)
7445         gloci1=0.0D0
7446         gloci2=0.0D0
7447         iblock=1
7448         if (iabs(itype(i+1)).eq.20) iblock=2
7449 C Iblock=2 Proline type
7450 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7451 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7452 C        if (itype(i+1).eq.ntyp1) iblock=3
7453 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7454 C IS or IS NOT need for this
7455 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7456 C        is (itype(i-3).eq.ntyp1) ntblock=2
7457 C        ntblock is N-terminal blocking group
7458
7459 C Regular cosine and sine terms
7460         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7461 C Example of changes for NH3+ blocking group
7462 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7463 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7464           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7465           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7466           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7467           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7468           cosphi1=dcos(j*phii)
7469           sinphi1=dsin(j*phii)
7470           cosphi2=dcos(j*phii1)
7471           sinphi2=dsin(j*phii1)
7472           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7473      &     v2cij*cosphi2+v2sij*sinphi2
7474           if (energy_dec) etors_d_ii=etors_d_ii+
7475      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7476           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7477           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7478         enddo
7479         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7480           do l=1,k-1
7481             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7482             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7483             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7484             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7485             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7486             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7487             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7488             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7489             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7490      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7491             if (energy_dec) etors_d_ii=etors_d_ii+
7492      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7493      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7494             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7495      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7496             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7497      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7498           enddo
7499         enddo
7500           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7501      &         'etor_d',i,etors_d_ii
7502         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7503         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7504       enddo
7505       return
7506       end
7507 #endif
7508 c------------------------------------------------------------------------------
7509       subroutine eback_sc_corr(esccor)
7510 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7511 c        conformational states; temporarily implemented as differences
7512 c        between UNRES torsional potentials (dependent on three types of
7513 c        residues) and the torsional potentials dependent on all 20 types
7514 c        of residues computed from AM1  energy surfaces of terminally-blocked
7515 c        amino-acid residues.
7516       implicit real*8 (a-h,o-z)
7517       include 'DIMENSIONS'
7518       include 'COMMON.VAR'
7519       include 'COMMON.GEO'
7520       include 'COMMON.LOCAL'
7521       include 'COMMON.TORSION'
7522       include 'COMMON.SCCOR'
7523       include 'COMMON.INTERACT'
7524       include 'COMMON.DERIV'
7525       include 'COMMON.CHAIN'
7526       include 'COMMON.NAMES'
7527       include 'COMMON.IOUNITS'
7528       include 'COMMON.FFIELD'
7529       include 'COMMON.CONTROL'
7530       logical lprn
7531 C Set lprn=.true. for debugging
7532       lprn=.false.
7533 c      lprn=.true.
7534 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7535       esccor=0.0D0
7536       do i=itau_start,itau_end
7537         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7538         esccor_ii=0.0D0
7539         isccori=isccortyp(itype(i-2))
7540         isccori1=isccortyp(itype(i-1))
7541 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7542         phii=phi(i)
7543         do intertyp=1,3 !intertyp
7544 cc Added 09 May 2012 (Adasko)
7545 cc  Intertyp means interaction type of backbone mainchain correlation:
7546 c   1 = SC...Ca...Ca...Ca
7547 c   2 = Ca...Ca...Ca...SC
7548 c   3 = SC...Ca...Ca...SCi
7549         gloci=0.0D0
7550         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7551      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7552      &      (itype(i-1).eq.ntyp1)))
7553      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7554      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7555      &     .or.(itype(i).eq.ntyp1)))
7556      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7557      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7558      &      (itype(i-3).eq.ntyp1)))) cycle
7559         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7560         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7561      & cycle
7562        do j=1,nterm_sccor(isccori,isccori1)
7563           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7564           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7565           cosphi=dcos(j*tauangle(intertyp,i))
7566           sinphi=dsin(j*tauangle(intertyp,i))
7567           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7568           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7569         enddo
7570 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7571         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7572         if (lprn)
7573      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7574      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7575      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7576      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7577         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7578        enddo !intertyp
7579       enddo
7580
7581       return
7582       end
7583 c----------------------------------------------------------------------------
7584       subroutine multibody(ecorr)
7585 C This subroutine calculates multi-body contributions to energy following
7586 C the idea of Skolnick et al. If side chains I and J make a contact and
7587 C at the same time side chains I+1 and J+1 make a contact, an extra
7588 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7589       implicit real*8 (a-h,o-z)
7590       include 'DIMENSIONS'
7591       include 'COMMON.IOUNITS'
7592       include 'COMMON.DERIV'
7593       include 'COMMON.INTERACT'
7594       include 'COMMON.CONTACTS'
7595       double precision gx(3),gx1(3)
7596       logical lprn
7597
7598 C Set lprn=.true. for debugging
7599       lprn=.false.
7600
7601       if (lprn) then
7602         write (iout,'(a)') 'Contact function values:'
7603         do i=nnt,nct-2
7604           write (iout,'(i2,20(1x,i2,f10.5))')
7605      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7606         enddo
7607       endif
7608       ecorr=0.0D0
7609       do i=nnt,nct
7610         do j=1,3
7611           gradcorr(j,i)=0.0D0
7612           gradxorr(j,i)=0.0D0
7613         enddo
7614       enddo
7615       do i=nnt,nct-2
7616
7617         DO ISHIFT = 3,4
7618
7619         i1=i+ishift
7620         num_conti=num_cont(i)
7621         num_conti1=num_cont(i1)
7622         do jj=1,num_conti
7623           j=jcont(jj,i)
7624           do kk=1,num_conti1
7625             j1=jcont(kk,i1)
7626             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7627 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7628 cd   &                   ' ishift=',ishift
7629 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7630 C The system gains extra energy.
7631               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7632             endif   ! j1==j+-ishift
7633           enddo     ! kk
7634         enddo       ! jj
7635
7636         ENDDO ! ISHIFT
7637
7638       enddo         ! i
7639       return
7640       end
7641 c------------------------------------------------------------------------------
7642       double precision function esccorr(i,j,k,l,jj,kk)
7643       implicit real*8 (a-h,o-z)
7644       include 'DIMENSIONS'
7645       include 'COMMON.IOUNITS'
7646       include 'COMMON.DERIV'
7647       include 'COMMON.INTERACT'
7648       include 'COMMON.CONTACTS'
7649       double precision gx(3),gx1(3)
7650       logical lprn
7651       lprn=.false.
7652       eij=facont(jj,i)
7653       ekl=facont(kk,k)
7654 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7655 C Calculate the multi-body contribution to energy.
7656 C Calculate multi-body contributions to the gradient.
7657 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7658 cd   & k,l,(gacont(m,kk,k),m=1,3)
7659       do m=1,3
7660         gx(m) =ekl*gacont(m,jj,i)
7661         gx1(m)=eij*gacont(m,kk,k)
7662         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7663         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7664         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7665         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7666       enddo
7667       do m=i,j-1
7668         do ll=1,3
7669           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7670         enddo
7671       enddo
7672       do m=k,l-1
7673         do ll=1,3
7674           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7675         enddo
7676       enddo
7677       esccorr=-eij*ekl
7678       return
7679       end
7680 c------------------------------------------------------------------------------
7681       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7682 C This subroutine calculates multi-body contributions to hydrogen-bonding
7683       implicit real*8 (a-h,o-z)
7684       include 'DIMENSIONS'
7685       include 'COMMON.IOUNITS'
7686 #ifdef MPI
7687       include "mpif.h"
7688       parameter (max_cont=maxconts)
7689       parameter (max_dim=26)
7690       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7691       double precision zapas(max_dim,maxconts,max_fg_procs),
7692      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7693       common /przechowalnia/ zapas
7694       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7695      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7696 #endif
7697       include 'COMMON.SETUP'
7698       include 'COMMON.FFIELD'
7699       include 'COMMON.DERIV'
7700       include 'COMMON.INTERACT'
7701       include 'COMMON.CONTACTS'
7702       include 'COMMON.CONTROL'
7703       include 'COMMON.LOCAL'
7704       double precision gx(3),gx1(3),time00
7705       logical lprn,ldone
7706
7707 C Set lprn=.true. for debugging
7708       lprn=.false.
7709 #ifdef MPI
7710       n_corr=0
7711       n_corr1=0
7712       if (nfgtasks.le.1) goto 30
7713       if (lprn) then
7714         write (iout,'(a)') 'Contact function values before RECEIVE:'
7715         do i=nnt,nct-2
7716           write (iout,'(2i3,50(1x,i2,f5.2))')
7717      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7718      &    j=1,num_cont_hb(i))
7719         enddo
7720       endif
7721       call flush(iout)
7722       do i=1,ntask_cont_from
7723         ncont_recv(i)=0
7724       enddo
7725       do i=1,ntask_cont_to
7726         ncont_sent(i)=0
7727       enddo
7728 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7729 c     & ntask_cont_to
7730 C Make the list of contacts to send to send to other procesors
7731 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7732 c      call flush(iout)
7733       do i=iturn3_start,iturn3_end
7734 c        write (iout,*) "make contact list turn3",i," num_cont",
7735 c     &    num_cont_hb(i)
7736         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7737       enddo
7738       do i=iturn4_start,iturn4_end
7739 c        write (iout,*) "make contact list turn4",i," num_cont",
7740 c     &   num_cont_hb(i)
7741         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7742       enddo
7743       do ii=1,nat_sent
7744         i=iat_sent(ii)
7745 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7746 c     &    num_cont_hb(i)
7747         do j=1,num_cont_hb(i)
7748         do k=1,4
7749           jjc=jcont_hb(j,i)
7750           iproc=iint_sent_local(k,jjc,ii)
7751 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7752           if (iproc.gt.0) then
7753             ncont_sent(iproc)=ncont_sent(iproc)+1
7754             nn=ncont_sent(iproc)
7755             zapas(1,nn,iproc)=i
7756             zapas(2,nn,iproc)=jjc
7757             zapas(3,nn,iproc)=facont_hb(j,i)
7758             zapas(4,nn,iproc)=ees0p(j,i)
7759             zapas(5,nn,iproc)=ees0m(j,i)
7760             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7761             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7762             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7763             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7764             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7765             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7766             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7767             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7768             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7769             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7770             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7771             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7772             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7773             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7774             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7775             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7776             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7777             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7778             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7779             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7780             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7781           endif
7782         enddo
7783         enddo
7784       enddo
7785       if (lprn) then
7786       write (iout,*)
7787      &  "Numbers of contacts to be sent to other processors",
7788      &  (ncont_sent(i),i=1,ntask_cont_to)
7789       write (iout,*) "Contacts sent"
7790       do ii=1,ntask_cont_to
7791         nn=ncont_sent(ii)
7792         iproc=itask_cont_to(ii)
7793         write (iout,*) nn," contacts to processor",iproc,
7794      &   " of CONT_TO_COMM group"
7795         do i=1,nn
7796           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7797         enddo
7798       enddo
7799       call flush(iout)
7800       endif
7801       CorrelType=477
7802       CorrelID=fg_rank+1
7803       CorrelType1=478
7804       CorrelID1=nfgtasks+fg_rank+1
7805       ireq=0
7806 C Receive the numbers of needed contacts from other processors
7807       do ii=1,ntask_cont_from
7808         iproc=itask_cont_from(ii)
7809         ireq=ireq+1
7810         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7811      &    FG_COMM,req(ireq),IERR)
7812       enddo
7813 c      write (iout,*) "IRECV ended"
7814 c      call flush(iout)
7815 C Send the number of contacts needed by other processors
7816       do ii=1,ntask_cont_to
7817         iproc=itask_cont_to(ii)
7818         ireq=ireq+1
7819         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7820      &    FG_COMM,req(ireq),IERR)
7821       enddo
7822 c      write (iout,*) "ISEND ended"
7823 c      write (iout,*) "number of requests (nn)",ireq
7824       call flush(iout)
7825       if (ireq.gt.0)
7826      &  call MPI_Waitall(ireq,req,status_array,ierr)
7827 c      write (iout,*)
7828 c     &  "Numbers of contacts to be received from other processors",
7829 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7830 c      call flush(iout)
7831 C Receive contacts
7832       ireq=0
7833       do ii=1,ntask_cont_from
7834         iproc=itask_cont_from(ii)
7835         nn=ncont_recv(ii)
7836 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7837 c     &   " of CONT_TO_COMM group"
7838         call flush(iout)
7839         if (nn.gt.0) then
7840           ireq=ireq+1
7841           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7842      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7843 c          write (iout,*) "ireq,req",ireq,req(ireq)
7844         endif
7845       enddo
7846 C Send the contacts to processors that need them
7847       do ii=1,ntask_cont_to
7848         iproc=itask_cont_to(ii)
7849         nn=ncont_sent(ii)
7850 c        write (iout,*) nn," contacts to processor",iproc,
7851 c     &   " of CONT_TO_COMM group"
7852         if (nn.gt.0) then
7853           ireq=ireq+1
7854           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7855      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7856 c          write (iout,*) "ireq,req",ireq,req(ireq)
7857 c          do i=1,nn
7858 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7859 c          enddo
7860         endif
7861       enddo
7862 c      write (iout,*) "number of requests (contacts)",ireq
7863 c      write (iout,*) "req",(req(i),i=1,4)
7864 c      call flush(iout)
7865       if (ireq.gt.0)
7866      & call MPI_Waitall(ireq,req,status_array,ierr)
7867       do iii=1,ntask_cont_from
7868         iproc=itask_cont_from(iii)
7869         nn=ncont_recv(iii)
7870         if (lprn) then
7871         write (iout,*) "Received",nn," contacts from processor",iproc,
7872      &   " of CONT_FROM_COMM group"
7873         call flush(iout)
7874         do i=1,nn
7875           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7876         enddo
7877         call flush(iout)
7878         endif
7879         do i=1,nn
7880           ii=zapas_recv(1,i,iii)
7881 c Flag the received contacts to prevent double-counting
7882           jj=-zapas_recv(2,i,iii)
7883 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7884 c          call flush(iout)
7885           nnn=num_cont_hb(ii)+1
7886           num_cont_hb(ii)=nnn
7887           jcont_hb(nnn,ii)=jj
7888           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7889           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7890           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7891           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7892           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7893           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7894           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7895           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7896           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7897           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7898           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7899           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7900           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7901           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7902           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7903           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7904           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7905           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7906           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7907           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7908           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7909           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7910           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7911           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7912         enddo
7913       enddo
7914       call flush(iout)
7915       if (lprn) then
7916         write (iout,'(a)') 'Contact function values after receive:'
7917         do i=nnt,nct-2
7918           write (iout,'(2i3,50(1x,i3,f5.2))')
7919      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7920      &    j=1,num_cont_hb(i))
7921         enddo
7922         call flush(iout)
7923       endif
7924    30 continue
7925 #endif
7926       if (lprn) then
7927         write (iout,'(a)') 'Contact function values:'
7928         do i=nnt,nct-2
7929           write (iout,'(2i3,50(1x,i3,f5.2))')
7930      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7931      &    j=1,num_cont_hb(i))
7932         enddo
7933       endif
7934       ecorr=0.0D0
7935 C Remove the loop below after debugging !!!
7936       do i=nnt,nct
7937         do j=1,3
7938           gradcorr(j,i)=0.0D0
7939           gradxorr(j,i)=0.0D0
7940         enddo
7941       enddo
7942 C Calculate the local-electrostatic correlation terms
7943       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7944         i1=i+1
7945         num_conti=num_cont_hb(i)
7946         num_conti1=num_cont_hb(i+1)
7947         do jj=1,num_conti
7948           j=jcont_hb(jj,i)
7949           jp=iabs(j)
7950           do kk=1,num_conti1
7951             j1=jcont_hb(kk,i1)
7952             jp1=iabs(j1)
7953 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7954 c     &         ' jj=',jj,' kk=',kk
7955             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7956      &          .or. j.lt.0 .and. j1.gt.0) .and.
7957      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7958 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7959 C The system gains extra energy.
7960               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7961               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7962      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7963               n_corr=n_corr+1
7964             else if (j1.eq.j) then
7965 C Contacts I-J and I-(J+1) occur simultaneously.
7966 C The system loses extra energy.
7967 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7968             endif
7969           enddo ! kk
7970           do kk=1,num_conti
7971             j1=jcont_hb(kk,i)
7972 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7973 c    &         ' jj=',jj,' kk=',kk
7974             if (j1.eq.j+1) then
7975 C Contacts I-J and (I+1)-J occur simultaneously.
7976 C The system loses extra energy.
7977 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7978             endif ! j1==j+1
7979           enddo ! kk
7980         enddo ! jj
7981       enddo ! i
7982       return
7983       end
7984 c------------------------------------------------------------------------------
7985       subroutine add_hb_contact(ii,jj,itask)
7986       implicit real*8 (a-h,o-z)
7987       include "DIMENSIONS"
7988       include "COMMON.IOUNITS"
7989       integer max_cont
7990       integer max_dim
7991       parameter (max_cont=maxconts)
7992       parameter (max_dim=26)
7993       include "COMMON.CONTACTS"
7994       double precision zapas(max_dim,maxconts,max_fg_procs),
7995      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7996       common /przechowalnia/ zapas
7997       integer i,j,ii,jj,iproc,itask(4),nn
7998 c      write (iout,*) "itask",itask
7999       do i=1,2
8000         iproc=itask(i)
8001         if (iproc.gt.0) then
8002           do j=1,num_cont_hb(ii)
8003             jjc=jcont_hb(j,ii)
8004 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8005             if (jjc.eq.jj) then
8006               ncont_sent(iproc)=ncont_sent(iproc)+1
8007               nn=ncont_sent(iproc)
8008               zapas(1,nn,iproc)=ii
8009               zapas(2,nn,iproc)=jjc
8010               zapas(3,nn,iproc)=facont_hb(j,ii)
8011               zapas(4,nn,iproc)=ees0p(j,ii)
8012               zapas(5,nn,iproc)=ees0m(j,ii)
8013               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8014               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8015               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8016               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8017               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8018               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8019               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8020               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8021               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8022               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8023               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8024               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8025               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8026               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8027               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8028               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8029               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8030               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8031               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8032               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8033               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8034               exit
8035             endif
8036           enddo
8037         endif
8038       enddo
8039       return
8040       end
8041 c------------------------------------------------------------------------------
8042       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8043      &  n_corr1)
8044 C This subroutine calculates multi-body contributions to hydrogen-bonding
8045       implicit real*8 (a-h,o-z)
8046       include 'DIMENSIONS'
8047       include 'COMMON.IOUNITS'
8048 #ifdef MPI
8049       include "mpif.h"
8050       parameter (max_cont=maxconts)
8051       parameter (max_dim=70)
8052       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8053       double precision zapas(max_dim,maxconts,max_fg_procs),
8054      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8055       common /przechowalnia/ zapas
8056       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8057      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8058 #endif
8059       include 'COMMON.SETUP'
8060       include 'COMMON.FFIELD'
8061       include 'COMMON.DERIV'
8062       include 'COMMON.LOCAL'
8063       include 'COMMON.INTERACT'
8064       include 'COMMON.CONTACTS'
8065       include 'COMMON.CHAIN'
8066       include 'COMMON.CONTROL'
8067       double precision gx(3),gx1(3)
8068       integer num_cont_hb_old(maxres)
8069       logical lprn,ldone
8070       double precision eello4,eello5,eelo6,eello_turn6
8071       external eello4,eello5,eello6,eello_turn6
8072 C Set lprn=.true. for debugging
8073       lprn=.false.
8074       eturn6=0.0d0
8075 #ifdef MPI
8076       do i=1,nres
8077         num_cont_hb_old(i)=num_cont_hb(i)
8078       enddo
8079       n_corr=0
8080       n_corr1=0
8081       if (nfgtasks.le.1) goto 30
8082       if (lprn) then
8083         write (iout,'(a)') 'Contact function values before RECEIVE:'
8084         do i=nnt,nct-2
8085           write (iout,'(2i3,50(1x,i2,f5.2))')
8086      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8087      &    j=1,num_cont_hb(i))
8088         enddo
8089       endif
8090       call flush(iout)
8091       do i=1,ntask_cont_from
8092         ncont_recv(i)=0
8093       enddo
8094       do i=1,ntask_cont_to
8095         ncont_sent(i)=0
8096       enddo
8097 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8098 c     & ntask_cont_to
8099 C Make the list of contacts to send to send to other procesors
8100       do i=iturn3_start,iturn3_end
8101 c        write (iout,*) "make contact list turn3",i," num_cont",
8102 c     &    num_cont_hb(i)
8103         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8104       enddo
8105       do i=iturn4_start,iturn4_end
8106 c        write (iout,*) "make contact list turn4",i," num_cont",
8107 c     &   num_cont_hb(i)
8108         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8109       enddo
8110       do ii=1,nat_sent
8111         i=iat_sent(ii)
8112 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8113 c     &    num_cont_hb(i)
8114         do j=1,num_cont_hb(i)
8115         do k=1,4
8116           jjc=jcont_hb(j,i)
8117           iproc=iint_sent_local(k,jjc,ii)
8118 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8119           if (iproc.ne.0) then
8120             ncont_sent(iproc)=ncont_sent(iproc)+1
8121             nn=ncont_sent(iproc)
8122             zapas(1,nn,iproc)=i
8123             zapas(2,nn,iproc)=jjc
8124             zapas(3,nn,iproc)=d_cont(j,i)
8125             ind=3
8126             do kk=1,3
8127               ind=ind+1
8128               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8129             enddo
8130             do kk=1,2
8131               do ll=1,2
8132                 ind=ind+1
8133                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8134               enddo
8135             enddo
8136             do jj=1,5
8137               do kk=1,3
8138                 do ll=1,2
8139                   do mm=1,2
8140                     ind=ind+1
8141                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8142                   enddo
8143                 enddo
8144               enddo
8145             enddo
8146           endif
8147         enddo
8148         enddo
8149       enddo
8150       if (lprn) then
8151       write (iout,*)
8152      &  "Numbers of contacts to be sent to other processors",
8153      &  (ncont_sent(i),i=1,ntask_cont_to)
8154       write (iout,*) "Contacts sent"
8155       do ii=1,ntask_cont_to
8156         nn=ncont_sent(ii)
8157         iproc=itask_cont_to(ii)
8158         write (iout,*) nn," contacts to processor",iproc,
8159      &   " of CONT_TO_COMM group"
8160         do i=1,nn
8161           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8162         enddo
8163       enddo
8164       call flush(iout)
8165       endif
8166       CorrelType=477
8167       CorrelID=fg_rank+1
8168       CorrelType1=478
8169       CorrelID1=nfgtasks+fg_rank+1
8170       ireq=0
8171 C Receive the numbers of needed contacts from other processors
8172       do ii=1,ntask_cont_from
8173         iproc=itask_cont_from(ii)
8174         ireq=ireq+1
8175         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8176      &    FG_COMM,req(ireq),IERR)
8177       enddo
8178 c      write (iout,*) "IRECV ended"
8179 c      call flush(iout)
8180 C Send the number of contacts needed by other processors
8181       do ii=1,ntask_cont_to
8182         iproc=itask_cont_to(ii)
8183         ireq=ireq+1
8184         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8185      &    FG_COMM,req(ireq),IERR)
8186       enddo
8187 c      write (iout,*) "ISEND ended"
8188 c      write (iout,*) "number of requests (nn)",ireq
8189       call flush(iout)
8190       if (ireq.gt.0)
8191      &  call MPI_Waitall(ireq,req,status_array,ierr)
8192 c      write (iout,*)
8193 c     &  "Numbers of contacts to be received from other processors",
8194 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8195 c      call flush(iout)
8196 C Receive contacts
8197       ireq=0
8198       do ii=1,ntask_cont_from
8199         iproc=itask_cont_from(ii)
8200         nn=ncont_recv(ii)
8201 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8202 c     &   " of CONT_TO_COMM group"
8203         call flush(iout)
8204         if (nn.gt.0) then
8205           ireq=ireq+1
8206           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8207      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8208 c          write (iout,*) "ireq,req",ireq,req(ireq)
8209         endif
8210       enddo
8211 C Send the contacts to processors that need them
8212       do ii=1,ntask_cont_to
8213         iproc=itask_cont_to(ii)
8214         nn=ncont_sent(ii)
8215 c        write (iout,*) nn," contacts to processor",iproc,
8216 c     &   " of CONT_TO_COMM group"
8217         if (nn.gt.0) then
8218           ireq=ireq+1
8219           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8220      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8221 c          write (iout,*) "ireq,req",ireq,req(ireq)
8222 c          do i=1,nn
8223 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8224 c          enddo
8225         endif
8226       enddo
8227 c      write (iout,*) "number of requests (contacts)",ireq
8228 c      write (iout,*) "req",(req(i),i=1,4)
8229 c      call flush(iout)
8230       if (ireq.gt.0)
8231      & call MPI_Waitall(ireq,req,status_array,ierr)
8232       do iii=1,ntask_cont_from
8233         iproc=itask_cont_from(iii)
8234         nn=ncont_recv(iii)
8235         if (lprn) then
8236         write (iout,*) "Received",nn," contacts from processor",iproc,
8237      &   " of CONT_FROM_COMM group"
8238         call flush(iout)
8239         do i=1,nn
8240           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8241         enddo
8242         call flush(iout)
8243         endif
8244         do i=1,nn
8245           ii=zapas_recv(1,i,iii)
8246 c Flag the received contacts to prevent double-counting
8247           jj=-zapas_recv(2,i,iii)
8248 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8249 c          call flush(iout)
8250           nnn=num_cont_hb(ii)+1
8251           num_cont_hb(ii)=nnn
8252           jcont_hb(nnn,ii)=jj
8253           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8254           ind=3
8255           do kk=1,3
8256             ind=ind+1
8257             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8258           enddo
8259           do kk=1,2
8260             do ll=1,2
8261               ind=ind+1
8262               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8263             enddo
8264           enddo
8265           do jj=1,5
8266             do kk=1,3
8267               do ll=1,2
8268                 do mm=1,2
8269                   ind=ind+1
8270                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8271                 enddo
8272               enddo
8273             enddo
8274           enddo
8275         enddo
8276       enddo
8277       call flush(iout)
8278       if (lprn) then
8279         write (iout,'(a)') 'Contact function values after receive:'
8280         do i=nnt,nct-2
8281           write (iout,'(2i3,50(1x,i3,5f6.3))')
8282      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8283      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8284         enddo
8285         call flush(iout)
8286       endif
8287    30 continue
8288 #endif
8289       if (lprn) then
8290         write (iout,'(a)') 'Contact function values:'
8291         do i=nnt,nct-2
8292           write (iout,'(2i3,50(1x,i2,5f6.3))')
8293      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8294      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8295         enddo
8296       endif
8297       ecorr=0.0D0
8298       ecorr5=0.0d0
8299       ecorr6=0.0d0
8300 C Remove the loop below after debugging !!!
8301       do i=nnt,nct
8302         do j=1,3
8303           gradcorr(j,i)=0.0D0
8304           gradxorr(j,i)=0.0D0
8305         enddo
8306       enddo
8307 C Calculate the dipole-dipole interaction energies
8308       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8309       do i=iatel_s,iatel_e+1
8310         num_conti=num_cont_hb(i)
8311         do jj=1,num_conti
8312           j=jcont_hb(jj,i)
8313 #ifdef MOMENT
8314           call dipole(i,j,jj)
8315 #endif
8316         enddo
8317       enddo
8318       endif
8319 C Calculate the local-electrostatic correlation terms
8320 c                write (iout,*) "gradcorr5 in eello5 before loop"
8321 c                do iii=1,nres
8322 c                  write (iout,'(i5,3f10.5)')
8323 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8324 c                enddo
8325       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8326 c        write (iout,*) "corr loop i",i
8327         i1=i+1
8328         num_conti=num_cont_hb(i)
8329         num_conti1=num_cont_hb(i+1)
8330         do jj=1,num_conti
8331           j=jcont_hb(jj,i)
8332           jp=iabs(j)
8333           do kk=1,num_conti1
8334             j1=jcont_hb(kk,i1)
8335             jp1=iabs(j1)
8336 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8337 c     &         ' jj=',jj,' kk=',kk
8338 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8339             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8340      &          .or. j.lt.0 .and. j1.gt.0) .and.
8341      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8342 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8343 C The system gains extra energy.
8344               n_corr=n_corr+1
8345               sqd1=dsqrt(d_cont(jj,i))
8346               sqd2=dsqrt(d_cont(kk,i1))
8347               sred_geom = sqd1*sqd2
8348               IF (sred_geom.lt.cutoff_corr) THEN
8349                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8350      &            ekont,fprimcont)
8351 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8352 cd     &         ' jj=',jj,' kk=',kk
8353                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8354                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8355                 do l=1,3
8356                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8357                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8358                 enddo
8359                 n_corr1=n_corr1+1
8360 cd               write (iout,*) 'sred_geom=',sred_geom,
8361 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8362 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8363 cd               write (iout,*) "g_contij",g_contij
8364 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8365 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8366                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8367                 if (wcorr4.gt.0.0d0)
8368      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8369                   if (energy_dec.and.wcorr4.gt.0.0d0)
8370      1                 write (iout,'(a6,4i5,0pf7.3)')
8371      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8372 c                write (iout,*) "gradcorr5 before eello5"
8373 c                do iii=1,nres
8374 c                  write (iout,'(i5,3f10.5)')
8375 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8376 c                enddo
8377                 if (wcorr5.gt.0.0d0)
8378      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8379 c                write (iout,*) "gradcorr5 after eello5"
8380 c                do iii=1,nres
8381 c                  write (iout,'(i5,3f10.5)')
8382 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8383 c                enddo
8384                   if (energy_dec.and.wcorr5.gt.0.0d0)
8385      1                 write (iout,'(a6,4i5,0pf7.3)')
8386      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8387 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8388 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8389                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8390      &               .or. wturn6.eq.0.0d0))then
8391 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8392                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8393                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8394      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8395 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8396 cd     &            'ecorr6=',ecorr6
8397 cd                write (iout,'(4e15.5)') sred_geom,
8398 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8399 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8400 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8401                 else if (wturn6.gt.0.0d0
8402      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8403 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8404                   eturn6=eturn6+eello_turn6(i,jj,kk)
8405                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8406      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8407 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8408                 endif
8409               ENDIF
8410 1111          continue
8411             endif
8412           enddo ! kk
8413         enddo ! jj
8414       enddo ! i
8415       do i=1,nres
8416         num_cont_hb(i)=num_cont_hb_old(i)
8417       enddo
8418 c                write (iout,*) "gradcorr5 in eello5"
8419 c                do iii=1,nres
8420 c                  write (iout,'(i5,3f10.5)')
8421 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8422 c                enddo
8423       return
8424       end
8425 c------------------------------------------------------------------------------
8426       subroutine add_hb_contact_eello(ii,jj,itask)
8427       implicit real*8 (a-h,o-z)
8428       include "DIMENSIONS"
8429       include "COMMON.IOUNITS"
8430       integer max_cont
8431       integer max_dim
8432       parameter (max_cont=maxconts)
8433       parameter (max_dim=70)
8434       include "COMMON.CONTACTS"
8435       double precision zapas(max_dim,maxconts,max_fg_procs),
8436      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8437       common /przechowalnia/ zapas
8438       integer i,j,ii,jj,iproc,itask(4),nn
8439 c      write (iout,*) "itask",itask
8440       do i=1,2
8441         iproc=itask(i)
8442         if (iproc.gt.0) then
8443           do j=1,num_cont_hb(ii)
8444             jjc=jcont_hb(j,ii)
8445 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8446             if (jjc.eq.jj) then
8447               ncont_sent(iproc)=ncont_sent(iproc)+1
8448               nn=ncont_sent(iproc)
8449               zapas(1,nn,iproc)=ii
8450               zapas(2,nn,iproc)=jjc
8451               zapas(3,nn,iproc)=d_cont(j,ii)
8452               ind=3
8453               do kk=1,3
8454                 ind=ind+1
8455                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8456               enddo
8457               do kk=1,2
8458                 do ll=1,2
8459                   ind=ind+1
8460                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8461                 enddo
8462               enddo
8463               do jj=1,5
8464                 do kk=1,3
8465                   do ll=1,2
8466                     do mm=1,2
8467                       ind=ind+1
8468                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8469                     enddo
8470                   enddo
8471                 enddo
8472               enddo
8473               exit
8474             endif
8475           enddo
8476         endif
8477       enddo
8478       return
8479       end
8480 c------------------------------------------------------------------------------
8481       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8482       implicit real*8 (a-h,o-z)
8483       include 'DIMENSIONS'
8484       include 'COMMON.IOUNITS'
8485       include 'COMMON.DERIV'
8486       include 'COMMON.INTERACT'
8487       include 'COMMON.CONTACTS'
8488       double precision gx(3),gx1(3)
8489       logical lprn
8490       lprn=.false.
8491       eij=facont_hb(jj,i)
8492       ekl=facont_hb(kk,k)
8493       ees0pij=ees0p(jj,i)
8494       ees0pkl=ees0p(kk,k)
8495       ees0mij=ees0m(jj,i)
8496       ees0mkl=ees0m(kk,k)
8497       ekont=eij*ekl
8498       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8499 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8500 C Following 4 lines for diagnostics.
8501 cd    ees0pkl=0.0D0
8502 cd    ees0pij=1.0D0
8503 cd    ees0mkl=0.0D0
8504 cd    ees0mij=1.0D0
8505 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8506 c     & 'Contacts ',i,j,
8507 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8508 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8509 c     & 'gradcorr_long'
8510 C Calculate the multi-body contribution to energy.
8511 c      ecorr=ecorr+ekont*ees
8512 C Calculate multi-body contributions to the gradient.
8513       coeffpees0pij=coeffp*ees0pij
8514       coeffmees0mij=coeffm*ees0mij
8515       coeffpees0pkl=coeffp*ees0pkl
8516       coeffmees0mkl=coeffm*ees0mkl
8517       do ll=1,3
8518 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8519         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8520      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8521      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8522         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8523      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8524      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8525 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8526         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8527      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8528      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8529         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8530      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8531      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8532         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8533      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8534      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8535         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8536         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8537         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8538      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8539      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8540         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8541         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8542 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8543       enddo
8544 c      write (iout,*)
8545 cgrad      do m=i+1,j-1
8546 cgrad        do ll=1,3
8547 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8548 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8549 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8550 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8551 cgrad        enddo
8552 cgrad      enddo
8553 cgrad      do m=k+1,l-1
8554 cgrad        do ll=1,3
8555 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8556 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8557 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8558 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8559 cgrad        enddo
8560 cgrad      enddo
8561 c      write (iout,*) "ehbcorr",ekont*ees
8562       ehbcorr=ekont*ees
8563       return
8564       end
8565 #ifdef MOMENT
8566 C---------------------------------------------------------------------------
8567       subroutine dipole(i,j,jj)
8568       implicit real*8 (a-h,o-z)
8569       include 'DIMENSIONS'
8570       include 'COMMON.IOUNITS'
8571       include 'COMMON.CHAIN'
8572       include 'COMMON.FFIELD'
8573       include 'COMMON.DERIV'
8574       include 'COMMON.INTERACT'
8575       include 'COMMON.CONTACTS'
8576       include 'COMMON.TORSION'
8577       include 'COMMON.VAR'
8578       include 'COMMON.GEO'
8579       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8580      &  auxmat(2,2)
8581       iti1 = itortyp(itype(i+1))
8582       if (j.lt.nres-1) then
8583         itj1 = itortyp(itype(j+1))
8584       else
8585         itj1=ntortyp
8586       endif
8587       do iii=1,2
8588         dipi(iii,1)=Ub2(iii,i)
8589         dipderi(iii)=Ub2der(iii,i)
8590         dipi(iii,2)=b1(iii,i+1)
8591         dipj(iii,1)=Ub2(iii,j)
8592         dipderj(iii)=Ub2der(iii,j)
8593         dipj(iii,2)=b1(iii,j+1)
8594       enddo
8595       kkk=0
8596       do iii=1,2
8597         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8598         do jjj=1,2
8599           kkk=kkk+1
8600           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8601         enddo
8602       enddo
8603       do kkk=1,5
8604         do lll=1,3
8605           mmm=0
8606           do iii=1,2
8607             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8608      &        auxvec(1))
8609             do jjj=1,2
8610               mmm=mmm+1
8611               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8612             enddo
8613           enddo
8614         enddo
8615       enddo
8616       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8617       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8618       do iii=1,2
8619         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8620       enddo
8621       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8622       do iii=1,2
8623         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8624       enddo
8625       return
8626       end
8627 #endif
8628 C---------------------------------------------------------------------------
8629       subroutine calc_eello(i,j,k,l,jj,kk)
8630 C
8631 C This subroutine computes matrices and vectors needed to calculate
8632 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8633 C
8634       implicit real*8 (a-h,o-z)
8635       include 'DIMENSIONS'
8636       include 'COMMON.IOUNITS'
8637       include 'COMMON.CHAIN'
8638       include 'COMMON.DERIV'
8639       include 'COMMON.INTERACT'
8640       include 'COMMON.CONTACTS'
8641       include 'COMMON.TORSION'
8642       include 'COMMON.VAR'
8643       include 'COMMON.GEO'
8644       include 'COMMON.FFIELD'
8645       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8646      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8647       logical lprn
8648       common /kutas/ lprn
8649 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8650 cd     & ' jj=',jj,' kk=',kk
8651 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8652 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8653 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8654       do iii=1,2
8655         do jjj=1,2
8656           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8657           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8658         enddo
8659       enddo
8660       call transpose2(aa1(1,1),aa1t(1,1))
8661       call transpose2(aa2(1,1),aa2t(1,1))
8662       do kkk=1,5
8663         do lll=1,3
8664           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8665      &      aa1tder(1,1,lll,kkk))
8666           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8667      &      aa2tder(1,1,lll,kkk))
8668         enddo
8669       enddo
8670       if (l.eq.j+1) then
8671 C parallel orientation of the two CA-CA-CA frames.
8672         if (i.gt.1) then
8673           iti=itortyp(itype(i))
8674         else
8675           iti=ntortyp
8676         endif
8677         itk1=itortyp(itype(k+1))
8678         itj=itortyp(itype(j))
8679         if (l.lt.nres-1) then
8680           itl1=itortyp(itype(l+1))
8681         else
8682           itl1=ntortyp
8683         endif
8684 C A1 kernel(j+1) A2T
8685 cd        do iii=1,2
8686 cd          write (iout,'(3f10.5,5x,3f10.5)')
8687 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8688 cd        enddo
8689         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8690      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8691      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8692 C Following matrices are needed only for 6-th order cumulants
8693         IF (wcorr6.gt.0.0d0) THEN
8694         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8695      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8696      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8697         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8698      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8699      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8700      &   ADtEAderx(1,1,1,1,1,1))
8701         lprn=.false.
8702         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8703      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8704      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8705      &   ADtEA1derx(1,1,1,1,1,1))
8706         ENDIF
8707 C End 6-th order cumulants
8708 cd        lprn=.false.
8709 cd        if (lprn) then
8710 cd        write (2,*) 'In calc_eello6'
8711 cd        do iii=1,2
8712 cd          write (2,*) 'iii=',iii
8713 cd          do kkk=1,5
8714 cd            write (2,*) 'kkk=',kkk
8715 cd            do jjj=1,2
8716 cd              write (2,'(3(2f10.5),5x)')
8717 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8718 cd            enddo
8719 cd          enddo
8720 cd        enddo
8721 cd        endif
8722         call transpose2(EUgder(1,1,k),auxmat(1,1))
8723         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8724         call transpose2(EUg(1,1,k),auxmat(1,1))
8725         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8726         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8727         do iii=1,2
8728           do kkk=1,5
8729             do lll=1,3
8730               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8731      &          EAEAderx(1,1,lll,kkk,iii,1))
8732             enddo
8733           enddo
8734         enddo
8735 C A1T kernel(i+1) A2
8736         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8737      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8738      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8739 C Following matrices are needed only for 6-th order cumulants
8740         IF (wcorr6.gt.0.0d0) THEN
8741         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8742      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8743      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8744         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8745      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8746      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8747      &   ADtEAderx(1,1,1,1,1,2))
8748         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8749      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8750      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8751      &   ADtEA1derx(1,1,1,1,1,2))
8752         ENDIF
8753 C End 6-th order cumulants
8754         call transpose2(EUgder(1,1,l),auxmat(1,1))
8755         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8756         call transpose2(EUg(1,1,l),auxmat(1,1))
8757         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8758         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8759         do iii=1,2
8760           do kkk=1,5
8761             do lll=1,3
8762               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8763      &          EAEAderx(1,1,lll,kkk,iii,2))
8764             enddo
8765           enddo
8766         enddo
8767 C AEAb1 and AEAb2
8768 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8769 C They are needed only when the fifth- or the sixth-order cumulants are
8770 C indluded.
8771         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8772         call transpose2(AEA(1,1,1),auxmat(1,1))
8773         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8774         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8775         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8776         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8777         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8778         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8779         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8780         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8781         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8782         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8783         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8784         call transpose2(AEA(1,1,2),auxmat(1,1))
8785         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8786         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8787         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8788         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8789         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8790         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8791         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8792         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8793         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8794         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8795         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8796 C Calculate the Cartesian derivatives of the vectors.
8797         do iii=1,2
8798           do kkk=1,5
8799             do lll=1,3
8800               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8801               call matvec2(auxmat(1,1),b1(1,i),
8802      &          AEAb1derx(1,lll,kkk,iii,1,1))
8803               call matvec2(auxmat(1,1),Ub2(1,i),
8804      &          AEAb2derx(1,lll,kkk,iii,1,1))
8805               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8806      &          AEAb1derx(1,lll,kkk,iii,2,1))
8807               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8808      &          AEAb2derx(1,lll,kkk,iii,2,1))
8809               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8810               call matvec2(auxmat(1,1),b1(1,j),
8811      &          AEAb1derx(1,lll,kkk,iii,1,2))
8812               call matvec2(auxmat(1,1),Ub2(1,j),
8813      &          AEAb2derx(1,lll,kkk,iii,1,2))
8814               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8815      &          AEAb1derx(1,lll,kkk,iii,2,2))
8816               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8817      &          AEAb2derx(1,lll,kkk,iii,2,2))
8818             enddo
8819           enddo
8820         enddo
8821         ENDIF
8822 C End vectors
8823       else
8824 C Antiparallel orientation of the two CA-CA-CA frames.
8825         if (i.gt.1) then
8826           iti=itortyp(itype(i))
8827         else
8828           iti=ntortyp
8829         endif
8830         itk1=itortyp(itype(k+1))
8831         itl=itortyp(itype(l))
8832         itj=itortyp(itype(j))
8833         if (j.lt.nres-1) then
8834           itj1=itortyp(itype(j+1))
8835         else
8836           itj1=ntortyp
8837         endif
8838 C A2 kernel(j-1)T A1T
8839         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8840      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8841      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8842 C Following matrices are needed only for 6-th order cumulants
8843         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8844      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8845         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8846      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8847      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8848         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8849      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8850      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8851      &   ADtEAderx(1,1,1,1,1,1))
8852         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8853      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8854      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8855      &   ADtEA1derx(1,1,1,1,1,1))
8856         ENDIF
8857 C End 6-th order cumulants
8858         call transpose2(EUgder(1,1,k),auxmat(1,1))
8859         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8860         call transpose2(EUg(1,1,k),auxmat(1,1))
8861         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8862         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8863         do iii=1,2
8864           do kkk=1,5
8865             do lll=1,3
8866               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8867      &          EAEAderx(1,1,lll,kkk,iii,1))
8868             enddo
8869           enddo
8870         enddo
8871 C A2T kernel(i+1)T A1
8872         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8873      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8874      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8875 C Following matrices are needed only for 6-th order cumulants
8876         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8877      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8878         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8879      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8880      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8881         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8882      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8883      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8884      &   ADtEAderx(1,1,1,1,1,2))
8885         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8886      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8887      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8888      &   ADtEA1derx(1,1,1,1,1,2))
8889         ENDIF
8890 C End 6-th order cumulants
8891         call transpose2(EUgder(1,1,j),auxmat(1,1))
8892         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8893         call transpose2(EUg(1,1,j),auxmat(1,1))
8894         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8895         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8896         do iii=1,2
8897           do kkk=1,5
8898             do lll=1,3
8899               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8900      &          EAEAderx(1,1,lll,kkk,iii,2))
8901             enddo
8902           enddo
8903         enddo
8904 C AEAb1 and AEAb2
8905 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8906 C They are needed only when the fifth- or the sixth-order cumulants are
8907 C indluded.
8908         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8909      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8910         call transpose2(AEA(1,1,1),auxmat(1,1))
8911         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8912         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8913         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8914         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8915         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8916         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8917         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8918         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8919         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8920         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8921         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8922         call transpose2(AEA(1,1,2),auxmat(1,1))
8923         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8924         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8925         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8926         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8927         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8928         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8929         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8930         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8931         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8932         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8933         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8934 C Calculate the Cartesian derivatives of the vectors.
8935         do iii=1,2
8936           do kkk=1,5
8937             do lll=1,3
8938               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8939               call matvec2(auxmat(1,1),b1(1,i),
8940      &          AEAb1derx(1,lll,kkk,iii,1,1))
8941               call matvec2(auxmat(1,1),Ub2(1,i),
8942      &          AEAb2derx(1,lll,kkk,iii,1,1))
8943               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8944      &          AEAb1derx(1,lll,kkk,iii,2,1))
8945               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8946      &          AEAb2derx(1,lll,kkk,iii,2,1))
8947               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8948               call matvec2(auxmat(1,1),b1(1,l),
8949      &          AEAb1derx(1,lll,kkk,iii,1,2))
8950               call matvec2(auxmat(1,1),Ub2(1,l),
8951      &          AEAb2derx(1,lll,kkk,iii,1,2))
8952               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8953      &          AEAb1derx(1,lll,kkk,iii,2,2))
8954               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8955      &          AEAb2derx(1,lll,kkk,iii,2,2))
8956             enddo
8957           enddo
8958         enddo
8959         ENDIF
8960 C End vectors
8961       endif
8962       return
8963       end
8964 C---------------------------------------------------------------------------
8965       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8966      &  KK,KKderg,AKA,AKAderg,AKAderx)
8967       implicit none
8968       integer nderg
8969       logical transp
8970       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8971      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8972      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8973       integer iii,kkk,lll
8974       integer jjj,mmm
8975       logical lprn
8976       common /kutas/ lprn
8977       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8978       do iii=1,nderg
8979         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8980      &    AKAderg(1,1,iii))
8981       enddo
8982 cd      if (lprn) write (2,*) 'In kernel'
8983       do kkk=1,5
8984 cd        if (lprn) write (2,*) 'kkk=',kkk
8985         do lll=1,3
8986           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8987      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8988 cd          if (lprn) then
8989 cd            write (2,*) 'lll=',lll
8990 cd            write (2,*) 'iii=1'
8991 cd            do jjj=1,2
8992 cd              write (2,'(3(2f10.5),5x)')
8993 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8994 cd            enddo
8995 cd          endif
8996           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8997      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8998 cd          if (lprn) then
8999 cd            write (2,*) 'lll=',lll
9000 cd            write (2,*) 'iii=2'
9001 cd            do jjj=1,2
9002 cd              write (2,'(3(2f10.5),5x)')
9003 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9004 cd            enddo
9005 cd          endif
9006         enddo
9007       enddo
9008       return
9009       end
9010 C---------------------------------------------------------------------------
9011       double precision function eello4(i,j,k,l,jj,kk)
9012       implicit real*8 (a-h,o-z)
9013       include 'DIMENSIONS'
9014       include 'COMMON.IOUNITS'
9015       include 'COMMON.CHAIN'
9016       include 'COMMON.DERIV'
9017       include 'COMMON.INTERACT'
9018       include 'COMMON.CONTACTS'
9019       include 'COMMON.TORSION'
9020       include 'COMMON.VAR'
9021       include 'COMMON.GEO'
9022       double precision pizda(2,2),ggg1(3),ggg2(3)
9023 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9024 cd        eello4=0.0d0
9025 cd        return
9026 cd      endif
9027 cd      print *,'eello4:',i,j,k,l,jj,kk
9028 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9029 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9030 cold      eij=facont_hb(jj,i)
9031 cold      ekl=facont_hb(kk,k)
9032 cold      ekont=eij*ekl
9033       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9034 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9035       gcorr_loc(k-1)=gcorr_loc(k-1)
9036      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9037       if (l.eq.j+1) then
9038         gcorr_loc(l-1)=gcorr_loc(l-1)
9039      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9040       else
9041         gcorr_loc(j-1)=gcorr_loc(j-1)
9042      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9043       endif
9044       do iii=1,2
9045         do kkk=1,5
9046           do lll=1,3
9047             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9048      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9049 cd            derx(lll,kkk,iii)=0.0d0
9050           enddo
9051         enddo
9052       enddo
9053 cd      gcorr_loc(l-1)=0.0d0
9054 cd      gcorr_loc(j-1)=0.0d0
9055 cd      gcorr_loc(k-1)=0.0d0
9056 cd      eel4=1.0d0
9057 cd      write (iout,*)'Contacts have occurred for peptide groups',
9058 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9059 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9060       if (j.lt.nres-1) then
9061         j1=j+1
9062         j2=j-1
9063       else
9064         j1=j-1
9065         j2=j-2
9066       endif
9067       if (l.lt.nres-1) then
9068         l1=l+1
9069         l2=l-1
9070       else
9071         l1=l-1
9072         l2=l-2
9073       endif
9074       do ll=1,3
9075 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9076 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9077         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9078         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9079 cgrad        ghalf=0.5d0*ggg1(ll)
9080         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9081         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9082         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9083         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9084         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9085         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9086 cgrad        ghalf=0.5d0*ggg2(ll)
9087         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9088         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9089         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9090         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9091         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9092         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9093       enddo
9094 cgrad      do m=i+1,j-1
9095 cgrad        do ll=1,3
9096 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9097 cgrad        enddo
9098 cgrad      enddo
9099 cgrad      do m=k+1,l-1
9100 cgrad        do ll=1,3
9101 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9102 cgrad        enddo
9103 cgrad      enddo
9104 cgrad      do m=i+2,j2
9105 cgrad        do ll=1,3
9106 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9107 cgrad        enddo
9108 cgrad      enddo
9109 cgrad      do m=k+2,l2
9110 cgrad        do ll=1,3
9111 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9112 cgrad        enddo
9113 cgrad      enddo
9114 cd      do iii=1,nres-3
9115 cd        write (2,*) iii,gcorr_loc(iii)
9116 cd      enddo
9117       eello4=ekont*eel4
9118 cd      write (2,*) 'ekont',ekont
9119 cd      write (iout,*) 'eello4',ekont*eel4
9120       return
9121       end
9122 C---------------------------------------------------------------------------
9123       double precision function eello5(i,j,k,l,jj,kk)
9124       implicit real*8 (a-h,o-z)
9125       include 'DIMENSIONS'
9126       include 'COMMON.IOUNITS'
9127       include 'COMMON.CHAIN'
9128       include 'COMMON.DERIV'
9129       include 'COMMON.INTERACT'
9130       include 'COMMON.CONTACTS'
9131       include 'COMMON.TORSION'
9132       include 'COMMON.VAR'
9133       include 'COMMON.GEO'
9134       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9135       double precision ggg1(3),ggg2(3)
9136 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9137 C                                                                              C
9138 C                            Parallel chains                                   C
9139 C                                                                              C
9140 C          o             o                   o             o                   C
9141 C         /l\           / \             \   / \           / \   /              C
9142 C        /   \         /   \             \ /   \         /   \ /               C
9143 C       j| o |l1       | o |              o| o |         | o |o                C
9144 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9145 C      \i/   \         /   \ /             /   \         /   \                 C
9146 C       o    k1             o                                                  C
9147 C         (I)          (II)                (III)          (IV)                 C
9148 C                                                                              C
9149 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9150 C                                                                              C
9151 C                            Antiparallel chains                               C
9152 C                                                                              C
9153 C          o             o                   o             o                   C
9154 C         /j\           / \             \   / \           / \   /              C
9155 C        /   \         /   \             \ /   \         /   \ /               C
9156 C      j1| o |l        | o |              o| o |         | o |o                C
9157 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9158 C      \i/   \         /   \ /             /   \         /   \                 C
9159 C       o     k1            o                                                  C
9160 C         (I)          (II)                (III)          (IV)                 C
9161 C                                                                              C
9162 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9163 C                                                                              C
9164 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9165 C                                                                              C
9166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9167 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9168 cd        eello5=0.0d0
9169 cd        return
9170 cd      endif
9171 cd      write (iout,*)
9172 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9173 cd     &   ' and',k,l
9174       itk=itortyp(itype(k))
9175       itl=itortyp(itype(l))
9176       itj=itortyp(itype(j))
9177       eello5_1=0.0d0
9178       eello5_2=0.0d0
9179       eello5_3=0.0d0
9180       eello5_4=0.0d0
9181 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9182 cd     &   eel5_3_num,eel5_4_num)
9183       do iii=1,2
9184         do kkk=1,5
9185           do lll=1,3
9186             derx(lll,kkk,iii)=0.0d0
9187           enddo
9188         enddo
9189       enddo
9190 cd      eij=facont_hb(jj,i)
9191 cd      ekl=facont_hb(kk,k)
9192 cd      ekont=eij*ekl
9193 cd      write (iout,*)'Contacts have occurred for peptide groups',
9194 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9195 cd      goto 1111
9196 C Contribution from the graph I.
9197 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9198 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9199       call transpose2(EUg(1,1,k),auxmat(1,1))
9200       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9201       vv(1)=pizda(1,1)-pizda(2,2)
9202       vv(2)=pizda(1,2)+pizda(2,1)
9203       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9204      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9205 C Explicit gradient in virtual-dihedral angles.
9206       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9207      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9208      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9209       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9210       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9211       vv(1)=pizda(1,1)-pizda(2,2)
9212       vv(2)=pizda(1,2)+pizda(2,1)
9213       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9214      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9215      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9216       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9217       vv(1)=pizda(1,1)-pizda(2,2)
9218       vv(2)=pizda(1,2)+pizda(2,1)
9219       if (l.eq.j+1) then
9220         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9221      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9222      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9223       else
9224         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9225      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9226      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9227       endif
9228 C Cartesian gradient
9229       do iii=1,2
9230         do kkk=1,5
9231           do lll=1,3
9232             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9233      &        pizda(1,1))
9234             vv(1)=pizda(1,1)-pizda(2,2)
9235             vv(2)=pizda(1,2)+pizda(2,1)
9236             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9237      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9238      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9239           enddo
9240         enddo
9241       enddo
9242 c      goto 1112
9243 c1111  continue
9244 C Contribution from graph II
9245       call transpose2(EE(1,1,itk),auxmat(1,1))
9246       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9247       vv(1)=pizda(1,1)+pizda(2,2)
9248       vv(2)=pizda(2,1)-pizda(1,2)
9249       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9250      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9251 C Explicit gradient in virtual-dihedral angles.
9252       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9253      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9254       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9255       vv(1)=pizda(1,1)+pizda(2,2)
9256       vv(2)=pizda(2,1)-pizda(1,2)
9257       if (l.eq.j+1) then
9258         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9259      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9260      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9261       else
9262         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9263      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9264      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9265       endif
9266 C Cartesian gradient
9267       do iii=1,2
9268         do kkk=1,5
9269           do lll=1,3
9270             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9271      &        pizda(1,1))
9272             vv(1)=pizda(1,1)+pizda(2,2)
9273             vv(2)=pizda(2,1)-pizda(1,2)
9274             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9275      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9276      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9277           enddo
9278         enddo
9279       enddo
9280 cd      goto 1112
9281 cd1111  continue
9282       if (l.eq.j+1) then
9283 cd        goto 1110
9284 C Parallel orientation
9285 C Contribution from graph III
9286         call transpose2(EUg(1,1,l),auxmat(1,1))
9287         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9288         vv(1)=pizda(1,1)-pizda(2,2)
9289         vv(2)=pizda(1,2)+pizda(2,1)
9290         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9291      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9292 C Explicit gradient in virtual-dihedral angles.
9293         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9294      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9295      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9296         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9297         vv(1)=pizda(1,1)-pizda(2,2)
9298         vv(2)=pizda(1,2)+pizda(2,1)
9299         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9300      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9301      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9302         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9303         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9304         vv(1)=pizda(1,1)-pizda(2,2)
9305         vv(2)=pizda(1,2)+pizda(2,1)
9306         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9307      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9308      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9309 C Cartesian gradient
9310         do iii=1,2
9311           do kkk=1,5
9312             do lll=1,3
9313               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9314      &          pizda(1,1))
9315               vv(1)=pizda(1,1)-pizda(2,2)
9316               vv(2)=pizda(1,2)+pizda(2,1)
9317               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9318      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9319      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9320             enddo
9321           enddo
9322         enddo
9323 cd        goto 1112
9324 C Contribution from graph IV
9325 cd1110    continue
9326         call transpose2(EE(1,1,itl),auxmat(1,1))
9327         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9328         vv(1)=pizda(1,1)+pizda(2,2)
9329         vv(2)=pizda(2,1)-pizda(1,2)
9330         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9331      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9332 C Explicit gradient in virtual-dihedral angles.
9333         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9334      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9335         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9336         vv(1)=pizda(1,1)+pizda(2,2)
9337         vv(2)=pizda(2,1)-pizda(1,2)
9338         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9339      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9340      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9341 C Cartesian gradient
9342         do iii=1,2
9343           do kkk=1,5
9344             do lll=1,3
9345               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9346      &          pizda(1,1))
9347               vv(1)=pizda(1,1)+pizda(2,2)
9348               vv(2)=pizda(2,1)-pizda(1,2)
9349               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9350      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9351      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9352             enddo
9353           enddo
9354         enddo
9355       else
9356 C Antiparallel orientation
9357 C Contribution from graph III
9358 c        goto 1110
9359         call transpose2(EUg(1,1,j),auxmat(1,1))
9360         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9361         vv(1)=pizda(1,1)-pizda(2,2)
9362         vv(2)=pizda(1,2)+pizda(2,1)
9363         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9364      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9365 C Explicit gradient in virtual-dihedral angles.
9366         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9367      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9368      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9369         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9370         vv(1)=pizda(1,1)-pizda(2,2)
9371         vv(2)=pizda(1,2)+pizda(2,1)
9372         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9373      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9374      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9375         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9376         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9377         vv(1)=pizda(1,1)-pizda(2,2)
9378         vv(2)=pizda(1,2)+pizda(2,1)
9379         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9380      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9381      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9382 C Cartesian gradient
9383         do iii=1,2
9384           do kkk=1,5
9385             do lll=1,3
9386               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9387      &          pizda(1,1))
9388               vv(1)=pizda(1,1)-pizda(2,2)
9389               vv(2)=pizda(1,2)+pizda(2,1)
9390               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9391      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9392      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9393             enddo
9394           enddo
9395         enddo
9396 cd        goto 1112
9397 C Contribution from graph IV
9398 1110    continue
9399         call transpose2(EE(1,1,itj),auxmat(1,1))
9400         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9401         vv(1)=pizda(1,1)+pizda(2,2)
9402         vv(2)=pizda(2,1)-pizda(1,2)
9403         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9404      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9405 C Explicit gradient in virtual-dihedral angles.
9406         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9407      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9408         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9409         vv(1)=pizda(1,1)+pizda(2,2)
9410         vv(2)=pizda(2,1)-pizda(1,2)
9411         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9412      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9413      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9414 C Cartesian gradient
9415         do iii=1,2
9416           do kkk=1,5
9417             do lll=1,3
9418               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9419      &          pizda(1,1))
9420               vv(1)=pizda(1,1)+pizda(2,2)
9421               vv(2)=pizda(2,1)-pizda(1,2)
9422               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9423      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9424      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9425             enddo
9426           enddo
9427         enddo
9428       endif
9429 1112  continue
9430       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9431 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9432 cd        write (2,*) 'ijkl',i,j,k,l
9433 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9434 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9435 cd      endif
9436 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9437 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9438 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9439 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9440       if (j.lt.nres-1) then
9441         j1=j+1
9442         j2=j-1
9443       else
9444         j1=j-1
9445         j2=j-2
9446       endif
9447       if (l.lt.nres-1) then
9448         l1=l+1
9449         l2=l-1
9450       else
9451         l1=l-1
9452         l2=l-2
9453       endif
9454 cd      eij=1.0d0
9455 cd      ekl=1.0d0
9456 cd      ekont=1.0d0
9457 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9458 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9459 C        summed up outside the subrouine as for the other subroutines
9460 C        handling long-range interactions. The old code is commented out
9461 C        with "cgrad" to keep track of changes.
9462       do ll=1,3
9463 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9464 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9465         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9466         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9467 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9468 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9469 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9470 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9471 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9472 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9473 c     &   gradcorr5ij,
9474 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9475 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9476 cgrad        ghalf=0.5d0*ggg1(ll)
9477 cd        ghalf=0.0d0
9478         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9479         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9480         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9481         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9482         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9483         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9484 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9485 cgrad        ghalf=0.5d0*ggg2(ll)
9486 cd        ghalf=0.0d0
9487         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9488         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9489         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9490         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9491         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9492         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9493       enddo
9494 cd      goto 1112
9495 cgrad      do m=i+1,j-1
9496 cgrad        do ll=1,3
9497 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9498 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9499 cgrad        enddo
9500 cgrad      enddo
9501 cgrad      do m=k+1,l-1
9502 cgrad        do ll=1,3
9503 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9504 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9505 cgrad        enddo
9506 cgrad      enddo
9507 c1112  continue
9508 cgrad      do m=i+2,j2
9509 cgrad        do ll=1,3
9510 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9511 cgrad        enddo
9512 cgrad      enddo
9513 cgrad      do m=k+2,l2
9514 cgrad        do ll=1,3
9515 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9516 cgrad        enddo
9517 cgrad      enddo
9518 cd      do iii=1,nres-3
9519 cd        write (2,*) iii,g_corr5_loc(iii)
9520 cd      enddo
9521       eello5=ekont*eel5
9522 cd      write (2,*) 'ekont',ekont
9523 cd      write (iout,*) 'eello5',ekont*eel5
9524       return
9525       end
9526 c--------------------------------------------------------------------------
9527       double precision function eello6(i,j,k,l,jj,kk)
9528       implicit real*8 (a-h,o-z)
9529       include 'DIMENSIONS'
9530       include 'COMMON.IOUNITS'
9531       include 'COMMON.CHAIN'
9532       include 'COMMON.DERIV'
9533       include 'COMMON.INTERACT'
9534       include 'COMMON.CONTACTS'
9535       include 'COMMON.TORSION'
9536       include 'COMMON.VAR'
9537       include 'COMMON.GEO'
9538       include 'COMMON.FFIELD'
9539       double precision ggg1(3),ggg2(3)
9540 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9541 cd        eello6=0.0d0
9542 cd        return
9543 cd      endif
9544 cd      write (iout,*)
9545 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9546 cd     &   ' and',k,l
9547       eello6_1=0.0d0
9548       eello6_2=0.0d0
9549       eello6_3=0.0d0
9550       eello6_4=0.0d0
9551       eello6_5=0.0d0
9552       eello6_6=0.0d0
9553 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9554 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9555       do iii=1,2
9556         do kkk=1,5
9557           do lll=1,3
9558             derx(lll,kkk,iii)=0.0d0
9559           enddo
9560         enddo
9561       enddo
9562 cd      eij=facont_hb(jj,i)
9563 cd      ekl=facont_hb(kk,k)
9564 cd      ekont=eij*ekl
9565 cd      eij=1.0d0
9566 cd      ekl=1.0d0
9567 cd      ekont=1.0d0
9568       if (l.eq.j+1) then
9569         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9570         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9571         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9572         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9573         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9574         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9575       else
9576         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9577         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9578         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9579         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9580         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9581           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9582         else
9583           eello6_5=0.0d0
9584         endif
9585         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9586       endif
9587 C If turn contributions are considered, they will be handled separately.
9588       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9589 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9590 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9591 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9592 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9593 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9594 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9595 cd      goto 1112
9596       if (j.lt.nres-1) then
9597         j1=j+1
9598         j2=j-1
9599       else
9600         j1=j-1
9601         j2=j-2
9602       endif
9603       if (l.lt.nres-1) then
9604         l1=l+1
9605         l2=l-1
9606       else
9607         l1=l-1
9608         l2=l-2
9609       endif
9610       do ll=1,3
9611 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9612 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9613 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9614 cgrad        ghalf=0.5d0*ggg1(ll)
9615 cd        ghalf=0.0d0
9616         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9617         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9618         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9619         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9620         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9621         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9622         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9623         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9624 cgrad        ghalf=0.5d0*ggg2(ll)
9625 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9626 cd        ghalf=0.0d0
9627         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9628         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9629         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9630         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9631         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9632         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9633       enddo
9634 cd      goto 1112
9635 cgrad      do m=i+1,j-1
9636 cgrad        do ll=1,3
9637 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9638 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9639 cgrad        enddo
9640 cgrad      enddo
9641 cgrad      do m=k+1,l-1
9642 cgrad        do ll=1,3
9643 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9644 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9645 cgrad        enddo
9646 cgrad      enddo
9647 cgrad1112  continue
9648 cgrad      do m=i+2,j2
9649 cgrad        do ll=1,3
9650 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9651 cgrad        enddo
9652 cgrad      enddo
9653 cgrad      do m=k+2,l2
9654 cgrad        do ll=1,3
9655 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9656 cgrad        enddo
9657 cgrad      enddo
9658 cd      do iii=1,nres-3
9659 cd        write (2,*) iii,g_corr6_loc(iii)
9660 cd      enddo
9661       eello6=ekont*eel6
9662 cd      write (2,*) 'ekont',ekont
9663 cd      write (iout,*) 'eello6',ekont*eel6
9664       return
9665       end
9666 c--------------------------------------------------------------------------
9667       double precision function eello6_graph1(i,j,k,l,imat,swap)
9668       implicit real*8 (a-h,o-z)
9669       include 'DIMENSIONS'
9670       include 'COMMON.IOUNITS'
9671       include 'COMMON.CHAIN'
9672       include 'COMMON.DERIV'
9673       include 'COMMON.INTERACT'
9674       include 'COMMON.CONTACTS'
9675       include 'COMMON.TORSION'
9676       include 'COMMON.VAR'
9677       include 'COMMON.GEO'
9678       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9679       logical swap
9680       logical lprn
9681       common /kutas/ lprn
9682 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9683 C                                                                              C
9684 C      Parallel       Antiparallel                                             C
9685 C                                                                              C
9686 C          o             o                                                     C
9687 C         /l\           /j\                                                    C
9688 C        /   \         /   \                                                   C
9689 C       /| o |         | o |\                                                  C
9690 C     \ j|/k\|  /   \  |/k\|l /                                                C
9691 C      \ /   \ /     \ /   \ /                                                 C
9692 C       o     o       o     o                                                  C
9693 C       i             i                                                        C
9694 C                                                                              C
9695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9696       itk=itortyp(itype(k))
9697       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9698       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9699       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9700       call transpose2(EUgC(1,1,k),auxmat(1,1))
9701       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9702       vv1(1)=pizda1(1,1)-pizda1(2,2)
9703       vv1(2)=pizda1(1,2)+pizda1(2,1)
9704       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9705       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9706       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9707       s5=scalar2(vv(1),Dtobr2(1,i))
9708 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9709       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9710       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9711      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9712      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9713      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9714      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9715      & +scalar2(vv(1),Dtobr2der(1,i)))
9716       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9717       vv1(1)=pizda1(1,1)-pizda1(2,2)
9718       vv1(2)=pizda1(1,2)+pizda1(2,1)
9719       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9720       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9721       if (l.eq.j+1) then
9722         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9723      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9724      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9725      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9726      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9727       else
9728         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9729      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9730      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9731      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9732      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9733       endif
9734       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9735       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9736       vv1(1)=pizda1(1,1)-pizda1(2,2)
9737       vv1(2)=pizda1(1,2)+pizda1(2,1)
9738       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9739      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9740      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9741      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9742       do iii=1,2
9743         if (swap) then
9744           ind=3-iii
9745         else
9746           ind=iii
9747         endif
9748         do kkk=1,5
9749           do lll=1,3
9750             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9751             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9752             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9753             call transpose2(EUgC(1,1,k),auxmat(1,1))
9754             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9755      &        pizda1(1,1))
9756             vv1(1)=pizda1(1,1)-pizda1(2,2)
9757             vv1(2)=pizda1(1,2)+pizda1(2,1)
9758             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9759             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9760      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9761             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9762      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9763             s5=scalar2(vv(1),Dtobr2(1,i))
9764             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9765           enddo
9766         enddo
9767       enddo
9768       return
9769       end
9770 c----------------------------------------------------------------------------
9771       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9772       implicit real*8 (a-h,o-z)
9773       include 'DIMENSIONS'
9774       include 'COMMON.IOUNITS'
9775       include 'COMMON.CHAIN'
9776       include 'COMMON.DERIV'
9777       include 'COMMON.INTERACT'
9778       include 'COMMON.CONTACTS'
9779       include 'COMMON.TORSION'
9780       include 'COMMON.VAR'
9781       include 'COMMON.GEO'
9782       logical swap
9783       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9784      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9785       logical lprn
9786       common /kutas/ lprn
9787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9788 C                                                                              C
9789 C      Parallel       Antiparallel                                             C
9790 C                                                                              C
9791 C          o             o                                                     C
9792 C     \   /l\           /j\   /                                                C
9793 C      \ /   \         /   \ /                                                 C
9794 C       o| o |         | o |o                                                  C
9795 C     \ j|/k\|      \  |/k\|l                                                  C
9796 C      \ /   \       \ /   \                                                   C
9797 C       o             o                                                        C
9798 C       i             i                                                        C
9799 C                                                                              C
9800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9801 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9802 C AL 7/4/01 s1 would occur in the sixth-order moment,
9803 C           but not in a cluster cumulant
9804 #ifdef MOMENT
9805       s1=dip(1,jj,i)*dip(1,kk,k)
9806 #endif
9807       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9808       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9809       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9810       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9811       call transpose2(EUg(1,1,k),auxmat(1,1))
9812       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9813       vv(1)=pizda(1,1)-pizda(2,2)
9814       vv(2)=pizda(1,2)+pizda(2,1)
9815       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9816 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9817 #ifdef MOMENT
9818       eello6_graph2=-(s1+s2+s3+s4)
9819 #else
9820       eello6_graph2=-(s2+s3+s4)
9821 #endif
9822 c      eello6_graph2=-s3
9823 C Derivatives in gamma(i-1)
9824       if (i.gt.1) then
9825 #ifdef MOMENT
9826         s1=dipderg(1,jj,i)*dip(1,kk,k)
9827 #endif
9828         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9829         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9830         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9831         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9832 #ifdef MOMENT
9833         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9834 #else
9835         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9836 #endif
9837 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9838       endif
9839 C Derivatives in gamma(k-1)
9840 #ifdef MOMENT
9841       s1=dip(1,jj,i)*dipderg(1,kk,k)
9842 #endif
9843       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9844       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9845       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9846       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9847       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9848       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9849       vv(1)=pizda(1,1)-pizda(2,2)
9850       vv(2)=pizda(1,2)+pizda(2,1)
9851       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9852 #ifdef MOMENT
9853       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9854 #else
9855       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9856 #endif
9857 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9858 C Derivatives in gamma(j-1) or gamma(l-1)
9859       if (j.gt.1) then
9860 #ifdef MOMENT
9861         s1=dipderg(3,jj,i)*dip(1,kk,k)
9862 #endif
9863         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9864         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9865         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9866         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9867         vv(1)=pizda(1,1)-pizda(2,2)
9868         vv(2)=pizda(1,2)+pizda(2,1)
9869         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9870 #ifdef MOMENT
9871         if (swap) then
9872           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9873         else
9874           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9875         endif
9876 #endif
9877         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9878 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9879       endif
9880 C Derivatives in gamma(l-1) or gamma(j-1)
9881       if (l.gt.1) then
9882 #ifdef MOMENT
9883         s1=dip(1,jj,i)*dipderg(3,kk,k)
9884 #endif
9885         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9886         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9887         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9888         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9889         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9890         vv(1)=pizda(1,1)-pizda(2,2)
9891         vv(2)=pizda(1,2)+pizda(2,1)
9892         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9893 #ifdef MOMENT
9894         if (swap) then
9895           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9896         else
9897           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9898         endif
9899 #endif
9900         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9901 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9902       endif
9903 C Cartesian derivatives.
9904       if (lprn) then
9905         write (2,*) 'In eello6_graph2'
9906         do iii=1,2
9907           write (2,*) 'iii=',iii
9908           do kkk=1,5
9909             write (2,*) 'kkk=',kkk
9910             do jjj=1,2
9911               write (2,'(3(2f10.5),5x)')
9912      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9913             enddo
9914           enddo
9915         enddo
9916       endif
9917       do iii=1,2
9918         do kkk=1,5
9919           do lll=1,3
9920 #ifdef MOMENT
9921             if (iii.eq.1) then
9922               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9923             else
9924               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9925             endif
9926 #endif
9927             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9928      &        auxvec(1))
9929             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9930             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9931      &        auxvec(1))
9932             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9933             call transpose2(EUg(1,1,k),auxmat(1,1))
9934             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9935      &        pizda(1,1))
9936             vv(1)=pizda(1,1)-pizda(2,2)
9937             vv(2)=pizda(1,2)+pizda(2,1)
9938             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9939 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9940 #ifdef MOMENT
9941             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9942 #else
9943             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9944 #endif
9945             if (swap) then
9946               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9947             else
9948               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9949             endif
9950           enddo
9951         enddo
9952       enddo
9953       return
9954       end
9955 c----------------------------------------------------------------------------
9956       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9957       implicit real*8 (a-h,o-z)
9958       include 'DIMENSIONS'
9959       include 'COMMON.IOUNITS'
9960       include 'COMMON.CHAIN'
9961       include 'COMMON.DERIV'
9962       include 'COMMON.INTERACT'
9963       include 'COMMON.CONTACTS'
9964       include 'COMMON.TORSION'
9965       include 'COMMON.VAR'
9966       include 'COMMON.GEO'
9967       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9968       logical swap
9969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9970 C                                                                              C
9971 C      Parallel       Antiparallel                                             C
9972 C                                                                              C
9973 C          o             o                                                     C
9974 C         /l\   /   \   /j\                                                    C
9975 C        /   \ /     \ /   \                                                   C
9976 C       /| o |o       o| o |\                                                  C
9977 C       j|/k\|  /      |/k\|l /                                                C
9978 C        /   \ /       /   \ /                                                 C
9979 C       /     o       /     o                                                  C
9980 C       i             i                                                        C
9981 C                                                                              C
9982 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9983 C
9984 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9985 C           energy moment and not to the cluster cumulant.
9986       iti=itortyp(itype(i))
9987       if (j.lt.nres-1) then
9988         itj1=itortyp(itype(j+1))
9989       else
9990         itj1=ntortyp
9991       endif
9992       itk=itortyp(itype(k))
9993       itk1=itortyp(itype(k+1))
9994       if (l.lt.nres-1) then
9995         itl1=itortyp(itype(l+1))
9996       else
9997         itl1=ntortyp
9998       endif
9999 #ifdef MOMENT
10000       s1=dip(4,jj,i)*dip(4,kk,k)
10001 #endif
10002       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10003       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10004       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10005       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10006       call transpose2(EE(1,1,itk),auxmat(1,1))
10007       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10008       vv(1)=pizda(1,1)+pizda(2,2)
10009       vv(2)=pizda(2,1)-pizda(1,2)
10010       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10011 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10012 cd     & "sum",-(s2+s3+s4)
10013 #ifdef MOMENT
10014       eello6_graph3=-(s1+s2+s3+s4)
10015 #else
10016       eello6_graph3=-(s2+s3+s4)
10017 #endif
10018 c      eello6_graph3=-s4
10019 C Derivatives in gamma(k-1)
10020       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10021       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10022       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10023       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10024 C Derivatives in gamma(l-1)
10025       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10026       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10027       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10028       vv(1)=pizda(1,1)+pizda(2,2)
10029       vv(2)=pizda(2,1)-pizda(1,2)
10030       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10031       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10032 C Cartesian derivatives.
10033       do iii=1,2
10034         do kkk=1,5
10035           do lll=1,3
10036 #ifdef MOMENT
10037             if (iii.eq.1) then
10038               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10039             else
10040               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10041             endif
10042 #endif
10043             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10044      &        auxvec(1))
10045             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10046             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10047      &        auxvec(1))
10048             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10049             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10050      &        pizda(1,1))
10051             vv(1)=pizda(1,1)+pizda(2,2)
10052             vv(2)=pizda(2,1)-pizda(1,2)
10053             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10054 #ifdef MOMENT
10055             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10056 #else
10057             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10058 #endif
10059             if (swap) then
10060               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10061             else
10062               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10063             endif
10064 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10065           enddo
10066         enddo
10067       enddo
10068       return
10069       end
10070 c----------------------------------------------------------------------------
10071       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10072       implicit real*8 (a-h,o-z)
10073       include 'DIMENSIONS'
10074       include 'COMMON.IOUNITS'
10075       include 'COMMON.CHAIN'
10076       include 'COMMON.DERIV'
10077       include 'COMMON.INTERACT'
10078       include 'COMMON.CONTACTS'
10079       include 'COMMON.TORSION'
10080       include 'COMMON.VAR'
10081       include 'COMMON.GEO'
10082       include 'COMMON.FFIELD'
10083       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10084      & auxvec1(2),auxmat1(2,2)
10085       logical swap
10086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10087 C                                                                              C
10088 C      Parallel       Antiparallel                                             C
10089 C                                                                              C
10090 C          o             o                                                     C
10091 C         /l\   /   \   /j\                                                    C
10092 C        /   \ /     \ /   \                                                   C
10093 C       /| o |o       o| o |\                                                  C
10094 C     \ j|/k\|      \  |/k\|l                                                  C
10095 C      \ /   \       \ /   \                                                   C
10096 C       o     \       o     \                                                  C
10097 C       i             i                                                        C
10098 C                                                                              C
10099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10100 C
10101 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10102 C           energy moment and not to the cluster cumulant.
10103 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10104       iti=itortyp(itype(i))
10105       itj=itortyp(itype(j))
10106       if (j.lt.nres-1) then
10107         itj1=itortyp(itype(j+1))
10108       else
10109         itj1=ntortyp
10110       endif
10111       itk=itortyp(itype(k))
10112       if (k.lt.nres-1) then
10113         itk1=itortyp(itype(k+1))
10114       else
10115         itk1=ntortyp
10116       endif
10117       itl=itortyp(itype(l))
10118       if (l.lt.nres-1) then
10119         itl1=itortyp(itype(l+1))
10120       else
10121         itl1=ntortyp
10122       endif
10123 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10124 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10125 cd     & ' itl',itl,' itl1',itl1
10126 #ifdef MOMENT
10127       if (imat.eq.1) then
10128         s1=dip(3,jj,i)*dip(3,kk,k)
10129       else
10130         s1=dip(2,jj,j)*dip(2,kk,l)
10131       endif
10132 #endif
10133       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10134       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10135       if (j.eq.l+1) then
10136         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10137         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10138       else
10139         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10140         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10141       endif
10142       call transpose2(EUg(1,1,k),auxmat(1,1))
10143       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10144       vv(1)=pizda(1,1)-pizda(2,2)
10145       vv(2)=pizda(2,1)+pizda(1,2)
10146       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10147 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10148 #ifdef MOMENT
10149       eello6_graph4=-(s1+s2+s3+s4)
10150 #else
10151       eello6_graph4=-(s2+s3+s4)
10152 #endif
10153 C Derivatives in gamma(i-1)
10154       if (i.gt.1) then
10155 #ifdef MOMENT
10156         if (imat.eq.1) then
10157           s1=dipderg(2,jj,i)*dip(3,kk,k)
10158         else
10159           s1=dipderg(4,jj,j)*dip(2,kk,l)
10160         endif
10161 #endif
10162         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10163         if (j.eq.l+1) then
10164           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10165           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10166         else
10167           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10168           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10169         endif
10170         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10171         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10172 cd          write (2,*) 'turn6 derivatives'
10173 #ifdef MOMENT
10174           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10175 #else
10176           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10177 #endif
10178         else
10179 #ifdef MOMENT
10180           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10181 #else
10182           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10183 #endif
10184         endif
10185       endif
10186 C Derivatives in gamma(k-1)
10187 #ifdef MOMENT
10188       if (imat.eq.1) then
10189         s1=dip(3,jj,i)*dipderg(2,kk,k)
10190       else
10191         s1=dip(2,jj,j)*dipderg(4,kk,l)
10192       endif
10193 #endif
10194       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10195       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10196       if (j.eq.l+1) then
10197         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10198         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10199       else
10200         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10201         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10202       endif
10203       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10204       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10205       vv(1)=pizda(1,1)-pizda(2,2)
10206       vv(2)=pizda(2,1)+pizda(1,2)
10207       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10208       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10209 #ifdef MOMENT
10210         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10211 #else
10212         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10213 #endif
10214       else
10215 #ifdef MOMENT
10216         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10217 #else
10218         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10219 #endif
10220       endif
10221 C Derivatives in gamma(j-1) or gamma(l-1)
10222       if (l.eq.j+1 .and. l.gt.1) then
10223         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10224         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10225         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10226         vv(1)=pizda(1,1)-pizda(2,2)
10227         vv(2)=pizda(2,1)+pizda(1,2)
10228         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10229         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10230       else if (j.gt.1) then
10231         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10232         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10233         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10234         vv(1)=pizda(1,1)-pizda(2,2)
10235         vv(2)=pizda(2,1)+pizda(1,2)
10236         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10237         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10238           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10239         else
10240           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10241         endif
10242       endif
10243 C Cartesian derivatives.
10244       do iii=1,2
10245         do kkk=1,5
10246           do lll=1,3
10247 #ifdef MOMENT
10248             if (iii.eq.1) then
10249               if (imat.eq.1) then
10250                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10251               else
10252                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10253               endif
10254             else
10255               if (imat.eq.1) then
10256                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10257               else
10258                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10259               endif
10260             endif
10261 #endif
10262             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10263      &        auxvec(1))
10264             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10265             if (j.eq.l+1) then
10266               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10267      &          b1(1,j+1),auxvec(1))
10268               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10269             else
10270               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10271      &          b1(1,l+1),auxvec(1))
10272               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10273             endif
10274             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10275      &        pizda(1,1))
10276             vv(1)=pizda(1,1)-pizda(2,2)
10277             vv(2)=pizda(2,1)+pizda(1,2)
10278             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10279             if (swap) then
10280               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10281 #ifdef MOMENT
10282                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10283      &             -(s1+s2+s4)
10284 #else
10285                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10286      &             -(s2+s4)
10287 #endif
10288                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10289               else
10290 #ifdef MOMENT
10291                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10292 #else
10293                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10294 #endif
10295                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10296               endif
10297             else
10298 #ifdef MOMENT
10299               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10300 #else
10301               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10302 #endif
10303               if (l.eq.j+1) then
10304                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10305               else
10306                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10307               endif
10308             endif
10309           enddo
10310         enddo
10311       enddo
10312       return
10313       end
10314 c----------------------------------------------------------------------------
10315       double precision function eello_turn6(i,jj,kk)
10316       implicit real*8 (a-h,o-z)
10317       include 'DIMENSIONS'
10318       include 'COMMON.IOUNITS'
10319       include 'COMMON.CHAIN'
10320       include 'COMMON.DERIV'
10321       include 'COMMON.INTERACT'
10322       include 'COMMON.CONTACTS'
10323       include 'COMMON.TORSION'
10324       include 'COMMON.VAR'
10325       include 'COMMON.GEO'
10326       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10327      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10328      &  ggg1(3),ggg2(3)
10329       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10330      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10331 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10332 C           the respective energy moment and not to the cluster cumulant.
10333       s1=0.0d0
10334       s8=0.0d0
10335       s13=0.0d0
10336 c
10337       eello_turn6=0.0d0
10338       j=i+4
10339       k=i+1
10340       l=i+3
10341       iti=itortyp(itype(i))
10342       itk=itortyp(itype(k))
10343       itk1=itortyp(itype(k+1))
10344       itl=itortyp(itype(l))
10345       itj=itortyp(itype(j))
10346 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10347 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10348 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10349 cd        eello6=0.0d0
10350 cd        return
10351 cd      endif
10352 cd      write (iout,*)
10353 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10354 cd     &   ' and',k,l
10355 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10356       do iii=1,2
10357         do kkk=1,5
10358           do lll=1,3
10359             derx_turn(lll,kkk,iii)=0.0d0
10360           enddo
10361         enddo
10362       enddo
10363 cd      eij=1.0d0
10364 cd      ekl=1.0d0
10365 cd      ekont=1.0d0
10366       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10367 cd      eello6_5=0.0d0
10368 cd      write (2,*) 'eello6_5',eello6_5
10369 #ifdef MOMENT
10370       call transpose2(AEA(1,1,1),auxmat(1,1))
10371       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10372       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10373       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10374 #endif
10375       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10376       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10377       s2 = scalar2(b1(1,k),vtemp1(1))
10378 #ifdef MOMENT
10379       call transpose2(AEA(1,1,2),atemp(1,1))
10380       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10381       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10382       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10383 #endif
10384       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10385       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10386       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10387 #ifdef MOMENT
10388       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10389       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10390       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10391       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10392       ss13 = scalar2(b1(1,k),vtemp4(1))
10393       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10394 #endif
10395 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10396 c      s1=0.0d0
10397 c      s2=0.0d0
10398 c      s8=0.0d0
10399 c      s12=0.0d0
10400 c      s13=0.0d0
10401       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10402 C Derivatives in gamma(i+2)
10403       s1d =0.0d0
10404       s8d =0.0d0
10405 #ifdef MOMENT
10406       call transpose2(AEA(1,1,1),auxmatd(1,1))
10407       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10408       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10409       call transpose2(AEAderg(1,1,2),atempd(1,1))
10410       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10411       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10412 #endif
10413       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10414       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10415       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10416 c      s1d=0.0d0
10417 c      s2d=0.0d0
10418 c      s8d=0.0d0
10419 c      s12d=0.0d0
10420 c      s13d=0.0d0
10421       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10422 C Derivatives in gamma(i+3)
10423 #ifdef MOMENT
10424       call transpose2(AEA(1,1,1),auxmatd(1,1))
10425       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10426       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10427       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10428 #endif
10429       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10430       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10431       s2d = scalar2(b1(1,k),vtemp1d(1))
10432 #ifdef MOMENT
10433       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10434       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10435 #endif
10436       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10437 #ifdef MOMENT
10438       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10439       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10440       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10441 #endif
10442 c      s1d=0.0d0
10443 c      s2d=0.0d0
10444 c      s8d=0.0d0
10445 c      s12d=0.0d0
10446 c      s13d=0.0d0
10447 #ifdef MOMENT
10448       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10449      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10450 #else
10451       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10452      &               -0.5d0*ekont*(s2d+s12d)
10453 #endif
10454 C Derivatives in gamma(i+4)
10455       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10456       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10457       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10458 #ifdef MOMENT
10459       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10460       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10461       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10462 #endif
10463 c      s1d=0.0d0
10464 c      s2d=0.0d0
10465 c      s8d=0.0d0
10466 C      s12d=0.0d0
10467 c      s13d=0.0d0
10468 #ifdef MOMENT
10469       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10470 #else
10471       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10472 #endif
10473 C Derivatives in gamma(i+5)
10474 #ifdef MOMENT
10475       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10476       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10477       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10478 #endif
10479       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10480       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10481       s2d = scalar2(b1(1,k),vtemp1d(1))
10482 #ifdef MOMENT
10483       call transpose2(AEA(1,1,2),atempd(1,1))
10484       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10485       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10486 #endif
10487       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10488       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10489 #ifdef MOMENT
10490       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10491       ss13d = scalar2(b1(1,k),vtemp4d(1))
10492       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10493 #endif
10494 c      s1d=0.0d0
10495 c      s2d=0.0d0
10496 c      s8d=0.0d0
10497 c      s12d=0.0d0
10498 c      s13d=0.0d0
10499 #ifdef MOMENT
10500       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10501      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10502 #else
10503       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10504      &               -0.5d0*ekont*(s2d+s12d)
10505 #endif
10506 C Cartesian derivatives
10507       do iii=1,2
10508         do kkk=1,5
10509           do lll=1,3
10510 #ifdef MOMENT
10511             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10512             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10513             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10514 #endif
10515             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10516             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10517      &          vtemp1d(1))
10518             s2d = scalar2(b1(1,k),vtemp1d(1))
10519 #ifdef MOMENT
10520             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10521             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10522             s8d = -(atempd(1,1)+atempd(2,2))*
10523      &           scalar2(cc(1,1,itl),vtemp2(1))
10524 #endif
10525             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10526      &           auxmatd(1,1))
10527             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10528             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10529 c      s1d=0.0d0
10530 c      s2d=0.0d0
10531 c      s8d=0.0d0
10532 c      s12d=0.0d0
10533 c      s13d=0.0d0
10534 #ifdef MOMENT
10535             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10536      &        - 0.5d0*(s1d+s2d)
10537 #else
10538             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10539      &        - 0.5d0*s2d
10540 #endif
10541 #ifdef MOMENT
10542             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10543      &        - 0.5d0*(s8d+s12d)
10544 #else
10545             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10546      &        - 0.5d0*s12d
10547 #endif
10548           enddo
10549         enddo
10550       enddo
10551 #ifdef MOMENT
10552       do kkk=1,5
10553         do lll=1,3
10554           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10555      &      achuj_tempd(1,1))
10556           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10557           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10558           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10559           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10560           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10561      &      vtemp4d(1))
10562           ss13d = scalar2(b1(1,k),vtemp4d(1))
10563           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10564           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10565         enddo
10566       enddo
10567 #endif
10568 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10569 cd     &  16*eel_turn6_num
10570 cd      goto 1112
10571       if (j.lt.nres-1) then
10572         j1=j+1
10573         j2=j-1
10574       else
10575         j1=j-1
10576         j2=j-2
10577       endif
10578       if (l.lt.nres-1) then
10579         l1=l+1
10580         l2=l-1
10581       else
10582         l1=l-1
10583         l2=l-2
10584       endif
10585       do ll=1,3
10586 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10587 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10588 cgrad        ghalf=0.5d0*ggg1(ll)
10589 cd        ghalf=0.0d0
10590         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10591         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10592         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10593      &    +ekont*derx_turn(ll,2,1)
10594         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10595         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10596      &    +ekont*derx_turn(ll,4,1)
10597         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10598         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10599         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10600 cgrad        ghalf=0.5d0*ggg2(ll)
10601 cd        ghalf=0.0d0
10602         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10603      &    +ekont*derx_turn(ll,2,2)
10604         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10605         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10606      &    +ekont*derx_turn(ll,4,2)
10607         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10608         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10609         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10610       enddo
10611 cd      goto 1112
10612 cgrad      do m=i+1,j-1
10613 cgrad        do ll=1,3
10614 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10615 cgrad        enddo
10616 cgrad      enddo
10617 cgrad      do m=k+1,l-1
10618 cgrad        do ll=1,3
10619 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10620 cgrad        enddo
10621 cgrad      enddo
10622 cgrad1112  continue
10623 cgrad      do m=i+2,j2
10624 cgrad        do ll=1,3
10625 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10626 cgrad        enddo
10627 cgrad      enddo
10628 cgrad      do m=k+2,l2
10629 cgrad        do ll=1,3
10630 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10631 cgrad        enddo
10632 cgrad      enddo
10633 cd      do iii=1,nres-3
10634 cd        write (2,*) iii,g_corr6_loc(iii)
10635 cd      enddo
10636       eello_turn6=ekont*eel_turn6
10637 cd      write (2,*) 'ekont',ekont
10638 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10639       return
10640       end
10641
10642 C-----------------------------------------------------------------------------
10643       double precision function scalar(u,v)
10644 !DIR$ INLINEALWAYS scalar
10645 #ifndef OSF
10646 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10647 #endif
10648       implicit none
10649       double precision u(3),v(3)
10650 cd      double precision sc
10651 cd      integer i
10652 cd      sc=0.0d0
10653 cd      do i=1,3
10654 cd        sc=sc+u(i)*v(i)
10655 cd      enddo
10656 cd      scalar=sc
10657
10658       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10659       return
10660       end
10661 crc-------------------------------------------------
10662       SUBROUTINE MATVEC2(A1,V1,V2)
10663 !DIR$ INLINEALWAYS MATVEC2
10664 #ifndef OSF
10665 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10666 #endif
10667       implicit real*8 (a-h,o-z)
10668       include 'DIMENSIONS'
10669       DIMENSION A1(2,2),V1(2),V2(2)
10670 c      DO 1 I=1,2
10671 c        VI=0.0
10672 c        DO 3 K=1,2
10673 c    3     VI=VI+A1(I,K)*V1(K)
10674 c        Vaux(I)=VI
10675 c    1 CONTINUE
10676
10677       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10678       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10679
10680       v2(1)=vaux1
10681       v2(2)=vaux2
10682       END
10683 C---------------------------------------
10684       SUBROUTINE MATMAT2(A1,A2,A3)
10685 #ifndef OSF
10686 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10687 #endif
10688       implicit real*8 (a-h,o-z)
10689       include 'DIMENSIONS'
10690       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10691 c      DIMENSION AI3(2,2)
10692 c        DO  J=1,2
10693 c          A3IJ=0.0
10694 c          DO K=1,2
10695 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10696 c          enddo
10697 c          A3(I,J)=A3IJ
10698 c       enddo
10699 c      enddo
10700
10701       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10702       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10703       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10704       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10705
10706       A3(1,1)=AI3_11
10707       A3(2,1)=AI3_21
10708       A3(1,2)=AI3_12
10709       A3(2,2)=AI3_22
10710       END
10711
10712 c-------------------------------------------------------------------------
10713       double precision function scalar2(u,v)
10714 !DIR$ INLINEALWAYS scalar2
10715       implicit none
10716       double precision u(2),v(2)
10717       double precision sc
10718       integer i
10719       scalar2=u(1)*v(1)+u(2)*v(2)
10720       return
10721       end
10722
10723 C-----------------------------------------------------------------------------
10724
10725       subroutine transpose2(a,at)
10726 !DIR$ INLINEALWAYS transpose2
10727 #ifndef OSF
10728 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10729 #endif
10730       implicit none
10731       double precision a(2,2),at(2,2)
10732       at(1,1)=a(1,1)
10733       at(1,2)=a(2,1)
10734       at(2,1)=a(1,2)
10735       at(2,2)=a(2,2)
10736       return
10737       end
10738 c--------------------------------------------------------------------------
10739       subroutine transpose(n,a,at)
10740       implicit none
10741       integer n,i,j
10742       double precision a(n,n),at(n,n)
10743       do i=1,n
10744         do j=1,n
10745           at(j,i)=a(i,j)
10746         enddo
10747       enddo
10748       return
10749       end
10750 C---------------------------------------------------------------------------
10751       subroutine prodmat3(a1,a2,kk,transp,prod)
10752 !DIR$ INLINEALWAYS prodmat3
10753 #ifndef OSF
10754 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10755 #endif
10756       implicit none
10757       integer i,j
10758       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10759       logical transp
10760 crc      double precision auxmat(2,2),prod_(2,2)
10761
10762       if (transp) then
10763 crc        call transpose2(kk(1,1),auxmat(1,1))
10764 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10765 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10766
10767            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10768      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10769            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10770      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10771            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10772      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10773            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10774      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10775
10776       else
10777 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10778 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10779
10780            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10781      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10782            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10783      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10784            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10785      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10786            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10787      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10788
10789       endif
10790 c      call transpose2(a2(1,1),a2t(1,1))
10791
10792 crc      print *,transp
10793 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10794 crc      print *,((prod(i,j),i=1,2),j=1,2)
10795
10796       return
10797       end
10798 CCC----------------------------------------------
10799       subroutine Eliptransfer(eliptran)
10800       implicit real*8 (a-h,o-z)
10801       include 'DIMENSIONS'
10802       include 'COMMON.GEO'
10803       include 'COMMON.VAR'
10804       include 'COMMON.LOCAL'
10805       include 'COMMON.CHAIN'
10806       include 'COMMON.DERIV'
10807       include 'COMMON.NAMES'
10808       include 'COMMON.INTERACT'
10809       include 'COMMON.IOUNITS'
10810       include 'COMMON.CALC'
10811       include 'COMMON.CONTROL'
10812       include 'COMMON.SPLITELE'
10813       include 'COMMON.SBRIDGE'
10814 C this is done by Adasko
10815 C      print *,"wchodze"
10816 C structure of box:
10817 C      water
10818 C--bordliptop-- buffore starts
10819 C--bufliptop--- here true lipid starts
10820 C      lipid
10821 C--buflipbot--- lipid ends buffore starts
10822 C--bordlipbot--buffore ends
10823       eliptran=0.0
10824       do i=ilip_start,ilip_end
10825 C       do i=1,1
10826         if (itype(i).eq.ntyp1) cycle
10827
10828         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10829         if (positi.le.0) positi=positi+boxzsize
10830 C        print *,i
10831 C first for peptide groups
10832 c for each residue check if it is in lipid or lipid water border area
10833        if ((positi.gt.bordlipbot)
10834      &.and.(positi.lt.bordliptop)) then
10835 C the energy transfer exist
10836         if (positi.lt.buflipbot) then
10837 C what fraction I am in
10838          fracinbuf=1.0d0-
10839      &        ((positi-bordlipbot)/lipbufthick)
10840 C lipbufthick is thickenes of lipid buffore
10841          sslip=sscalelip(fracinbuf)
10842          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10843          eliptran=eliptran+sslip*pepliptran
10844          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10845          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10846 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10847
10848 C        print *,"doing sccale for lower part"
10849 C         print *,i,sslip,fracinbuf,ssgradlip
10850         elseif (positi.gt.bufliptop) then
10851          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10852          sslip=sscalelip(fracinbuf)
10853          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10854          eliptran=eliptran+sslip*pepliptran
10855          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10856          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10857 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10858 C          print *, "doing sscalefor top part"
10859 C         print *,i,sslip,fracinbuf,ssgradlip
10860         else
10861          eliptran=eliptran+pepliptran
10862 C         print *,"I am in true lipid"
10863         endif
10864 C       else
10865 C       eliptran=elpitran+0.0 ! I am in water
10866        endif
10867        enddo
10868 C       print *, "nic nie bylo w lipidzie?"
10869 C now multiply all by the peptide group transfer factor
10870 C       eliptran=eliptran*pepliptran
10871 C now the same for side chains
10872 CV       do i=1,1
10873        do i=ilip_start,ilip_end
10874         if (itype(i).eq.ntyp1) cycle
10875         positi=(mod(c(3,i+nres),boxzsize))
10876         if (positi.le.0) positi=positi+boxzsize
10877 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10878 c for each residue check if it is in lipid or lipid water border area
10879 C       respos=mod(c(3,i+nres),boxzsize)
10880 C       print *,positi,bordlipbot,buflipbot
10881        if ((positi.gt.bordlipbot)
10882      & .and.(positi.lt.bordliptop)) then
10883 C the energy transfer exist
10884         if (positi.lt.buflipbot) then
10885          fracinbuf=1.0d0-
10886      &     ((positi-bordlipbot)/lipbufthick)
10887 C lipbufthick is thickenes of lipid buffore
10888          sslip=sscalelip(fracinbuf)
10889          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10890          eliptran=eliptran+sslip*liptranene(itype(i))
10891          gliptranx(3,i)=gliptranx(3,i)
10892      &+ssgradlip*liptranene(itype(i))
10893          gliptranc(3,i-1)= gliptranc(3,i-1)
10894      &+ssgradlip*liptranene(itype(i))
10895 C         print *,"doing sccale for lower part"
10896         elseif (positi.gt.bufliptop) then
10897          fracinbuf=1.0d0-
10898      &((bordliptop-positi)/lipbufthick)
10899          sslip=sscalelip(fracinbuf)
10900          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10901          eliptran=eliptran+sslip*liptranene(itype(i))
10902          gliptranx(3,i)=gliptranx(3,i)
10903      &+ssgradlip*liptranene(itype(i))
10904          gliptranc(3,i-1)= gliptranc(3,i-1)
10905      &+ssgradlip*liptranene(itype(i))
10906 C          print *, "doing sscalefor top part",sslip,fracinbuf
10907         else
10908          eliptran=eliptran+liptranene(itype(i))
10909 C         print *,"I am in true lipid"
10910         endif
10911         endif ! if in lipid or buffor
10912 C       else
10913 C       eliptran=elpitran+0.0 ! I am in water
10914        enddo
10915        return
10916        end
10917 C---------------------------------------------------------
10918 C AFM soubroutine for constant force
10919        subroutine AFMforce(Eafmforce)
10920        implicit real*8 (a-h,o-z)
10921       include 'DIMENSIONS'
10922       include 'COMMON.GEO'
10923       include 'COMMON.VAR'
10924       include 'COMMON.LOCAL'
10925       include 'COMMON.CHAIN'
10926       include 'COMMON.DERIV'
10927       include 'COMMON.NAMES'
10928       include 'COMMON.INTERACT'
10929       include 'COMMON.IOUNITS'
10930       include 'COMMON.CALC'
10931       include 'COMMON.CONTROL'
10932       include 'COMMON.SPLITELE'
10933       include 'COMMON.SBRIDGE'
10934       real*8 diffafm(3)
10935       dist=0.0d0
10936       Eafmforce=0.0d0
10937       do i=1,3
10938       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10939       dist=dist+diffafm(i)**2
10940       enddo
10941       dist=dsqrt(dist)
10942       Eafmforce=-forceAFMconst*(dist-distafminit)
10943       do i=1,3
10944       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10945       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10946       enddo
10947 C      print *,'AFM',Eafmforce
10948       return
10949       end
10950 C---------------------------------------------------------
10951 C AFM subroutine with pseudoconstant velocity
10952        subroutine AFMvel(Eafmforce)
10953        implicit real*8 (a-h,o-z)
10954       include 'DIMENSIONS'
10955       include 'COMMON.GEO'
10956       include 'COMMON.VAR'
10957       include 'COMMON.LOCAL'
10958       include 'COMMON.CHAIN'
10959       include 'COMMON.DERIV'
10960       include 'COMMON.NAMES'
10961       include 'COMMON.INTERACT'
10962       include 'COMMON.IOUNITS'
10963       include 'COMMON.CALC'
10964       include 'COMMON.CONTROL'
10965       include 'COMMON.SPLITELE'
10966       include 'COMMON.SBRIDGE'
10967       real*8 diffafm(3)
10968 C Only for check grad COMMENT if not used for checkgrad
10969 C      totT=3.0d0
10970 C--------------------------------------------------------
10971 C      print *,"wchodze"
10972       dist=0.0d0
10973       Eafmforce=0.0d0
10974       do i=1,3
10975       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10976       dist=dist+diffafm(i)**2
10977       enddo
10978       dist=dsqrt(dist)
10979       Eafmforce=0.5d0*forceAFMconst
10980      & *(distafminit+totTafm*velAFMconst-dist)**2
10981 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10982       do i=1,3
10983       gradafm(i,afmend-1)=-forceAFMconst*
10984      &(distafminit+totTafm*velAFMconst-dist)
10985      &*diffafm(i)/dist
10986       gradafm(i,afmbeg-1)=forceAFMconst*
10987      &(distafminit+totTafm*velAFMconst-dist)
10988      &*diffafm(i)/dist
10989       enddo
10990 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10991       return
10992       end
10993