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 c         min_odl=minval(distancek)
6900          do kk=1,constr_homology
6901           if(l_homo(kk,ii)) then
6902             min_odl=distancek(kk)
6903             exit
6904           endif
6905          enddo
6906          do kk=1,constr_homology
6907           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6908      &              min_odl=distancek(kk)
6909          enddo
6910
6911 c        write (iout,* )"min_odl",min_odl
6912 #ifdef DEBUG
6913          write (iout,*) "ij dij",i,j,dij
6914          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6915          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6916          write (iout,* )"min_odl",min_odl
6917 #endif
6918          odleg2=0.0d0
6919          do k=1,constr_homology
6920 c Nie wiem po co to liczycie jeszcze raz!
6921 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6922 c     &              (2*(sigma_odl(i,j,k))**2))
6923            if(.not.l_homo(k,ii)) cycle
6924            if (waga_dist.ge.0.0d0) then
6925 c
6926 c          For Gaussian-type Urestr
6927 c
6928             godl(k)=dexp(-distancek(k)+min_odl)
6929             odleg2=odleg2+godl(k)
6930 c
6931 c          For Lorentzian-type Urestr
6932 c
6933            else
6934             odleg2=odleg2+distancek(k)
6935            endif
6936
6937 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6938 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6939 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6940 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6941
6942          enddo
6943 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6944 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6945 #ifdef DEBUG
6946          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6947          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6948 #endif
6949            if (waga_dist.ge.0.0d0) then
6950 c
6951 c          For Gaussian-type Urestr
6952 c
6953               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6954 c
6955 c          For Lorentzian-type Urestr
6956 c
6957            else
6958               odleg=odleg+odleg2/constr_homology
6959            endif
6960 c
6961 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6962 c Gradient
6963 c
6964 c          For Gaussian-type Urestr
6965 c
6966          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6967          sum_sgodl=0.0d0
6968          do k=1,constr_homology
6969 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6970 c     &           *waga_dist)+min_odl
6971 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6972 c
6973          if(.not.l_homo(k,ii)) cycle
6974          if (waga_dist.ge.0.0d0) then
6975 c          For Gaussian-type Urestr
6976 c
6977            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6978 c
6979 c          For Lorentzian-type Urestr
6980 c
6981          else
6982            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6983      &           sigma_odlir(k,ii)**2)**2)
6984          endif
6985            sum_sgodl=sum_sgodl+sgodl
6986
6987 c            sgodl2=sgodl2+sgodl
6988 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6989 c      write(iout,*) "constr_homology=",constr_homology
6990 c      write(iout,*) i, j, k, "TEST K"
6991          enddo
6992          if (waga_dist.ge.0.0d0) then
6993 c
6994 c          For Gaussian-type Urestr
6995 c
6996             grad_odl3=waga_homology(iset)*waga_dist
6997      &                *sum_sgodl/(sum_godl*dij)
6998 c
6999 c          For Lorentzian-type Urestr
7000 c
7001          else
7002 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7003 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7004             grad_odl3=-waga_homology(iset)*waga_dist*
7005      &                sum_sgodl/(constr_homology*dij)
7006          endif
7007 c
7008 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7009
7010
7011 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7012 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7013 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7014
7015 ccc      write(iout,*) godl, sgodl, grad_odl3
7016
7017 c          grad_odl=grad_odl+grad_odl3
7018
7019          do jik=1,3
7020             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7021 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7022 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7023 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7024             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7025             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7026 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7027 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7028 c         if (i.eq.25.and.j.eq.27) then
7029 c         write(iout,*) "jik",jik,"i",i,"j",j
7030 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7031 c         write(iout,*) "grad_odl3",grad_odl3
7032 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7033 c         write(iout,*) "ggodl",ggodl
7034 c         write(iout,*) "ghpbc(",jik,i,")",
7035 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7036 c     &                 ghpbc(jik,j)
7037 c         endif
7038          enddo
7039 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7040 ccc     & dLOG(odleg2),"-odleg=", -odleg
7041
7042       enddo ! ii-loop for dist
7043 #ifdef DEBUG
7044       write(iout,*) "------- dist restrs end -------"
7045 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7046 c    &     waga_d.eq.1.0d0) call sum_gradient
7047 #endif
7048 c Pseudo-energy and gradient from dihedral-angle restraints from
7049 c homology templates
7050 c      write (iout,*) "End of distance loop"
7051 c      call flush(iout)
7052       kat=0.0d0
7053 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7054 #ifdef DEBUG
7055       write(iout,*) "------- dih restrs start -------"
7056       do i=idihconstr_start_homo,idihconstr_end_homo
7057         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7058       enddo
7059 #endif
7060       do i=idihconstr_start_homo,idihconstr_end_homo
7061         kat2=0.0d0
7062 c        betai=beta(i,i+1,i+2,i+3)
7063         betai = phi(i+3)
7064 c       write (iout,*) "betai =",betai
7065         do k=1,constr_homology
7066           dih_diff(k)=pinorm(dih(k,i)-betai)
7067 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
7068 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7069 c     &                                   -(6.28318-dih_diff(i,k))
7070 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7071 c     &                                   6.28318+dih_diff(i,k)
7072
7073           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7074 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7075           gdih(k)=dexp(kat3)
7076           kat2=kat2+gdih(k)
7077 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7078 c          write(*,*)""
7079         enddo
7080 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7081 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7082 #ifdef DEBUG
7083         write (iout,*) "i",i," betai",betai," kat2",kat2
7084         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7085 #endif
7086         if (kat2.le.1.0d-14) cycle
7087         kat=kat-dLOG(kat2/constr_homology)
7088 c       write (iout,*) "kat",kat ! sum of -ln-s
7089
7090 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7091 ccc     & dLOG(kat2), "-kat=", -kat
7092
7093 c ----------------------------------------------------------------------
7094 c Gradient
7095 c ----------------------------------------------------------------------
7096
7097         sum_gdih=kat2
7098         sum_sgdih=0.0d0
7099         do k=1,constr_homology
7100           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7101 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7102           sum_sgdih=sum_sgdih+sgdih
7103         enddo
7104 c       grad_dih3=sum_sgdih/sum_gdih
7105         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7106
7107 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7108 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7109 ccc     & gloc(nphi+i-3,icg)
7110         gloc(i,icg)=gloc(i,icg)+grad_dih3
7111 c        if (i.eq.25) then
7112 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7113 c        endif
7114 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7115 ccc     & gloc(nphi+i-3,icg)
7116
7117       enddo ! i-loop for dih
7118 #ifdef DEBUG
7119       write(iout,*) "------- dih restrs end -------"
7120 #endif
7121
7122 c Pseudo-energy and gradient for theta angle restraints from
7123 c homology templates
7124 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7125 c adapted
7126
7127 c
7128 c     For constr_homology reference structures (FP)
7129 c
7130 c     Uconst_back_tot=0.0d0
7131       Eval=0.0d0
7132       Erot=0.0d0
7133 c     Econstr_back legacy
7134       do i=1,nres
7135 c     do i=ithet_start,ithet_end
7136        dutheta(i)=0.0d0
7137 c     enddo
7138 c     do i=loc_start,loc_end
7139         do j=1,3
7140           duscdiff(j,i)=0.0d0
7141           duscdiffx(j,i)=0.0d0
7142         enddo
7143       enddo
7144 c
7145 c     do iref=1,nref
7146 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7147 c     write (iout,*) "waga_theta",waga_theta
7148       if (waga_theta.gt.0.0d0) then
7149 #ifdef DEBUG
7150       write (iout,*) "usampl",usampl
7151       write(iout,*) "------- theta restrs start -------"
7152 c     do i=ithet_start,ithet_end
7153 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7154 c     enddo
7155 #endif
7156 c     write (iout,*) "maxres",maxres,"nres",nres
7157
7158       do i=ithet_start,ithet_end
7159 c
7160 c     do i=1,nfrag_back
7161 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7162 c
7163 c Deviation of theta angles wrt constr_homology ref structures
7164 c
7165         utheta_i=0.0d0 ! argument of Gaussian for single k
7166         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7167 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7168 c       over residues in a fragment
7169 c       write (iout,*) "theta(",i,")=",theta(i)
7170         do k=1,constr_homology
7171 c
7172 c         dtheta_i=theta(j)-thetaref(j,iref)
7173 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7174           theta_diff(k)=thetatpl(k,i)-theta(i)
7175 c
7176           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7177 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7178           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7179           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
7180 c         Gradient for single Gaussian restraint in subr Econstr_back
7181 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7182 c
7183         enddo
7184 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7185 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7186
7187 c
7188 c         Gradient for multiple Gaussian restraint
7189         sum_gtheta=gutheta_i
7190         sum_sgtheta=0.0d0
7191         do k=1,constr_homology
7192 c        New generalized expr for multiple Gaussian from Econstr_back
7193          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7194 c
7195 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7196           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7197         enddo
7198 c       Final value of gradient using same var as in Econstr_back
7199         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7200      &      +sum_sgtheta/sum_gtheta*waga_theta
7201      &               *waga_homology(iset)
7202 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7203 c     &               *waga_homology(iset)
7204 c       dutheta(i)=sum_sgtheta/sum_gtheta
7205 c
7206 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7207         Eval=Eval-dLOG(gutheta_i/constr_homology)
7208 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7209 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7210 c       Uconst_back=Uconst_back+utheta(i)
7211       enddo ! (i-loop for theta)
7212 #ifdef DEBUG
7213       write(iout,*) "------- theta restrs end -------"
7214 #endif
7215       endif
7216 c
7217 c Deviation of local SC geometry
7218 c
7219 c Separation of two i-loops (instructed by AL - 11/3/2014)
7220 c
7221 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7222 c     write (iout,*) "waga_d",waga_d
7223
7224 #ifdef DEBUG
7225       write(iout,*) "------- SC restrs start -------"
7226       write (iout,*) "Initial duscdiff,duscdiffx"
7227       do i=loc_start,loc_end
7228         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7229      &                 (duscdiffx(jik,i),jik=1,3)
7230       enddo
7231 #endif
7232       do i=loc_start,loc_end
7233         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7234         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7235 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7236 c       write(iout,*) "xxtab, yytab, zztab"
7237 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7238         do k=1,constr_homology
7239 c
7240           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7241 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7242           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7243           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7244 c         write(iout,*) "dxx, dyy, dzz"
7245 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7246 c
7247           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7248 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7249 c         uscdiffk(k)=usc_diff(i)
7250           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7251           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
7252 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7253 c     &      xxref(j),yyref(j),zzref(j)
7254         enddo
7255 c
7256 c       Gradient
7257 c
7258 c       Generalized expression for multiple Gaussian acc to that for a single
7259 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7260 c
7261 c       Original implementation
7262 c       sum_guscdiff=guscdiff(i)
7263 c
7264 c       sum_sguscdiff=0.0d0
7265 c       do k=1,constr_homology
7266 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7267 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7268 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7269 c       enddo
7270 c
7271 c       Implementation of new expressions for gradient (Jan. 2015)
7272 c
7273 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7274         do k=1,constr_homology
7275 c
7276 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7277 c       before. Now the drivatives should be correct
7278 c
7279           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7280 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7281           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7282           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7283 c
7284 c         New implementation
7285 c
7286           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7287      &                 sigma_d(k,i) ! for the grad wrt r'
7288 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7289 c
7290 c
7291 c        New implementation
7292          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7293          do jik=1,3
7294             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7295      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7296      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7297             duscdiff(jik,i)=duscdiff(jik,i)+
7298      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7299      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7300             duscdiffx(jik,i)=duscdiffx(jik,i)+
7301      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7302      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7303 c
7304 #ifdef DEBUG
7305              write(iout,*) "jik",jik,"i",i
7306              write(iout,*) "dxx, dyy, dzz"
7307              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7308              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7309 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7310 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7311 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7312 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7313 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7314 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7315 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7316 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7317 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7318 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7319 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7320 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7321 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7322 c            endif
7323 #endif
7324          enddo
7325         enddo
7326 c
7327 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7328 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7329 c
7330 c        write (iout,*) i," uscdiff",uscdiff(i)
7331 c
7332 c Put together deviations from local geometry
7333
7334 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7335 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7336         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7337 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7338 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7339 c       Uconst_back=Uconst_back+usc_diff(i)
7340 c
7341 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7342 c
7343 c     New implment: multiplied by sum_sguscdiff
7344 c
7345
7346       enddo ! (i-loop for dscdiff)
7347
7348 c      endif
7349
7350 #ifdef DEBUG
7351       write(iout,*) "------- SC restrs end -------"
7352         write (iout,*) "------ After SC loop in e_modeller ------"
7353         do i=loc_start,loc_end
7354          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7355          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7356         enddo
7357       if (waga_theta.eq.1.0d0) then
7358       write (iout,*) "in e_modeller after SC restr end: dutheta"
7359       do i=ithet_start,ithet_end
7360         write (iout,*) i,dutheta(i)
7361       enddo
7362       endif
7363       if (waga_d.eq.1.0d0) then
7364       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7365       do i=1,nres
7366         write (iout,*) i,(duscdiff(j,i),j=1,3)
7367         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7368       enddo
7369       endif
7370 #endif
7371
7372 c Total energy from homology restraints
7373 #ifdef DEBUG
7374       write (iout,*) "odleg",odleg," kat",kat
7375 #endif
7376 c
7377 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7378 c
7379 c     ehomology_constr=odleg+kat
7380 c
7381 c     For Lorentzian-type Urestr
7382 c
7383
7384       if (waga_dist.ge.0.0d0) then
7385 c
7386 c          For Gaussian-type Urestr
7387 c
7388         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7389      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7390 c     write (iout,*) "ehomology_constr=",ehomology_constr
7391       else
7392 c
7393 c          For Lorentzian-type Urestr
7394 c
7395         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7396      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7397 c     write (iout,*) "ehomology_constr=",ehomology_constr
7398       endif
7399 #ifdef DEBUG
7400       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7401      & "Eval",waga_theta,eval,
7402      &   "Erot",waga_d,Erot
7403       write (iout,*) "ehomology_constr",ehomology_constr
7404 #endif
7405       return
7406 c
7407 c FP 01/15 end
7408 c
7409   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7410   747 format(a12,i4,i4,i4,f8.3,f8.3)
7411   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7412   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7413   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7414      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7415       end
7416
7417 c------------------------------------------------------------------------------
7418       subroutine etor_d(etors_d)
7419 C 6/23/01 Compute double torsional energy
7420       implicit real*8 (a-h,o-z)
7421       include 'DIMENSIONS'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       include 'COMMON.LOCAL'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.INTERACT'
7427       include 'COMMON.DERIV'
7428       include 'COMMON.CHAIN'
7429       include 'COMMON.NAMES'
7430       include 'COMMON.IOUNITS'
7431       include 'COMMON.FFIELD'
7432       include 'COMMON.TORCNSTR'
7433       include 'COMMON.CONTROL'
7434       logical lprn
7435 C Set lprn=.true. for debugging
7436       lprn=.false.
7437 c     lprn=.true.
7438       etors_d=0.0D0
7439 c      write(iout,*) "a tu??"
7440       do i=iphid_start,iphid_end
7441 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7442 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7443 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7444 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7445 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7446          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7447      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7448      &  (itype(i+1).eq.ntyp1)) cycle
7449 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7450         etors_d_ii=0.0D0
7451         itori=itortyp(itype(i-2))
7452         itori1=itortyp(itype(i-1))
7453         itori2=itortyp(itype(i))
7454         phii=phi(i)
7455         phii1=phi(i+1)
7456         gloci1=0.0D0
7457         gloci2=0.0D0
7458         iblock=1
7459         if (iabs(itype(i+1)).eq.20) iblock=2
7460 C Iblock=2 Proline type
7461 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7462 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7463 C        if (itype(i+1).eq.ntyp1) iblock=3
7464 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7465 C IS or IS NOT need for this
7466 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7467 C        is (itype(i-3).eq.ntyp1) ntblock=2
7468 C        ntblock is N-terminal blocking group
7469
7470 C Regular cosine and sine terms
7471         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7472 C Example of changes for NH3+ blocking group
7473 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7474 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7475           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7476           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7477           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7478           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7479           cosphi1=dcos(j*phii)
7480           sinphi1=dsin(j*phii)
7481           cosphi2=dcos(j*phii1)
7482           sinphi2=dsin(j*phii1)
7483           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7484      &     v2cij*cosphi2+v2sij*sinphi2
7485           if (energy_dec) etors_d_ii=etors_d_ii+
7486      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7487           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7488           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7489         enddo
7490         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7491           do l=1,k-1
7492             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7493             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7494             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7495             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7496             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7497             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7498             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7499             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7500             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7501      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7502             if (energy_dec) etors_d_ii=etors_d_ii+
7503      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7504      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7505             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7506      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7507             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7508      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7509           enddo
7510         enddo
7511           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7512      &         'etor_d',i,etors_d_ii
7513         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7514         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7515       enddo
7516       return
7517       end
7518 #endif
7519 c------------------------------------------------------------------------------
7520       subroutine eback_sc_corr(esccor)
7521 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7522 c        conformational states; temporarily implemented as differences
7523 c        between UNRES torsional potentials (dependent on three types of
7524 c        residues) and the torsional potentials dependent on all 20 types
7525 c        of residues computed from AM1  energy surfaces of terminally-blocked
7526 c        amino-acid residues.
7527       implicit real*8 (a-h,o-z)
7528       include 'DIMENSIONS'
7529       include 'COMMON.VAR'
7530       include 'COMMON.GEO'
7531       include 'COMMON.LOCAL'
7532       include 'COMMON.TORSION'
7533       include 'COMMON.SCCOR'
7534       include 'COMMON.INTERACT'
7535       include 'COMMON.DERIV'
7536       include 'COMMON.CHAIN'
7537       include 'COMMON.NAMES'
7538       include 'COMMON.IOUNITS'
7539       include 'COMMON.FFIELD'
7540       include 'COMMON.CONTROL'
7541       logical lprn
7542 C Set lprn=.true. for debugging
7543       lprn=.false.
7544 c      lprn=.true.
7545 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7546       esccor=0.0D0
7547       do i=itau_start,itau_end
7548         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7549         esccor_ii=0.0D0
7550         isccori=isccortyp(itype(i-2))
7551         isccori1=isccortyp(itype(i-1))
7552 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7553         phii=phi(i)
7554         do intertyp=1,3 !intertyp
7555 cc Added 09 May 2012 (Adasko)
7556 cc  Intertyp means interaction type of backbone mainchain correlation:
7557 c   1 = SC...Ca...Ca...Ca
7558 c   2 = Ca...Ca...Ca...SC
7559 c   3 = SC...Ca...Ca...SCi
7560         gloci=0.0D0
7561         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7562      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7563      &      (itype(i-1).eq.ntyp1)))
7564      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7565      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7566      &     .or.(itype(i).eq.ntyp1)))
7567      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7568      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7569      &      (itype(i-3).eq.ntyp1)))) cycle
7570         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7571         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7572      & cycle
7573        do j=1,nterm_sccor(isccori,isccori1)
7574           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7575           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7576           cosphi=dcos(j*tauangle(intertyp,i))
7577           sinphi=dsin(j*tauangle(intertyp,i))
7578           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7579           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7580         enddo
7581 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7582         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7583         if (lprn)
7584      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7585      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7586      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7587      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7588         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7589        enddo !intertyp
7590       enddo
7591
7592       return
7593       end
7594 c----------------------------------------------------------------------------
7595       subroutine multibody(ecorr)
7596 C This subroutine calculates multi-body contributions to energy following
7597 C the idea of Skolnick et al. If side chains I and J make a contact and
7598 C at the same time side chains I+1 and J+1 make a contact, an extra
7599 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7600       implicit real*8 (a-h,o-z)
7601       include 'DIMENSIONS'
7602       include 'COMMON.IOUNITS'
7603       include 'COMMON.DERIV'
7604       include 'COMMON.INTERACT'
7605       include 'COMMON.CONTACTS'
7606       double precision gx(3),gx1(3)
7607       logical lprn
7608
7609 C Set lprn=.true. for debugging
7610       lprn=.false.
7611
7612       if (lprn) then
7613         write (iout,'(a)') 'Contact function values:'
7614         do i=nnt,nct-2
7615           write (iout,'(i2,20(1x,i2,f10.5))')
7616      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7617         enddo
7618       endif
7619       ecorr=0.0D0
7620       do i=nnt,nct
7621         do j=1,3
7622           gradcorr(j,i)=0.0D0
7623           gradxorr(j,i)=0.0D0
7624         enddo
7625       enddo
7626       do i=nnt,nct-2
7627
7628         DO ISHIFT = 3,4
7629
7630         i1=i+ishift
7631         num_conti=num_cont(i)
7632         num_conti1=num_cont(i1)
7633         do jj=1,num_conti
7634           j=jcont(jj,i)
7635           do kk=1,num_conti1
7636             j1=jcont(kk,i1)
7637             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7638 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7639 cd   &                   ' ishift=',ishift
7640 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7641 C The system gains extra energy.
7642               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7643             endif   ! j1==j+-ishift
7644           enddo     ! kk
7645         enddo       ! jj
7646
7647         ENDDO ! ISHIFT
7648
7649       enddo         ! i
7650       return
7651       end
7652 c------------------------------------------------------------------------------
7653       double precision function esccorr(i,j,k,l,jj,kk)
7654       implicit real*8 (a-h,o-z)
7655       include 'DIMENSIONS'
7656       include 'COMMON.IOUNITS'
7657       include 'COMMON.DERIV'
7658       include 'COMMON.INTERACT'
7659       include 'COMMON.CONTACTS'
7660       double precision gx(3),gx1(3)
7661       logical lprn
7662       lprn=.false.
7663       eij=facont(jj,i)
7664       ekl=facont(kk,k)
7665 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7666 C Calculate the multi-body contribution to energy.
7667 C Calculate multi-body contributions to the gradient.
7668 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7669 cd   & k,l,(gacont(m,kk,k),m=1,3)
7670       do m=1,3
7671         gx(m) =ekl*gacont(m,jj,i)
7672         gx1(m)=eij*gacont(m,kk,k)
7673         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7674         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7675         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7676         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7677       enddo
7678       do m=i,j-1
7679         do ll=1,3
7680           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7681         enddo
7682       enddo
7683       do m=k,l-1
7684         do ll=1,3
7685           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7686         enddo
7687       enddo
7688       esccorr=-eij*ekl
7689       return
7690       end
7691 c------------------------------------------------------------------------------
7692       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7693 C This subroutine calculates multi-body contributions to hydrogen-bonding
7694       implicit real*8 (a-h,o-z)
7695       include 'DIMENSIONS'
7696       include 'COMMON.IOUNITS'
7697 #ifdef MPI
7698       include "mpif.h"
7699       parameter (max_cont=maxconts)
7700       parameter (max_dim=26)
7701       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7702       double precision zapas(max_dim,maxconts,max_fg_procs),
7703      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7704       common /przechowalnia/ zapas
7705       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7706      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7707 #endif
7708       include 'COMMON.SETUP'
7709       include 'COMMON.FFIELD'
7710       include 'COMMON.DERIV'
7711       include 'COMMON.INTERACT'
7712       include 'COMMON.CONTACTS'
7713       include 'COMMON.CONTROL'
7714       include 'COMMON.LOCAL'
7715       double precision gx(3),gx1(3),time00
7716       logical lprn,ldone
7717
7718 C Set lprn=.true. for debugging
7719       lprn=.false.
7720 #ifdef MPI
7721       n_corr=0
7722       n_corr1=0
7723       if (nfgtasks.le.1) goto 30
7724       if (lprn) then
7725         write (iout,'(a)') 'Contact function values before RECEIVE:'
7726         do i=nnt,nct-2
7727           write (iout,'(2i3,50(1x,i2,f5.2))')
7728      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7729      &    j=1,num_cont_hb(i))
7730         enddo
7731       endif
7732       call flush(iout)
7733       do i=1,ntask_cont_from
7734         ncont_recv(i)=0
7735       enddo
7736       do i=1,ntask_cont_to
7737         ncont_sent(i)=0
7738       enddo
7739 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7740 c     & ntask_cont_to
7741 C Make the list of contacts to send to send to other procesors
7742 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7743 c      call flush(iout)
7744       do i=iturn3_start,iturn3_end
7745 c        write (iout,*) "make contact list turn3",i," num_cont",
7746 c     &    num_cont_hb(i)
7747         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7748       enddo
7749       do i=iturn4_start,iturn4_end
7750 c        write (iout,*) "make contact list turn4",i," num_cont",
7751 c     &   num_cont_hb(i)
7752         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7753       enddo
7754       do ii=1,nat_sent
7755         i=iat_sent(ii)
7756 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7757 c     &    num_cont_hb(i)
7758         do j=1,num_cont_hb(i)
7759         do k=1,4
7760           jjc=jcont_hb(j,i)
7761           iproc=iint_sent_local(k,jjc,ii)
7762 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7763           if (iproc.gt.0) then
7764             ncont_sent(iproc)=ncont_sent(iproc)+1
7765             nn=ncont_sent(iproc)
7766             zapas(1,nn,iproc)=i
7767             zapas(2,nn,iproc)=jjc
7768             zapas(3,nn,iproc)=facont_hb(j,i)
7769             zapas(4,nn,iproc)=ees0p(j,i)
7770             zapas(5,nn,iproc)=ees0m(j,i)
7771             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7772             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7773             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7774             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7775             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7776             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7777             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7778             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7779             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7780             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7781             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7782             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7783             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7784             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7785             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7786             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7787             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7788             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7789             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7790             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7791             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7792           endif
7793         enddo
7794         enddo
7795       enddo
7796       if (lprn) then
7797       write (iout,*)
7798      &  "Numbers of contacts to be sent to other processors",
7799      &  (ncont_sent(i),i=1,ntask_cont_to)
7800       write (iout,*) "Contacts sent"
7801       do ii=1,ntask_cont_to
7802         nn=ncont_sent(ii)
7803         iproc=itask_cont_to(ii)
7804         write (iout,*) nn," contacts to processor",iproc,
7805      &   " of CONT_TO_COMM group"
7806         do i=1,nn
7807           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7808         enddo
7809       enddo
7810       call flush(iout)
7811       endif
7812       CorrelType=477
7813       CorrelID=fg_rank+1
7814       CorrelType1=478
7815       CorrelID1=nfgtasks+fg_rank+1
7816       ireq=0
7817 C Receive the numbers of needed contacts from other processors
7818       do ii=1,ntask_cont_from
7819         iproc=itask_cont_from(ii)
7820         ireq=ireq+1
7821         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7822      &    FG_COMM,req(ireq),IERR)
7823       enddo
7824 c      write (iout,*) "IRECV ended"
7825 c      call flush(iout)
7826 C Send the number of contacts needed by other processors
7827       do ii=1,ntask_cont_to
7828         iproc=itask_cont_to(ii)
7829         ireq=ireq+1
7830         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7831      &    FG_COMM,req(ireq),IERR)
7832       enddo
7833 c      write (iout,*) "ISEND ended"
7834 c      write (iout,*) "number of requests (nn)",ireq
7835       call flush(iout)
7836       if (ireq.gt.0)
7837      &  call MPI_Waitall(ireq,req,status_array,ierr)
7838 c      write (iout,*)
7839 c     &  "Numbers of contacts to be received from other processors",
7840 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7841 c      call flush(iout)
7842 C Receive contacts
7843       ireq=0
7844       do ii=1,ntask_cont_from
7845         iproc=itask_cont_from(ii)
7846         nn=ncont_recv(ii)
7847 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7848 c     &   " of CONT_TO_COMM group"
7849         call flush(iout)
7850         if (nn.gt.0) then
7851           ireq=ireq+1
7852           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7853      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7854 c          write (iout,*) "ireq,req",ireq,req(ireq)
7855         endif
7856       enddo
7857 C Send the contacts to processors that need them
7858       do ii=1,ntask_cont_to
7859         iproc=itask_cont_to(ii)
7860         nn=ncont_sent(ii)
7861 c        write (iout,*) nn," contacts to processor",iproc,
7862 c     &   " of CONT_TO_COMM group"
7863         if (nn.gt.0) then
7864           ireq=ireq+1
7865           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7866      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7867 c          write (iout,*) "ireq,req",ireq,req(ireq)
7868 c          do i=1,nn
7869 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7870 c          enddo
7871         endif
7872       enddo
7873 c      write (iout,*) "number of requests (contacts)",ireq
7874 c      write (iout,*) "req",(req(i),i=1,4)
7875 c      call flush(iout)
7876       if (ireq.gt.0)
7877      & call MPI_Waitall(ireq,req,status_array,ierr)
7878       do iii=1,ntask_cont_from
7879         iproc=itask_cont_from(iii)
7880         nn=ncont_recv(iii)
7881         if (lprn) then
7882         write (iout,*) "Received",nn," contacts from processor",iproc,
7883      &   " of CONT_FROM_COMM group"
7884         call flush(iout)
7885         do i=1,nn
7886           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7887         enddo
7888         call flush(iout)
7889         endif
7890         do i=1,nn
7891           ii=zapas_recv(1,i,iii)
7892 c Flag the received contacts to prevent double-counting
7893           jj=-zapas_recv(2,i,iii)
7894 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7895 c          call flush(iout)
7896           nnn=num_cont_hb(ii)+1
7897           num_cont_hb(ii)=nnn
7898           jcont_hb(nnn,ii)=jj
7899           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7900           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7901           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7902           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7903           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7904           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7905           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7906           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7907           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7908           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7909           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7910           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7911           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7912           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7913           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7914           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7915           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7916           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7917           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7918           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7919           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7920           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7921           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7922           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7923         enddo
7924       enddo
7925       call flush(iout)
7926       if (lprn) then
7927         write (iout,'(a)') 'Contact function values after receive:'
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         call flush(iout)
7934       endif
7935    30 continue
7936 #endif
7937       if (lprn) then
7938         write (iout,'(a)') 'Contact function values:'
7939         do i=nnt,nct-2
7940           write (iout,'(2i3,50(1x,i3,f5.2))')
7941      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7942      &    j=1,num_cont_hb(i))
7943         enddo
7944       endif
7945       ecorr=0.0D0
7946 C Remove the loop below after debugging !!!
7947       do i=nnt,nct
7948         do j=1,3
7949           gradcorr(j,i)=0.0D0
7950           gradxorr(j,i)=0.0D0
7951         enddo
7952       enddo
7953 C Calculate the local-electrostatic correlation terms
7954       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7955         i1=i+1
7956         num_conti=num_cont_hb(i)
7957         num_conti1=num_cont_hb(i+1)
7958         do jj=1,num_conti
7959           j=jcont_hb(jj,i)
7960           jp=iabs(j)
7961           do kk=1,num_conti1
7962             j1=jcont_hb(kk,i1)
7963             jp1=iabs(j1)
7964 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7965 c     &         ' jj=',jj,' kk=',kk
7966             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7967      &          .or. j.lt.0 .and. j1.gt.0) .and.
7968      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7969 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7970 C The system gains extra energy.
7971               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7972               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7973      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7974               n_corr=n_corr+1
7975             else if (j1.eq.j) then
7976 C Contacts I-J and I-(J+1) occur simultaneously.
7977 C The system loses extra energy.
7978 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7979             endif
7980           enddo ! kk
7981           do kk=1,num_conti
7982             j1=jcont_hb(kk,i)
7983 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7984 c    &         ' jj=',jj,' kk=',kk
7985             if (j1.eq.j+1) then
7986 C Contacts I-J and (I+1)-J occur simultaneously.
7987 C The system loses extra energy.
7988 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7989             endif ! j1==j+1
7990           enddo ! kk
7991         enddo ! jj
7992       enddo ! i
7993       return
7994       end
7995 c------------------------------------------------------------------------------
7996       subroutine add_hb_contact(ii,jj,itask)
7997       implicit real*8 (a-h,o-z)
7998       include "DIMENSIONS"
7999       include "COMMON.IOUNITS"
8000       integer max_cont
8001       integer max_dim
8002       parameter (max_cont=maxconts)
8003       parameter (max_dim=26)
8004       include "COMMON.CONTACTS"
8005       double precision zapas(max_dim,maxconts,max_fg_procs),
8006      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8007       common /przechowalnia/ zapas
8008       integer i,j,ii,jj,iproc,itask(4),nn
8009 c      write (iout,*) "itask",itask
8010       do i=1,2
8011         iproc=itask(i)
8012         if (iproc.gt.0) then
8013           do j=1,num_cont_hb(ii)
8014             jjc=jcont_hb(j,ii)
8015 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8016             if (jjc.eq.jj) then
8017               ncont_sent(iproc)=ncont_sent(iproc)+1
8018               nn=ncont_sent(iproc)
8019               zapas(1,nn,iproc)=ii
8020               zapas(2,nn,iproc)=jjc
8021               zapas(3,nn,iproc)=facont_hb(j,ii)
8022               zapas(4,nn,iproc)=ees0p(j,ii)
8023               zapas(5,nn,iproc)=ees0m(j,ii)
8024               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8025               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8026               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8027               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8028               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8029               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8030               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8031               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8032               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8033               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8034               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8035               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8036               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8037               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8038               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8039               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8040               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8041               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8042               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8043               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8044               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8045               exit
8046             endif
8047           enddo
8048         endif
8049       enddo
8050       return
8051       end
8052 c------------------------------------------------------------------------------
8053       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8054      &  n_corr1)
8055 C This subroutine calculates multi-body contributions to hydrogen-bonding
8056       implicit real*8 (a-h,o-z)
8057       include 'DIMENSIONS'
8058       include 'COMMON.IOUNITS'
8059 #ifdef MPI
8060       include "mpif.h"
8061       parameter (max_cont=maxconts)
8062       parameter (max_dim=70)
8063       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8064       double precision zapas(max_dim,maxconts,max_fg_procs),
8065      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8066       common /przechowalnia/ zapas
8067       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8068      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8069 #endif
8070       include 'COMMON.SETUP'
8071       include 'COMMON.FFIELD'
8072       include 'COMMON.DERIV'
8073       include 'COMMON.LOCAL'
8074       include 'COMMON.INTERACT'
8075       include 'COMMON.CONTACTS'
8076       include 'COMMON.CHAIN'
8077       include 'COMMON.CONTROL'
8078       double precision gx(3),gx1(3)
8079       integer num_cont_hb_old(maxres)
8080       logical lprn,ldone
8081       double precision eello4,eello5,eelo6,eello_turn6
8082       external eello4,eello5,eello6,eello_turn6
8083 C Set lprn=.true. for debugging
8084       lprn=.false.
8085       eturn6=0.0d0
8086 #ifdef MPI
8087       do i=1,nres
8088         num_cont_hb_old(i)=num_cont_hb(i)
8089       enddo
8090       n_corr=0
8091       n_corr1=0
8092       if (nfgtasks.le.1) goto 30
8093       if (lprn) then
8094         write (iout,'(a)') 'Contact function values before RECEIVE:'
8095         do i=nnt,nct-2
8096           write (iout,'(2i3,50(1x,i2,f5.2))')
8097      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8098      &    j=1,num_cont_hb(i))
8099         enddo
8100       endif
8101       call flush(iout)
8102       do i=1,ntask_cont_from
8103         ncont_recv(i)=0
8104       enddo
8105       do i=1,ntask_cont_to
8106         ncont_sent(i)=0
8107       enddo
8108 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8109 c     & ntask_cont_to
8110 C Make the list of contacts to send to send to other procesors
8111       do i=iturn3_start,iturn3_end
8112 c        write (iout,*) "make contact list turn3",i," num_cont",
8113 c     &    num_cont_hb(i)
8114         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8115       enddo
8116       do i=iturn4_start,iturn4_end
8117 c        write (iout,*) "make contact list turn4",i," num_cont",
8118 c     &   num_cont_hb(i)
8119         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8120       enddo
8121       do ii=1,nat_sent
8122         i=iat_sent(ii)
8123 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8124 c     &    num_cont_hb(i)
8125         do j=1,num_cont_hb(i)
8126         do k=1,4
8127           jjc=jcont_hb(j,i)
8128           iproc=iint_sent_local(k,jjc,ii)
8129 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8130           if (iproc.ne.0) then
8131             ncont_sent(iproc)=ncont_sent(iproc)+1
8132             nn=ncont_sent(iproc)
8133             zapas(1,nn,iproc)=i
8134             zapas(2,nn,iproc)=jjc
8135             zapas(3,nn,iproc)=d_cont(j,i)
8136             ind=3
8137             do kk=1,3
8138               ind=ind+1
8139               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8140             enddo
8141             do kk=1,2
8142               do ll=1,2
8143                 ind=ind+1
8144                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8145               enddo
8146             enddo
8147             do jj=1,5
8148               do kk=1,3
8149                 do ll=1,2
8150                   do mm=1,2
8151                     ind=ind+1
8152                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8153                   enddo
8154                 enddo
8155               enddo
8156             enddo
8157           endif
8158         enddo
8159         enddo
8160       enddo
8161       if (lprn) then
8162       write (iout,*)
8163      &  "Numbers of contacts to be sent to other processors",
8164      &  (ncont_sent(i),i=1,ntask_cont_to)
8165       write (iout,*) "Contacts sent"
8166       do ii=1,ntask_cont_to
8167         nn=ncont_sent(ii)
8168         iproc=itask_cont_to(ii)
8169         write (iout,*) nn," contacts to processor",iproc,
8170      &   " of CONT_TO_COMM group"
8171         do i=1,nn
8172           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8173         enddo
8174       enddo
8175       call flush(iout)
8176       endif
8177       CorrelType=477
8178       CorrelID=fg_rank+1
8179       CorrelType1=478
8180       CorrelID1=nfgtasks+fg_rank+1
8181       ireq=0
8182 C Receive the numbers of needed contacts from other processors
8183       do ii=1,ntask_cont_from
8184         iproc=itask_cont_from(ii)
8185         ireq=ireq+1
8186         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8187      &    FG_COMM,req(ireq),IERR)
8188       enddo
8189 c      write (iout,*) "IRECV ended"
8190 c      call flush(iout)
8191 C Send the number of contacts needed by other processors
8192       do ii=1,ntask_cont_to
8193         iproc=itask_cont_to(ii)
8194         ireq=ireq+1
8195         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8196      &    FG_COMM,req(ireq),IERR)
8197       enddo
8198 c      write (iout,*) "ISEND ended"
8199 c      write (iout,*) "number of requests (nn)",ireq
8200       call flush(iout)
8201       if (ireq.gt.0)
8202      &  call MPI_Waitall(ireq,req,status_array,ierr)
8203 c      write (iout,*)
8204 c     &  "Numbers of contacts to be received from other processors",
8205 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8206 c      call flush(iout)
8207 C Receive contacts
8208       ireq=0
8209       do ii=1,ntask_cont_from
8210         iproc=itask_cont_from(ii)
8211         nn=ncont_recv(ii)
8212 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8213 c     &   " of CONT_TO_COMM group"
8214         call flush(iout)
8215         if (nn.gt.0) then
8216           ireq=ireq+1
8217           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8218      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8219 c          write (iout,*) "ireq,req",ireq,req(ireq)
8220         endif
8221       enddo
8222 C Send the contacts to processors that need them
8223       do ii=1,ntask_cont_to
8224         iproc=itask_cont_to(ii)
8225         nn=ncont_sent(ii)
8226 c        write (iout,*) nn," contacts to processor",iproc,
8227 c     &   " of CONT_TO_COMM group"
8228         if (nn.gt.0) then
8229           ireq=ireq+1
8230           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8231      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8232 c          write (iout,*) "ireq,req",ireq,req(ireq)
8233 c          do i=1,nn
8234 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8235 c          enddo
8236         endif
8237       enddo
8238 c      write (iout,*) "number of requests (contacts)",ireq
8239 c      write (iout,*) "req",(req(i),i=1,4)
8240 c      call flush(iout)
8241       if (ireq.gt.0)
8242      & call MPI_Waitall(ireq,req,status_array,ierr)
8243       do iii=1,ntask_cont_from
8244         iproc=itask_cont_from(iii)
8245         nn=ncont_recv(iii)
8246         if (lprn) then
8247         write (iout,*) "Received",nn," contacts from processor",iproc,
8248      &   " of CONT_FROM_COMM group"
8249         call flush(iout)
8250         do i=1,nn
8251           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8252         enddo
8253         call flush(iout)
8254         endif
8255         do i=1,nn
8256           ii=zapas_recv(1,i,iii)
8257 c Flag the received contacts to prevent double-counting
8258           jj=-zapas_recv(2,i,iii)
8259 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8260 c          call flush(iout)
8261           nnn=num_cont_hb(ii)+1
8262           num_cont_hb(ii)=nnn
8263           jcont_hb(nnn,ii)=jj
8264           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8265           ind=3
8266           do kk=1,3
8267             ind=ind+1
8268             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8269           enddo
8270           do kk=1,2
8271             do ll=1,2
8272               ind=ind+1
8273               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8274             enddo
8275           enddo
8276           do jj=1,5
8277             do kk=1,3
8278               do ll=1,2
8279                 do mm=1,2
8280                   ind=ind+1
8281                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8282                 enddo
8283               enddo
8284             enddo
8285           enddo
8286         enddo
8287       enddo
8288       call flush(iout)
8289       if (lprn) then
8290         write (iout,'(a)') 'Contact function values after receive:'
8291         do i=nnt,nct-2
8292           write (iout,'(2i3,50(1x,i3,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         call flush(iout)
8297       endif
8298    30 continue
8299 #endif
8300       if (lprn) then
8301         write (iout,'(a)') 'Contact function values:'
8302         do i=nnt,nct-2
8303           write (iout,'(2i3,50(1x,i2,5f6.3))')
8304      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8305      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8306         enddo
8307       endif
8308       ecorr=0.0D0
8309       ecorr5=0.0d0
8310       ecorr6=0.0d0
8311 C Remove the loop below after debugging !!!
8312       do i=nnt,nct
8313         do j=1,3
8314           gradcorr(j,i)=0.0D0
8315           gradxorr(j,i)=0.0D0
8316         enddo
8317       enddo
8318 C Calculate the dipole-dipole interaction energies
8319       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8320       do i=iatel_s,iatel_e+1
8321         num_conti=num_cont_hb(i)
8322         do jj=1,num_conti
8323           j=jcont_hb(jj,i)
8324 #ifdef MOMENT
8325           call dipole(i,j,jj)
8326 #endif
8327         enddo
8328       enddo
8329       endif
8330 C Calculate the local-electrostatic correlation terms
8331 c                write (iout,*) "gradcorr5 in eello5 before loop"
8332 c                do iii=1,nres
8333 c                  write (iout,'(i5,3f10.5)')
8334 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8335 c                enddo
8336       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8337 c        write (iout,*) "corr loop i",i
8338         i1=i+1
8339         num_conti=num_cont_hb(i)
8340         num_conti1=num_cont_hb(i+1)
8341         do jj=1,num_conti
8342           j=jcont_hb(jj,i)
8343           jp=iabs(j)
8344           do kk=1,num_conti1
8345             j1=jcont_hb(kk,i1)
8346             jp1=iabs(j1)
8347 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8348 c     &         ' jj=',jj,' kk=',kk
8349 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8350             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8351      &          .or. j.lt.0 .and. j1.gt.0) .and.
8352      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8353 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8354 C The system gains extra energy.
8355               n_corr=n_corr+1
8356               sqd1=dsqrt(d_cont(jj,i))
8357               sqd2=dsqrt(d_cont(kk,i1))
8358               sred_geom = sqd1*sqd2
8359               IF (sred_geom.lt.cutoff_corr) THEN
8360                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8361      &            ekont,fprimcont)
8362 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8363 cd     &         ' jj=',jj,' kk=',kk
8364                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8365                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8366                 do l=1,3
8367                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8368                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8369                 enddo
8370                 n_corr1=n_corr1+1
8371 cd               write (iout,*) 'sred_geom=',sred_geom,
8372 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8373 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8374 cd               write (iout,*) "g_contij",g_contij
8375 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8376 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8377                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8378                 if (wcorr4.gt.0.0d0)
8379      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8380                   if (energy_dec.and.wcorr4.gt.0.0d0)
8381      1                 write (iout,'(a6,4i5,0pf7.3)')
8382      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8383 c                write (iout,*) "gradcorr5 before eello5"
8384 c                do iii=1,nres
8385 c                  write (iout,'(i5,3f10.5)')
8386 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8387 c                enddo
8388                 if (wcorr5.gt.0.0d0)
8389      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8390 c                write (iout,*) "gradcorr5 after eello5"
8391 c                do iii=1,nres
8392 c                  write (iout,'(i5,3f10.5)')
8393 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8394 c                enddo
8395                   if (energy_dec.and.wcorr5.gt.0.0d0)
8396      1                 write (iout,'(a6,4i5,0pf7.3)')
8397      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8398 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8399 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8400                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8401      &               .or. wturn6.eq.0.0d0))then
8402 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8403                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8404                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8405      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8406 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8407 cd     &            'ecorr6=',ecorr6
8408 cd                write (iout,'(4e15.5)') sred_geom,
8409 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8410 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8411 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8412                 else if (wturn6.gt.0.0d0
8413      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8414 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8415                   eturn6=eturn6+eello_turn6(i,jj,kk)
8416                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8417      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8418 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8419                 endif
8420               ENDIF
8421 1111          continue
8422             endif
8423           enddo ! kk
8424         enddo ! jj
8425       enddo ! i
8426       do i=1,nres
8427         num_cont_hb(i)=num_cont_hb_old(i)
8428       enddo
8429 c                write (iout,*) "gradcorr5 in eello5"
8430 c                do iii=1,nres
8431 c                  write (iout,'(i5,3f10.5)')
8432 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8433 c                enddo
8434       return
8435       end
8436 c------------------------------------------------------------------------------
8437       subroutine add_hb_contact_eello(ii,jj,itask)
8438       implicit real*8 (a-h,o-z)
8439       include "DIMENSIONS"
8440       include "COMMON.IOUNITS"
8441       integer max_cont
8442       integer max_dim
8443       parameter (max_cont=maxconts)
8444       parameter (max_dim=70)
8445       include "COMMON.CONTACTS"
8446       double precision zapas(max_dim,maxconts,max_fg_procs),
8447      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8448       common /przechowalnia/ zapas
8449       integer i,j,ii,jj,iproc,itask(4),nn
8450 c      write (iout,*) "itask",itask
8451       do i=1,2
8452         iproc=itask(i)
8453         if (iproc.gt.0) then
8454           do j=1,num_cont_hb(ii)
8455             jjc=jcont_hb(j,ii)
8456 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8457             if (jjc.eq.jj) then
8458               ncont_sent(iproc)=ncont_sent(iproc)+1
8459               nn=ncont_sent(iproc)
8460               zapas(1,nn,iproc)=ii
8461               zapas(2,nn,iproc)=jjc
8462               zapas(3,nn,iproc)=d_cont(j,ii)
8463               ind=3
8464               do kk=1,3
8465                 ind=ind+1
8466                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8467               enddo
8468               do kk=1,2
8469                 do ll=1,2
8470                   ind=ind+1
8471                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8472                 enddo
8473               enddo
8474               do jj=1,5
8475                 do kk=1,3
8476                   do ll=1,2
8477                     do mm=1,2
8478                       ind=ind+1
8479                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8480                     enddo
8481                   enddo
8482                 enddo
8483               enddo
8484               exit
8485             endif
8486           enddo
8487         endif
8488       enddo
8489       return
8490       end
8491 c------------------------------------------------------------------------------
8492       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8493       implicit real*8 (a-h,o-z)
8494       include 'DIMENSIONS'
8495       include 'COMMON.IOUNITS'
8496       include 'COMMON.DERIV'
8497       include 'COMMON.INTERACT'
8498       include 'COMMON.CONTACTS'
8499       double precision gx(3),gx1(3)
8500       logical lprn
8501       lprn=.false.
8502       eij=facont_hb(jj,i)
8503       ekl=facont_hb(kk,k)
8504       ees0pij=ees0p(jj,i)
8505       ees0pkl=ees0p(kk,k)
8506       ees0mij=ees0m(jj,i)
8507       ees0mkl=ees0m(kk,k)
8508       ekont=eij*ekl
8509       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8510 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8511 C Following 4 lines for diagnostics.
8512 cd    ees0pkl=0.0D0
8513 cd    ees0pij=1.0D0
8514 cd    ees0mkl=0.0D0
8515 cd    ees0mij=1.0D0
8516 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8517 c     & 'Contacts ',i,j,
8518 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8519 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8520 c     & 'gradcorr_long'
8521 C Calculate the multi-body contribution to energy.
8522 c      ecorr=ecorr+ekont*ees
8523 C Calculate multi-body contributions to the gradient.
8524       coeffpees0pij=coeffp*ees0pij
8525       coeffmees0mij=coeffm*ees0mij
8526       coeffpees0pkl=coeffp*ees0pkl
8527       coeffmees0mkl=coeffm*ees0mkl
8528       do ll=1,3
8529 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8530         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8531      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8532      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8533         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8534      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8535      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8536 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8537         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8538      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8539      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8540         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8541      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8542      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8543         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8544      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8545      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8546         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8547         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8548         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8549      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8550      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8551         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8552         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8553 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8554       enddo
8555 c      write (iout,*)
8556 cgrad      do m=i+1,j-1
8557 cgrad        do ll=1,3
8558 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8559 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8560 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8561 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8562 cgrad        enddo
8563 cgrad      enddo
8564 cgrad      do m=k+1,l-1
8565 cgrad        do ll=1,3
8566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8567 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8568 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8569 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8570 cgrad        enddo
8571 cgrad      enddo
8572 c      write (iout,*) "ehbcorr",ekont*ees
8573       ehbcorr=ekont*ees
8574       return
8575       end
8576 #ifdef MOMENT
8577 C---------------------------------------------------------------------------
8578       subroutine dipole(i,j,jj)
8579       implicit real*8 (a-h,o-z)
8580       include 'DIMENSIONS'
8581       include 'COMMON.IOUNITS'
8582       include 'COMMON.CHAIN'
8583       include 'COMMON.FFIELD'
8584       include 'COMMON.DERIV'
8585       include 'COMMON.INTERACT'
8586       include 'COMMON.CONTACTS'
8587       include 'COMMON.TORSION'
8588       include 'COMMON.VAR'
8589       include 'COMMON.GEO'
8590       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8591      &  auxmat(2,2)
8592       iti1 = itortyp(itype(i+1))
8593       if (j.lt.nres-1) then
8594         itj1 = itortyp(itype(j+1))
8595       else
8596         itj1=ntortyp
8597       endif
8598       do iii=1,2
8599         dipi(iii,1)=Ub2(iii,i)
8600         dipderi(iii)=Ub2der(iii,i)
8601         dipi(iii,2)=b1(iii,i+1)
8602         dipj(iii,1)=Ub2(iii,j)
8603         dipderj(iii)=Ub2der(iii,j)
8604         dipj(iii,2)=b1(iii,j+1)
8605       enddo
8606       kkk=0
8607       do iii=1,2
8608         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8609         do jjj=1,2
8610           kkk=kkk+1
8611           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8612         enddo
8613       enddo
8614       do kkk=1,5
8615         do lll=1,3
8616           mmm=0
8617           do iii=1,2
8618             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8619      &        auxvec(1))
8620             do jjj=1,2
8621               mmm=mmm+1
8622               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8623             enddo
8624           enddo
8625         enddo
8626       enddo
8627       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8628       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8629       do iii=1,2
8630         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8631       enddo
8632       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8633       do iii=1,2
8634         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8635       enddo
8636       return
8637       end
8638 #endif
8639 C---------------------------------------------------------------------------
8640       subroutine calc_eello(i,j,k,l,jj,kk)
8641 C
8642 C This subroutine computes matrices and vectors needed to calculate
8643 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8644 C
8645       implicit real*8 (a-h,o-z)
8646       include 'DIMENSIONS'
8647       include 'COMMON.IOUNITS'
8648       include 'COMMON.CHAIN'
8649       include 'COMMON.DERIV'
8650       include 'COMMON.INTERACT'
8651       include 'COMMON.CONTACTS'
8652       include 'COMMON.TORSION'
8653       include 'COMMON.VAR'
8654       include 'COMMON.GEO'
8655       include 'COMMON.FFIELD'
8656       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8657      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8658       logical lprn
8659       common /kutas/ lprn
8660 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8661 cd     & ' jj=',jj,' kk=',kk
8662 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8663 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8664 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8665       do iii=1,2
8666         do jjj=1,2
8667           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8668           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8669         enddo
8670       enddo
8671       call transpose2(aa1(1,1),aa1t(1,1))
8672       call transpose2(aa2(1,1),aa2t(1,1))
8673       do kkk=1,5
8674         do lll=1,3
8675           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8676      &      aa1tder(1,1,lll,kkk))
8677           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8678      &      aa2tder(1,1,lll,kkk))
8679         enddo
8680       enddo
8681       if (l.eq.j+1) then
8682 C parallel orientation of the two CA-CA-CA frames.
8683         if (i.gt.1) then
8684           iti=itortyp(itype(i))
8685         else
8686           iti=ntortyp
8687         endif
8688         itk1=itortyp(itype(k+1))
8689         itj=itortyp(itype(j))
8690         if (l.lt.nres-1) then
8691           itl1=itortyp(itype(l+1))
8692         else
8693           itl1=ntortyp
8694         endif
8695 C A1 kernel(j+1) A2T
8696 cd        do iii=1,2
8697 cd          write (iout,'(3f10.5,5x,3f10.5)')
8698 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8699 cd        enddo
8700         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8701      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8702      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8703 C Following matrices are needed only for 6-th order cumulants
8704         IF (wcorr6.gt.0.0d0) THEN
8705         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8706      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8707      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8708         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8709      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8710      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8711      &   ADtEAderx(1,1,1,1,1,1))
8712         lprn=.false.
8713         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8714      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8715      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8716      &   ADtEA1derx(1,1,1,1,1,1))
8717         ENDIF
8718 C End 6-th order cumulants
8719 cd        lprn=.false.
8720 cd        if (lprn) then
8721 cd        write (2,*) 'In calc_eello6'
8722 cd        do iii=1,2
8723 cd          write (2,*) 'iii=',iii
8724 cd          do kkk=1,5
8725 cd            write (2,*) 'kkk=',kkk
8726 cd            do jjj=1,2
8727 cd              write (2,'(3(2f10.5),5x)')
8728 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8729 cd            enddo
8730 cd          enddo
8731 cd        enddo
8732 cd        endif
8733         call transpose2(EUgder(1,1,k),auxmat(1,1))
8734         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8735         call transpose2(EUg(1,1,k),auxmat(1,1))
8736         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8737         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8738         do iii=1,2
8739           do kkk=1,5
8740             do lll=1,3
8741               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8742      &          EAEAderx(1,1,lll,kkk,iii,1))
8743             enddo
8744           enddo
8745         enddo
8746 C A1T kernel(i+1) A2
8747         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8748      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8749      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8750 C Following matrices are needed only for 6-th order cumulants
8751         IF (wcorr6.gt.0.0d0) THEN
8752         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8753      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8754      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8755         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8756      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8757      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8758      &   ADtEAderx(1,1,1,1,1,2))
8759         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8760      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8761      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8762      &   ADtEA1derx(1,1,1,1,1,2))
8763         ENDIF
8764 C End 6-th order cumulants
8765         call transpose2(EUgder(1,1,l),auxmat(1,1))
8766         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8767         call transpose2(EUg(1,1,l),auxmat(1,1))
8768         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8769         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8770         do iii=1,2
8771           do kkk=1,5
8772             do lll=1,3
8773               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8774      &          EAEAderx(1,1,lll,kkk,iii,2))
8775             enddo
8776           enddo
8777         enddo
8778 C AEAb1 and AEAb2
8779 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8780 C They are needed only when the fifth- or the sixth-order cumulants are
8781 C indluded.
8782         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8783         call transpose2(AEA(1,1,1),auxmat(1,1))
8784         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8785         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8786         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8787         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8788         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8789         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8790         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8791         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8792         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8793         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8794         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8795         call transpose2(AEA(1,1,2),auxmat(1,1))
8796         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8797         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8798         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8799         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8800         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8801         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8802         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8803         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8804         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8805         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8806         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8807 C Calculate the Cartesian derivatives of the vectors.
8808         do iii=1,2
8809           do kkk=1,5
8810             do lll=1,3
8811               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8812               call matvec2(auxmat(1,1),b1(1,i),
8813      &          AEAb1derx(1,lll,kkk,iii,1,1))
8814               call matvec2(auxmat(1,1),Ub2(1,i),
8815      &          AEAb2derx(1,lll,kkk,iii,1,1))
8816               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8817      &          AEAb1derx(1,lll,kkk,iii,2,1))
8818               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8819      &          AEAb2derx(1,lll,kkk,iii,2,1))
8820               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8821               call matvec2(auxmat(1,1),b1(1,j),
8822      &          AEAb1derx(1,lll,kkk,iii,1,2))
8823               call matvec2(auxmat(1,1),Ub2(1,j),
8824      &          AEAb2derx(1,lll,kkk,iii,1,2))
8825               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8826      &          AEAb1derx(1,lll,kkk,iii,2,2))
8827               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8828      &          AEAb2derx(1,lll,kkk,iii,2,2))
8829             enddo
8830           enddo
8831         enddo
8832         ENDIF
8833 C End vectors
8834       else
8835 C Antiparallel orientation of the two CA-CA-CA frames.
8836         if (i.gt.1) then
8837           iti=itortyp(itype(i))
8838         else
8839           iti=ntortyp
8840         endif
8841         itk1=itortyp(itype(k+1))
8842         itl=itortyp(itype(l))
8843         itj=itortyp(itype(j))
8844         if (j.lt.nres-1) then
8845           itj1=itortyp(itype(j+1))
8846         else
8847           itj1=ntortyp
8848         endif
8849 C A2 kernel(j-1)T A1T
8850         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8851      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8852      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8853 C Following matrices are needed only for 6-th order cumulants
8854         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8855      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8856         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8857      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8858      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8859         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8860      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8861      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8862      &   ADtEAderx(1,1,1,1,1,1))
8863         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8864      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8865      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8866      &   ADtEA1derx(1,1,1,1,1,1))
8867         ENDIF
8868 C End 6-th order cumulants
8869         call transpose2(EUgder(1,1,k),auxmat(1,1))
8870         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8871         call transpose2(EUg(1,1,k),auxmat(1,1))
8872         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8873         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8874         do iii=1,2
8875           do kkk=1,5
8876             do lll=1,3
8877               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8878      &          EAEAderx(1,1,lll,kkk,iii,1))
8879             enddo
8880           enddo
8881         enddo
8882 C A2T kernel(i+1)T A1
8883         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8884      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8885      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8886 C Following matrices are needed only for 6-th order cumulants
8887         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8888      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8889         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8890      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8891      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8892         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8893      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8894      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8895      &   ADtEAderx(1,1,1,1,1,2))
8896         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8897      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8898      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8899      &   ADtEA1derx(1,1,1,1,1,2))
8900         ENDIF
8901 C End 6-th order cumulants
8902         call transpose2(EUgder(1,1,j),auxmat(1,1))
8903         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8904         call transpose2(EUg(1,1,j),auxmat(1,1))
8905         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8906         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8907         do iii=1,2
8908           do kkk=1,5
8909             do lll=1,3
8910               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8911      &          EAEAderx(1,1,lll,kkk,iii,2))
8912             enddo
8913           enddo
8914         enddo
8915 C AEAb1 and AEAb2
8916 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8917 C They are needed only when the fifth- or the sixth-order cumulants are
8918 C indluded.
8919         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8920      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8921         call transpose2(AEA(1,1,1),auxmat(1,1))
8922         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8923         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8924         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8925         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8926         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8927         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8928         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8929         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8930         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8931         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8932         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8933         call transpose2(AEA(1,1,2),auxmat(1,1))
8934         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8935         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8936         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8937         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8938         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8939         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8940         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8941         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8942         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8943         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8944         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8945 C Calculate the Cartesian derivatives of the vectors.
8946         do iii=1,2
8947           do kkk=1,5
8948             do lll=1,3
8949               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8950               call matvec2(auxmat(1,1),b1(1,i),
8951      &          AEAb1derx(1,lll,kkk,iii,1,1))
8952               call matvec2(auxmat(1,1),Ub2(1,i),
8953      &          AEAb2derx(1,lll,kkk,iii,1,1))
8954               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8955      &          AEAb1derx(1,lll,kkk,iii,2,1))
8956               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8957      &          AEAb2derx(1,lll,kkk,iii,2,1))
8958               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8959               call matvec2(auxmat(1,1),b1(1,l),
8960      &          AEAb1derx(1,lll,kkk,iii,1,2))
8961               call matvec2(auxmat(1,1),Ub2(1,l),
8962      &          AEAb2derx(1,lll,kkk,iii,1,2))
8963               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8964      &          AEAb1derx(1,lll,kkk,iii,2,2))
8965               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8966      &          AEAb2derx(1,lll,kkk,iii,2,2))
8967             enddo
8968           enddo
8969         enddo
8970         ENDIF
8971 C End vectors
8972       endif
8973       return
8974       end
8975 C---------------------------------------------------------------------------
8976       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8977      &  KK,KKderg,AKA,AKAderg,AKAderx)
8978       implicit none
8979       integer nderg
8980       logical transp
8981       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8982      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8983      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8984       integer iii,kkk,lll
8985       integer jjj,mmm
8986       logical lprn
8987       common /kutas/ lprn
8988       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8989       do iii=1,nderg
8990         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8991      &    AKAderg(1,1,iii))
8992       enddo
8993 cd      if (lprn) write (2,*) 'In kernel'
8994       do kkk=1,5
8995 cd        if (lprn) write (2,*) 'kkk=',kkk
8996         do lll=1,3
8997           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8998      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8999 cd          if (lprn) then
9000 cd            write (2,*) 'lll=',lll
9001 cd            write (2,*) 'iii=1'
9002 cd            do jjj=1,2
9003 cd              write (2,'(3(2f10.5),5x)')
9004 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9005 cd            enddo
9006 cd          endif
9007           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9008      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9009 cd          if (lprn) then
9010 cd            write (2,*) 'lll=',lll
9011 cd            write (2,*) 'iii=2'
9012 cd            do jjj=1,2
9013 cd              write (2,'(3(2f10.5),5x)')
9014 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9015 cd            enddo
9016 cd          endif
9017         enddo
9018       enddo
9019       return
9020       end
9021 C---------------------------------------------------------------------------
9022       double precision function eello4(i,j,k,l,jj,kk)
9023       implicit real*8 (a-h,o-z)
9024       include 'DIMENSIONS'
9025       include 'COMMON.IOUNITS'
9026       include 'COMMON.CHAIN'
9027       include 'COMMON.DERIV'
9028       include 'COMMON.INTERACT'
9029       include 'COMMON.CONTACTS'
9030       include 'COMMON.TORSION'
9031       include 'COMMON.VAR'
9032       include 'COMMON.GEO'
9033       double precision pizda(2,2),ggg1(3),ggg2(3)
9034 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9035 cd        eello4=0.0d0
9036 cd        return
9037 cd      endif
9038 cd      print *,'eello4:',i,j,k,l,jj,kk
9039 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9040 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9041 cold      eij=facont_hb(jj,i)
9042 cold      ekl=facont_hb(kk,k)
9043 cold      ekont=eij*ekl
9044       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9045 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9046       gcorr_loc(k-1)=gcorr_loc(k-1)
9047      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9048       if (l.eq.j+1) then
9049         gcorr_loc(l-1)=gcorr_loc(l-1)
9050      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9051       else
9052         gcorr_loc(j-1)=gcorr_loc(j-1)
9053      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9054       endif
9055       do iii=1,2
9056         do kkk=1,5
9057           do lll=1,3
9058             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9059      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9060 cd            derx(lll,kkk,iii)=0.0d0
9061           enddo
9062         enddo
9063       enddo
9064 cd      gcorr_loc(l-1)=0.0d0
9065 cd      gcorr_loc(j-1)=0.0d0
9066 cd      gcorr_loc(k-1)=0.0d0
9067 cd      eel4=1.0d0
9068 cd      write (iout,*)'Contacts have occurred for peptide groups',
9069 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9070 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9071       if (j.lt.nres-1) then
9072         j1=j+1
9073         j2=j-1
9074       else
9075         j1=j-1
9076         j2=j-2
9077       endif
9078       if (l.lt.nres-1) then
9079         l1=l+1
9080         l2=l-1
9081       else
9082         l1=l-1
9083         l2=l-2
9084       endif
9085       do ll=1,3
9086 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9087 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9088         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9089         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9090 cgrad        ghalf=0.5d0*ggg1(ll)
9091         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9092         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9093         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9094         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9095         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9096         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9097 cgrad        ghalf=0.5d0*ggg2(ll)
9098         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9099         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9100         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9101         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9102         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9103         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9104       enddo
9105 cgrad      do m=i+1,j-1
9106 cgrad        do ll=1,3
9107 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9108 cgrad        enddo
9109 cgrad      enddo
9110 cgrad      do m=k+1,l-1
9111 cgrad        do ll=1,3
9112 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9113 cgrad        enddo
9114 cgrad      enddo
9115 cgrad      do m=i+2,j2
9116 cgrad        do ll=1,3
9117 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9118 cgrad        enddo
9119 cgrad      enddo
9120 cgrad      do m=k+2,l2
9121 cgrad        do ll=1,3
9122 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9123 cgrad        enddo
9124 cgrad      enddo
9125 cd      do iii=1,nres-3
9126 cd        write (2,*) iii,gcorr_loc(iii)
9127 cd      enddo
9128       eello4=ekont*eel4
9129 cd      write (2,*) 'ekont',ekont
9130 cd      write (iout,*) 'eello4',ekont*eel4
9131       return
9132       end
9133 C---------------------------------------------------------------------------
9134       double precision function eello5(i,j,k,l,jj,kk)
9135       implicit real*8 (a-h,o-z)
9136       include 'DIMENSIONS'
9137       include 'COMMON.IOUNITS'
9138       include 'COMMON.CHAIN'
9139       include 'COMMON.DERIV'
9140       include 'COMMON.INTERACT'
9141       include 'COMMON.CONTACTS'
9142       include 'COMMON.TORSION'
9143       include 'COMMON.VAR'
9144       include 'COMMON.GEO'
9145       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9146       double precision ggg1(3),ggg2(3)
9147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9148 C                                                                              C
9149 C                            Parallel chains                                   C
9150 C                                                                              C
9151 C          o             o                   o             o                   C
9152 C         /l\           / \             \   / \           / \   /              C
9153 C        /   \         /   \             \ /   \         /   \ /               C
9154 C       j| o |l1       | o |              o| o |         | o |o                C
9155 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9156 C      \i/   \         /   \ /             /   \         /   \                 C
9157 C       o    k1             o                                                  C
9158 C         (I)          (II)                (III)          (IV)                 C
9159 C                                                                              C
9160 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9161 C                                                                              C
9162 C                            Antiparallel chains                               C
9163 C                                                                              C
9164 C          o             o                   o             o                   C
9165 C         /j\           / \             \   / \           / \   /              C
9166 C        /   \         /   \             \ /   \         /   \ /               C
9167 C      j1| o |l        | o |              o| o |         | o |o                C
9168 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9169 C      \i/   \         /   \ /             /   \         /   \                 C
9170 C       o     k1            o                                                  C
9171 C         (I)          (II)                (III)          (IV)                 C
9172 C                                                                              C
9173 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9174 C                                                                              C
9175 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9176 C                                                                              C
9177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9178 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9179 cd        eello5=0.0d0
9180 cd        return
9181 cd      endif
9182 cd      write (iout,*)
9183 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9184 cd     &   ' and',k,l
9185       itk=itortyp(itype(k))
9186       itl=itortyp(itype(l))
9187       itj=itortyp(itype(j))
9188       eello5_1=0.0d0
9189       eello5_2=0.0d0
9190       eello5_3=0.0d0
9191       eello5_4=0.0d0
9192 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9193 cd     &   eel5_3_num,eel5_4_num)
9194       do iii=1,2
9195         do kkk=1,5
9196           do lll=1,3
9197             derx(lll,kkk,iii)=0.0d0
9198           enddo
9199         enddo
9200       enddo
9201 cd      eij=facont_hb(jj,i)
9202 cd      ekl=facont_hb(kk,k)
9203 cd      ekont=eij*ekl
9204 cd      write (iout,*)'Contacts have occurred for peptide groups',
9205 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9206 cd      goto 1111
9207 C Contribution from the graph I.
9208 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9209 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9210       call transpose2(EUg(1,1,k),auxmat(1,1))
9211       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9212       vv(1)=pizda(1,1)-pizda(2,2)
9213       vv(2)=pizda(1,2)+pizda(2,1)
9214       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9215      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9216 C Explicit gradient in virtual-dihedral angles.
9217       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9218      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9219      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9220       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9221       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9222       vv(1)=pizda(1,1)-pizda(2,2)
9223       vv(2)=pizda(1,2)+pizda(2,1)
9224       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9225      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9226      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9227       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9228       vv(1)=pizda(1,1)-pizda(2,2)
9229       vv(2)=pizda(1,2)+pizda(2,1)
9230       if (l.eq.j+1) then
9231         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9232      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9233      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9234       else
9235         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9236      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9237      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9238       endif
9239 C Cartesian gradient
9240       do iii=1,2
9241         do kkk=1,5
9242           do lll=1,3
9243             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9244      &        pizda(1,1))
9245             vv(1)=pizda(1,1)-pizda(2,2)
9246             vv(2)=pizda(1,2)+pizda(2,1)
9247             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9248      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9249      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9250           enddo
9251         enddo
9252       enddo
9253 c      goto 1112
9254 c1111  continue
9255 C Contribution from graph II
9256       call transpose2(EE(1,1,itk),auxmat(1,1))
9257       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9258       vv(1)=pizda(1,1)+pizda(2,2)
9259       vv(2)=pizda(2,1)-pizda(1,2)
9260       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9261      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9262 C Explicit gradient in virtual-dihedral angles.
9263       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9264      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9265       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9266       vv(1)=pizda(1,1)+pizda(2,2)
9267       vv(2)=pizda(2,1)-pizda(1,2)
9268       if (l.eq.j+1) then
9269         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9270      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9271      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9272       else
9273         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9274      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9275      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9276       endif
9277 C Cartesian gradient
9278       do iii=1,2
9279         do kkk=1,5
9280           do lll=1,3
9281             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9282      &        pizda(1,1))
9283             vv(1)=pizda(1,1)+pizda(2,2)
9284             vv(2)=pizda(2,1)-pizda(1,2)
9285             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9286      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9287      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9288           enddo
9289         enddo
9290       enddo
9291 cd      goto 1112
9292 cd1111  continue
9293       if (l.eq.j+1) then
9294 cd        goto 1110
9295 C Parallel orientation
9296 C Contribution from graph III
9297         call transpose2(EUg(1,1,l),auxmat(1,1))
9298         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9299         vv(1)=pizda(1,1)-pizda(2,2)
9300         vv(2)=pizda(1,2)+pizda(2,1)
9301         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9302      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9303 C Explicit gradient in virtual-dihedral angles.
9304         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9305      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9306      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9307         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9308         vv(1)=pizda(1,1)-pizda(2,2)
9309         vv(2)=pizda(1,2)+pizda(2,1)
9310         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9311      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9312      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9313         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9314         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9315         vv(1)=pizda(1,1)-pizda(2,2)
9316         vv(2)=pizda(1,2)+pizda(2,1)
9317         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9318      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9319      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9320 C Cartesian gradient
9321         do iii=1,2
9322           do kkk=1,5
9323             do lll=1,3
9324               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9325      &          pizda(1,1))
9326               vv(1)=pizda(1,1)-pizda(2,2)
9327               vv(2)=pizda(1,2)+pizda(2,1)
9328               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9329      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9330      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9331             enddo
9332           enddo
9333         enddo
9334 cd        goto 1112
9335 C Contribution from graph IV
9336 cd1110    continue
9337         call transpose2(EE(1,1,itl),auxmat(1,1))
9338         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9339         vv(1)=pizda(1,1)+pizda(2,2)
9340         vv(2)=pizda(2,1)-pizda(1,2)
9341         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9342      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9343 C Explicit gradient in virtual-dihedral angles.
9344         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9345      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9346         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9347         vv(1)=pizda(1,1)+pizda(2,2)
9348         vv(2)=pizda(2,1)-pizda(1,2)
9349         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9350      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9351      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9352 C Cartesian gradient
9353         do iii=1,2
9354           do kkk=1,5
9355             do lll=1,3
9356               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9357      &          pizda(1,1))
9358               vv(1)=pizda(1,1)+pizda(2,2)
9359               vv(2)=pizda(2,1)-pizda(1,2)
9360               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9361      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9362      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9363             enddo
9364           enddo
9365         enddo
9366       else
9367 C Antiparallel orientation
9368 C Contribution from graph III
9369 c        goto 1110
9370         call transpose2(EUg(1,1,j),auxmat(1,1))
9371         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9372         vv(1)=pizda(1,1)-pizda(2,2)
9373         vv(2)=pizda(1,2)+pizda(2,1)
9374         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9375      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9376 C Explicit gradient in virtual-dihedral angles.
9377         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9378      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9379      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9380         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9381         vv(1)=pizda(1,1)-pizda(2,2)
9382         vv(2)=pizda(1,2)+pizda(2,1)
9383         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9384      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9385      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9386         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9387         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9388         vv(1)=pizda(1,1)-pizda(2,2)
9389         vv(2)=pizda(1,2)+pizda(2,1)
9390         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9391      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9392      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9393 C Cartesian gradient
9394         do iii=1,2
9395           do kkk=1,5
9396             do lll=1,3
9397               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9398      &          pizda(1,1))
9399               vv(1)=pizda(1,1)-pizda(2,2)
9400               vv(2)=pizda(1,2)+pizda(2,1)
9401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9402      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9403      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9404             enddo
9405           enddo
9406         enddo
9407 cd        goto 1112
9408 C Contribution from graph IV
9409 1110    continue
9410         call transpose2(EE(1,1,itj),auxmat(1,1))
9411         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9412         vv(1)=pizda(1,1)+pizda(2,2)
9413         vv(2)=pizda(2,1)-pizda(1,2)
9414         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9415      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9416 C Explicit gradient in virtual-dihedral angles.
9417         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9418      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9419         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9420         vv(1)=pizda(1,1)+pizda(2,2)
9421         vv(2)=pizda(2,1)-pizda(1,2)
9422         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9423      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9424      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9425 C Cartesian gradient
9426         do iii=1,2
9427           do kkk=1,5
9428             do lll=1,3
9429               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9430      &          pizda(1,1))
9431               vv(1)=pizda(1,1)+pizda(2,2)
9432               vv(2)=pizda(2,1)-pizda(1,2)
9433               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9434      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9435      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9436             enddo
9437           enddo
9438         enddo
9439       endif
9440 1112  continue
9441       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9442 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9443 cd        write (2,*) 'ijkl',i,j,k,l
9444 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9445 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9446 cd      endif
9447 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9448 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9449 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9450 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9451       if (j.lt.nres-1) then
9452         j1=j+1
9453         j2=j-1
9454       else
9455         j1=j-1
9456         j2=j-2
9457       endif
9458       if (l.lt.nres-1) then
9459         l1=l+1
9460         l2=l-1
9461       else
9462         l1=l-1
9463         l2=l-2
9464       endif
9465 cd      eij=1.0d0
9466 cd      ekl=1.0d0
9467 cd      ekont=1.0d0
9468 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9469 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9470 C        summed up outside the subrouine as for the other subroutines
9471 C        handling long-range interactions. The old code is commented out
9472 C        with "cgrad" to keep track of changes.
9473       do ll=1,3
9474 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9475 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9476         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9477         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9478 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9479 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9480 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9481 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9482 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9483 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9484 c     &   gradcorr5ij,
9485 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9486 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9487 cgrad        ghalf=0.5d0*ggg1(ll)
9488 cd        ghalf=0.0d0
9489         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9490         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9491         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9492         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9493         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9494         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9495 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9496 cgrad        ghalf=0.5d0*ggg2(ll)
9497 cd        ghalf=0.0d0
9498         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9499         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9500         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9501         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9502         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9503         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9504       enddo
9505 cd      goto 1112
9506 cgrad      do m=i+1,j-1
9507 cgrad        do ll=1,3
9508 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9509 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9510 cgrad        enddo
9511 cgrad      enddo
9512 cgrad      do m=k+1,l-1
9513 cgrad        do ll=1,3
9514 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9515 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9516 cgrad        enddo
9517 cgrad      enddo
9518 c1112  continue
9519 cgrad      do m=i+2,j2
9520 cgrad        do ll=1,3
9521 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9522 cgrad        enddo
9523 cgrad      enddo
9524 cgrad      do m=k+2,l2
9525 cgrad        do ll=1,3
9526 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9527 cgrad        enddo
9528 cgrad      enddo
9529 cd      do iii=1,nres-3
9530 cd        write (2,*) iii,g_corr5_loc(iii)
9531 cd      enddo
9532       eello5=ekont*eel5
9533 cd      write (2,*) 'ekont',ekont
9534 cd      write (iout,*) 'eello5',ekont*eel5
9535       return
9536       end
9537 c--------------------------------------------------------------------------
9538       double precision function eello6(i,j,k,l,jj,kk)
9539       implicit real*8 (a-h,o-z)
9540       include 'DIMENSIONS'
9541       include 'COMMON.IOUNITS'
9542       include 'COMMON.CHAIN'
9543       include 'COMMON.DERIV'
9544       include 'COMMON.INTERACT'
9545       include 'COMMON.CONTACTS'
9546       include 'COMMON.TORSION'
9547       include 'COMMON.VAR'
9548       include 'COMMON.GEO'
9549       include 'COMMON.FFIELD'
9550       double precision ggg1(3),ggg2(3)
9551 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9552 cd        eello6=0.0d0
9553 cd        return
9554 cd      endif
9555 cd      write (iout,*)
9556 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9557 cd     &   ' and',k,l
9558       eello6_1=0.0d0
9559       eello6_2=0.0d0
9560       eello6_3=0.0d0
9561       eello6_4=0.0d0
9562       eello6_5=0.0d0
9563       eello6_6=0.0d0
9564 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9565 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9566       do iii=1,2
9567         do kkk=1,5
9568           do lll=1,3
9569             derx(lll,kkk,iii)=0.0d0
9570           enddo
9571         enddo
9572       enddo
9573 cd      eij=facont_hb(jj,i)
9574 cd      ekl=facont_hb(kk,k)
9575 cd      ekont=eij*ekl
9576 cd      eij=1.0d0
9577 cd      ekl=1.0d0
9578 cd      ekont=1.0d0
9579       if (l.eq.j+1) then
9580         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9581         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9582         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9583         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9584         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9585         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9586       else
9587         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9588         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9589         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9590         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9591         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9592           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9593         else
9594           eello6_5=0.0d0
9595         endif
9596         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9597       endif
9598 C If turn contributions are considered, they will be handled separately.
9599       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9600 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9601 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9602 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9603 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9604 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9605 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9606 cd      goto 1112
9607       if (j.lt.nres-1) then
9608         j1=j+1
9609         j2=j-1
9610       else
9611         j1=j-1
9612         j2=j-2
9613       endif
9614       if (l.lt.nres-1) then
9615         l1=l+1
9616         l2=l-1
9617       else
9618         l1=l-1
9619         l2=l-2
9620       endif
9621       do ll=1,3
9622 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9623 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9624 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9625 cgrad        ghalf=0.5d0*ggg1(ll)
9626 cd        ghalf=0.0d0
9627         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9628         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9629         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9630         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9631         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9632         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9633         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9634         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9635 cgrad        ghalf=0.5d0*ggg2(ll)
9636 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9637 cd        ghalf=0.0d0
9638         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9639         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9640         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9641         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9642         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9643         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9644       enddo
9645 cd      goto 1112
9646 cgrad      do m=i+1,j-1
9647 cgrad        do ll=1,3
9648 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9649 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9650 cgrad        enddo
9651 cgrad      enddo
9652 cgrad      do m=k+1,l-1
9653 cgrad        do ll=1,3
9654 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9655 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9656 cgrad        enddo
9657 cgrad      enddo
9658 cgrad1112  continue
9659 cgrad      do m=i+2,j2
9660 cgrad        do ll=1,3
9661 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9662 cgrad        enddo
9663 cgrad      enddo
9664 cgrad      do m=k+2,l2
9665 cgrad        do ll=1,3
9666 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9667 cgrad        enddo
9668 cgrad      enddo
9669 cd      do iii=1,nres-3
9670 cd        write (2,*) iii,g_corr6_loc(iii)
9671 cd      enddo
9672       eello6=ekont*eel6
9673 cd      write (2,*) 'ekont',ekont
9674 cd      write (iout,*) 'eello6',ekont*eel6
9675       return
9676       end
9677 c--------------------------------------------------------------------------
9678       double precision function eello6_graph1(i,j,k,l,imat,swap)
9679       implicit real*8 (a-h,o-z)
9680       include 'DIMENSIONS'
9681       include 'COMMON.IOUNITS'
9682       include 'COMMON.CHAIN'
9683       include 'COMMON.DERIV'
9684       include 'COMMON.INTERACT'
9685       include 'COMMON.CONTACTS'
9686       include 'COMMON.TORSION'
9687       include 'COMMON.VAR'
9688       include 'COMMON.GEO'
9689       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9690       logical swap
9691       logical lprn
9692       common /kutas/ lprn
9693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9694 C                                                                              C
9695 C      Parallel       Antiparallel                                             C
9696 C                                                                              C
9697 C          o             o                                                     C
9698 C         /l\           /j\                                                    C
9699 C        /   \         /   \                                                   C
9700 C       /| o |         | o |\                                                  C
9701 C     \ j|/k\|  /   \  |/k\|l /                                                C
9702 C      \ /   \ /     \ /   \ /                                                 C
9703 C       o     o       o     o                                                  C
9704 C       i             i                                                        C
9705 C                                                                              C
9706 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9707       itk=itortyp(itype(k))
9708       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9709       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9710       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9711       call transpose2(EUgC(1,1,k),auxmat(1,1))
9712       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9713       vv1(1)=pizda1(1,1)-pizda1(2,2)
9714       vv1(2)=pizda1(1,2)+pizda1(2,1)
9715       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9716       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9717       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9718       s5=scalar2(vv(1),Dtobr2(1,i))
9719 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9720       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9721       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9722      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9723      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9724      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9725      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9726      & +scalar2(vv(1),Dtobr2der(1,i)))
9727       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9728       vv1(1)=pizda1(1,1)-pizda1(2,2)
9729       vv1(2)=pizda1(1,2)+pizda1(2,1)
9730       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9731       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9732       if (l.eq.j+1) then
9733         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9734      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9735      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9736      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9737      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9738       else
9739         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9740      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9741      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9742      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9743      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9744       endif
9745       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9746       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9747       vv1(1)=pizda1(1,1)-pizda1(2,2)
9748       vv1(2)=pizda1(1,2)+pizda1(2,1)
9749       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9750      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9751      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9752      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9753       do iii=1,2
9754         if (swap) then
9755           ind=3-iii
9756         else
9757           ind=iii
9758         endif
9759         do kkk=1,5
9760           do lll=1,3
9761             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9762             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9763             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9764             call transpose2(EUgC(1,1,k),auxmat(1,1))
9765             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9766      &        pizda1(1,1))
9767             vv1(1)=pizda1(1,1)-pizda1(2,2)
9768             vv1(2)=pizda1(1,2)+pizda1(2,1)
9769             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9770             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9771      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9772             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9773      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9774             s5=scalar2(vv(1),Dtobr2(1,i))
9775             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9776           enddo
9777         enddo
9778       enddo
9779       return
9780       end
9781 c----------------------------------------------------------------------------
9782       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9783       implicit real*8 (a-h,o-z)
9784       include 'DIMENSIONS'
9785       include 'COMMON.IOUNITS'
9786       include 'COMMON.CHAIN'
9787       include 'COMMON.DERIV'
9788       include 'COMMON.INTERACT'
9789       include 'COMMON.CONTACTS'
9790       include 'COMMON.TORSION'
9791       include 'COMMON.VAR'
9792       include 'COMMON.GEO'
9793       logical swap
9794       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9795      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9796       logical lprn
9797       common /kutas/ lprn
9798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9799 C                                                                              C
9800 C      Parallel       Antiparallel                                             C
9801 C                                                                              C
9802 C          o             o                                                     C
9803 C     \   /l\           /j\   /                                                C
9804 C      \ /   \         /   \ /                                                 C
9805 C       o| o |         | o |o                                                  C
9806 C     \ j|/k\|      \  |/k\|l                                                  C
9807 C      \ /   \       \ /   \                                                   C
9808 C       o             o                                                        C
9809 C       i             i                                                        C
9810 C                                                                              C
9811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9812 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9813 C AL 7/4/01 s1 would occur in the sixth-order moment,
9814 C           but not in a cluster cumulant
9815 #ifdef MOMENT
9816       s1=dip(1,jj,i)*dip(1,kk,k)
9817 #endif
9818       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9819       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9820       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9821       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9822       call transpose2(EUg(1,1,k),auxmat(1,1))
9823       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9824       vv(1)=pizda(1,1)-pizda(2,2)
9825       vv(2)=pizda(1,2)+pizda(2,1)
9826       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9827 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9828 #ifdef MOMENT
9829       eello6_graph2=-(s1+s2+s3+s4)
9830 #else
9831       eello6_graph2=-(s2+s3+s4)
9832 #endif
9833 c      eello6_graph2=-s3
9834 C Derivatives in gamma(i-1)
9835       if (i.gt.1) then
9836 #ifdef MOMENT
9837         s1=dipderg(1,jj,i)*dip(1,kk,k)
9838 #endif
9839         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9840         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9841         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9842         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9843 #ifdef MOMENT
9844         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9845 #else
9846         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9847 #endif
9848 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9849       endif
9850 C Derivatives in gamma(k-1)
9851 #ifdef MOMENT
9852       s1=dip(1,jj,i)*dipderg(1,kk,k)
9853 #endif
9854       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9855       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9856       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9857       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9858       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9859       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9860       vv(1)=pizda(1,1)-pizda(2,2)
9861       vv(2)=pizda(1,2)+pizda(2,1)
9862       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9863 #ifdef MOMENT
9864       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9865 #else
9866       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9867 #endif
9868 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9869 C Derivatives in gamma(j-1) or gamma(l-1)
9870       if (j.gt.1) then
9871 #ifdef MOMENT
9872         s1=dipderg(3,jj,i)*dip(1,kk,k)
9873 #endif
9874         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9875         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9876         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9877         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9878         vv(1)=pizda(1,1)-pizda(2,2)
9879         vv(2)=pizda(1,2)+pizda(2,1)
9880         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9881 #ifdef MOMENT
9882         if (swap) then
9883           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9884         else
9885           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9886         endif
9887 #endif
9888         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9889 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9890       endif
9891 C Derivatives in gamma(l-1) or gamma(j-1)
9892       if (l.gt.1) then
9893 #ifdef MOMENT
9894         s1=dip(1,jj,i)*dipderg(3,kk,k)
9895 #endif
9896         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9897         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9898         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9899         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9900         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9901         vv(1)=pizda(1,1)-pizda(2,2)
9902         vv(2)=pizda(1,2)+pizda(2,1)
9903         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9904 #ifdef MOMENT
9905         if (swap) then
9906           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9907         else
9908           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9909         endif
9910 #endif
9911         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9912 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9913       endif
9914 C Cartesian derivatives.
9915       if (lprn) then
9916         write (2,*) 'In eello6_graph2'
9917         do iii=1,2
9918           write (2,*) 'iii=',iii
9919           do kkk=1,5
9920             write (2,*) 'kkk=',kkk
9921             do jjj=1,2
9922               write (2,'(3(2f10.5),5x)')
9923      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9924             enddo
9925           enddo
9926         enddo
9927       endif
9928       do iii=1,2
9929         do kkk=1,5
9930           do lll=1,3
9931 #ifdef MOMENT
9932             if (iii.eq.1) then
9933               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9934             else
9935               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9936             endif
9937 #endif
9938             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9939      &        auxvec(1))
9940             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9941             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9942      &        auxvec(1))
9943             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9944             call transpose2(EUg(1,1,k),auxmat(1,1))
9945             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9946      &        pizda(1,1))
9947             vv(1)=pizda(1,1)-pizda(2,2)
9948             vv(2)=pizda(1,2)+pizda(2,1)
9949             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9950 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9951 #ifdef MOMENT
9952             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9953 #else
9954             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9955 #endif
9956             if (swap) then
9957               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9958             else
9959               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9960             endif
9961           enddo
9962         enddo
9963       enddo
9964       return
9965       end
9966 c----------------------------------------------------------------------------
9967       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9968       implicit real*8 (a-h,o-z)
9969       include 'DIMENSIONS'
9970       include 'COMMON.IOUNITS'
9971       include 'COMMON.CHAIN'
9972       include 'COMMON.DERIV'
9973       include 'COMMON.INTERACT'
9974       include 'COMMON.CONTACTS'
9975       include 'COMMON.TORSION'
9976       include 'COMMON.VAR'
9977       include 'COMMON.GEO'
9978       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9979       logical swap
9980 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9981 C                                                                              C
9982 C      Parallel       Antiparallel                                             C
9983 C                                                                              C
9984 C          o             o                                                     C
9985 C         /l\   /   \   /j\                                                    C
9986 C        /   \ /     \ /   \                                                   C
9987 C       /| o |o       o| o |\                                                  C
9988 C       j|/k\|  /      |/k\|l /                                                C
9989 C        /   \ /       /   \ /                                                 C
9990 C       /     o       /     o                                                  C
9991 C       i             i                                                        C
9992 C                                                                              C
9993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9994 C
9995 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9996 C           energy moment and not to the cluster cumulant.
9997       iti=itortyp(itype(i))
9998       if (j.lt.nres-1) then
9999         itj1=itortyp(itype(j+1))
10000       else
10001         itj1=ntortyp
10002       endif
10003       itk=itortyp(itype(k))
10004       itk1=itortyp(itype(k+1))
10005       if (l.lt.nres-1) then
10006         itl1=itortyp(itype(l+1))
10007       else
10008         itl1=ntortyp
10009       endif
10010 #ifdef MOMENT
10011       s1=dip(4,jj,i)*dip(4,kk,k)
10012 #endif
10013       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10014       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10015       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10016       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10017       call transpose2(EE(1,1,itk),auxmat(1,1))
10018       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10019       vv(1)=pizda(1,1)+pizda(2,2)
10020       vv(2)=pizda(2,1)-pizda(1,2)
10021       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10022 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10023 cd     & "sum",-(s2+s3+s4)
10024 #ifdef MOMENT
10025       eello6_graph3=-(s1+s2+s3+s4)
10026 #else
10027       eello6_graph3=-(s2+s3+s4)
10028 #endif
10029 c      eello6_graph3=-s4
10030 C Derivatives in gamma(k-1)
10031       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10032       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10033       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10034       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10035 C Derivatives in gamma(l-1)
10036       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10037       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10038       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10039       vv(1)=pizda(1,1)+pizda(2,2)
10040       vv(2)=pizda(2,1)-pizda(1,2)
10041       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10042       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10043 C Cartesian derivatives.
10044       do iii=1,2
10045         do kkk=1,5
10046           do lll=1,3
10047 #ifdef MOMENT
10048             if (iii.eq.1) then
10049               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10050             else
10051               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10052             endif
10053 #endif
10054             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10055      &        auxvec(1))
10056             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10057             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10058      &        auxvec(1))
10059             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10060             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10061      &        pizda(1,1))
10062             vv(1)=pizda(1,1)+pizda(2,2)
10063             vv(2)=pizda(2,1)-pizda(1,2)
10064             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10065 #ifdef MOMENT
10066             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10067 #else
10068             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10069 #endif
10070             if (swap) then
10071               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10072             else
10073               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10074             endif
10075 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10076           enddo
10077         enddo
10078       enddo
10079       return
10080       end
10081 c----------------------------------------------------------------------------
10082       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10083       implicit real*8 (a-h,o-z)
10084       include 'DIMENSIONS'
10085       include 'COMMON.IOUNITS'
10086       include 'COMMON.CHAIN'
10087       include 'COMMON.DERIV'
10088       include 'COMMON.INTERACT'
10089       include 'COMMON.CONTACTS'
10090       include 'COMMON.TORSION'
10091       include 'COMMON.VAR'
10092       include 'COMMON.GEO'
10093       include 'COMMON.FFIELD'
10094       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10095      & auxvec1(2),auxmat1(2,2)
10096       logical swap
10097 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10098 C                                                                              C
10099 C      Parallel       Antiparallel                                             C
10100 C                                                                              C
10101 C          o             o                                                     C
10102 C         /l\   /   \   /j\                                                    C
10103 C        /   \ /     \ /   \                                                   C
10104 C       /| o |o       o| o |\                                                  C
10105 C     \ j|/k\|      \  |/k\|l                                                  C
10106 C      \ /   \       \ /   \                                                   C
10107 C       o     \       o     \                                                  C
10108 C       i             i                                                        C
10109 C                                                                              C
10110 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10111 C
10112 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10113 C           energy moment and not to the cluster cumulant.
10114 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10115       iti=itortyp(itype(i))
10116       itj=itortyp(itype(j))
10117       if (j.lt.nres-1) then
10118         itj1=itortyp(itype(j+1))
10119       else
10120         itj1=ntortyp
10121       endif
10122       itk=itortyp(itype(k))
10123       if (k.lt.nres-1) then
10124         itk1=itortyp(itype(k+1))
10125       else
10126         itk1=ntortyp
10127       endif
10128       itl=itortyp(itype(l))
10129       if (l.lt.nres-1) then
10130         itl1=itortyp(itype(l+1))
10131       else
10132         itl1=ntortyp
10133       endif
10134 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10135 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10136 cd     & ' itl',itl,' itl1',itl1
10137 #ifdef MOMENT
10138       if (imat.eq.1) then
10139         s1=dip(3,jj,i)*dip(3,kk,k)
10140       else
10141         s1=dip(2,jj,j)*dip(2,kk,l)
10142       endif
10143 #endif
10144       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10145       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10146       if (j.eq.l+1) then
10147         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10148         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10149       else
10150         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10151         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10152       endif
10153       call transpose2(EUg(1,1,k),auxmat(1,1))
10154       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10155       vv(1)=pizda(1,1)-pizda(2,2)
10156       vv(2)=pizda(2,1)+pizda(1,2)
10157       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10158 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10159 #ifdef MOMENT
10160       eello6_graph4=-(s1+s2+s3+s4)
10161 #else
10162       eello6_graph4=-(s2+s3+s4)
10163 #endif
10164 C Derivatives in gamma(i-1)
10165       if (i.gt.1) then
10166 #ifdef MOMENT
10167         if (imat.eq.1) then
10168           s1=dipderg(2,jj,i)*dip(3,kk,k)
10169         else
10170           s1=dipderg(4,jj,j)*dip(2,kk,l)
10171         endif
10172 #endif
10173         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10174         if (j.eq.l+1) then
10175           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10176           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10177         else
10178           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10179           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10180         endif
10181         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10182         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10183 cd          write (2,*) 'turn6 derivatives'
10184 #ifdef MOMENT
10185           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10186 #else
10187           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10188 #endif
10189         else
10190 #ifdef MOMENT
10191           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10192 #else
10193           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10194 #endif
10195         endif
10196       endif
10197 C Derivatives in gamma(k-1)
10198 #ifdef MOMENT
10199       if (imat.eq.1) then
10200         s1=dip(3,jj,i)*dipderg(2,kk,k)
10201       else
10202         s1=dip(2,jj,j)*dipderg(4,kk,l)
10203       endif
10204 #endif
10205       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10206       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10207       if (j.eq.l+1) then
10208         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10209         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10210       else
10211         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10212         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10213       endif
10214       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10215       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10216       vv(1)=pizda(1,1)-pizda(2,2)
10217       vv(2)=pizda(2,1)+pizda(1,2)
10218       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10219       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10220 #ifdef MOMENT
10221         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10222 #else
10223         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10224 #endif
10225       else
10226 #ifdef MOMENT
10227         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10228 #else
10229         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10230 #endif
10231       endif
10232 C Derivatives in gamma(j-1) or gamma(l-1)
10233       if (l.eq.j+1 .and. l.gt.1) then
10234         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10235         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10236         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10237         vv(1)=pizda(1,1)-pizda(2,2)
10238         vv(2)=pizda(2,1)+pizda(1,2)
10239         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10240         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10241       else if (j.gt.1) then
10242         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10243         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10244         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10245         vv(1)=pizda(1,1)-pizda(2,2)
10246         vv(2)=pizda(2,1)+pizda(1,2)
10247         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10248         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10249           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10250         else
10251           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10252         endif
10253       endif
10254 C Cartesian derivatives.
10255       do iii=1,2
10256         do kkk=1,5
10257           do lll=1,3
10258 #ifdef MOMENT
10259             if (iii.eq.1) then
10260               if (imat.eq.1) then
10261                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10262               else
10263                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10264               endif
10265             else
10266               if (imat.eq.1) then
10267                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10268               else
10269                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10270               endif
10271             endif
10272 #endif
10273             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10274      &        auxvec(1))
10275             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10276             if (j.eq.l+1) then
10277               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10278      &          b1(1,j+1),auxvec(1))
10279               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10280             else
10281               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10282      &          b1(1,l+1),auxvec(1))
10283               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10284             endif
10285             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10286      &        pizda(1,1))
10287             vv(1)=pizda(1,1)-pizda(2,2)
10288             vv(2)=pizda(2,1)+pizda(1,2)
10289             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10290             if (swap) then
10291               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10292 #ifdef MOMENT
10293                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10294      &             -(s1+s2+s4)
10295 #else
10296                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10297      &             -(s2+s4)
10298 #endif
10299                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10300               else
10301 #ifdef MOMENT
10302                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10303 #else
10304                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10305 #endif
10306                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10307               endif
10308             else
10309 #ifdef MOMENT
10310               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10311 #else
10312               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10313 #endif
10314               if (l.eq.j+1) then
10315                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10316               else
10317                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10318               endif
10319             endif
10320           enddo
10321         enddo
10322       enddo
10323       return
10324       end
10325 c----------------------------------------------------------------------------
10326       double precision function eello_turn6(i,jj,kk)
10327       implicit real*8 (a-h,o-z)
10328       include 'DIMENSIONS'
10329       include 'COMMON.IOUNITS'
10330       include 'COMMON.CHAIN'
10331       include 'COMMON.DERIV'
10332       include 'COMMON.INTERACT'
10333       include 'COMMON.CONTACTS'
10334       include 'COMMON.TORSION'
10335       include 'COMMON.VAR'
10336       include 'COMMON.GEO'
10337       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10338      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10339      &  ggg1(3),ggg2(3)
10340       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10341      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10342 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10343 C           the respective energy moment and not to the cluster cumulant.
10344       s1=0.0d0
10345       s8=0.0d0
10346       s13=0.0d0
10347 c
10348       eello_turn6=0.0d0
10349       j=i+4
10350       k=i+1
10351       l=i+3
10352       iti=itortyp(itype(i))
10353       itk=itortyp(itype(k))
10354       itk1=itortyp(itype(k+1))
10355       itl=itortyp(itype(l))
10356       itj=itortyp(itype(j))
10357 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10358 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10359 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10360 cd        eello6=0.0d0
10361 cd        return
10362 cd      endif
10363 cd      write (iout,*)
10364 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10365 cd     &   ' and',k,l
10366 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10367       do iii=1,2
10368         do kkk=1,5
10369           do lll=1,3
10370             derx_turn(lll,kkk,iii)=0.0d0
10371           enddo
10372         enddo
10373       enddo
10374 cd      eij=1.0d0
10375 cd      ekl=1.0d0
10376 cd      ekont=1.0d0
10377       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10378 cd      eello6_5=0.0d0
10379 cd      write (2,*) 'eello6_5',eello6_5
10380 #ifdef MOMENT
10381       call transpose2(AEA(1,1,1),auxmat(1,1))
10382       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10383       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10384       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10385 #endif
10386       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10387       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10388       s2 = scalar2(b1(1,k),vtemp1(1))
10389 #ifdef MOMENT
10390       call transpose2(AEA(1,1,2),atemp(1,1))
10391       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10392       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10393       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10394 #endif
10395       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10396       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10397       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10398 #ifdef MOMENT
10399       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10400       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10401       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10402       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10403       ss13 = scalar2(b1(1,k),vtemp4(1))
10404       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10405 #endif
10406 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10407 c      s1=0.0d0
10408 c      s2=0.0d0
10409 c      s8=0.0d0
10410 c      s12=0.0d0
10411 c      s13=0.0d0
10412       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10413 C Derivatives in gamma(i+2)
10414       s1d =0.0d0
10415       s8d =0.0d0
10416 #ifdef MOMENT
10417       call transpose2(AEA(1,1,1),auxmatd(1,1))
10418       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10419       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10420       call transpose2(AEAderg(1,1,2),atempd(1,1))
10421       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10422       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10423 #endif
10424       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10425       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10426       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10427 c      s1d=0.0d0
10428 c      s2d=0.0d0
10429 c      s8d=0.0d0
10430 c      s12d=0.0d0
10431 c      s13d=0.0d0
10432       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10433 C Derivatives in gamma(i+3)
10434 #ifdef MOMENT
10435       call transpose2(AEA(1,1,1),auxmatd(1,1))
10436       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10437       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10438       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10439 #endif
10440       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10441       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10442       s2d = scalar2(b1(1,k),vtemp1d(1))
10443 #ifdef MOMENT
10444       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10445       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10446 #endif
10447       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10448 #ifdef MOMENT
10449       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10450       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10451       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10452 #endif
10453 c      s1d=0.0d0
10454 c      s2d=0.0d0
10455 c      s8d=0.0d0
10456 c      s12d=0.0d0
10457 c      s13d=0.0d0
10458 #ifdef MOMENT
10459       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10460      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10461 #else
10462       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10463      &               -0.5d0*ekont*(s2d+s12d)
10464 #endif
10465 C Derivatives in gamma(i+4)
10466       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10467       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10468       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10469 #ifdef MOMENT
10470       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10471       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10472       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10473 #endif
10474 c      s1d=0.0d0
10475 c      s2d=0.0d0
10476 c      s8d=0.0d0
10477 C      s12d=0.0d0
10478 c      s13d=0.0d0
10479 #ifdef MOMENT
10480       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10481 #else
10482       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10483 #endif
10484 C Derivatives in gamma(i+5)
10485 #ifdef MOMENT
10486       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10487       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10488       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10489 #endif
10490       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10491       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10492       s2d = scalar2(b1(1,k),vtemp1d(1))
10493 #ifdef MOMENT
10494       call transpose2(AEA(1,1,2),atempd(1,1))
10495       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10496       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10497 #endif
10498       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10499       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10500 #ifdef MOMENT
10501       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10502       ss13d = scalar2(b1(1,k),vtemp4d(1))
10503       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10504 #endif
10505 c      s1d=0.0d0
10506 c      s2d=0.0d0
10507 c      s8d=0.0d0
10508 c      s12d=0.0d0
10509 c      s13d=0.0d0
10510 #ifdef MOMENT
10511       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10512      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10513 #else
10514       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10515      &               -0.5d0*ekont*(s2d+s12d)
10516 #endif
10517 C Cartesian derivatives
10518       do iii=1,2
10519         do kkk=1,5
10520           do lll=1,3
10521 #ifdef MOMENT
10522             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10523             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10524             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10525 #endif
10526             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10527             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10528      &          vtemp1d(1))
10529             s2d = scalar2(b1(1,k),vtemp1d(1))
10530 #ifdef MOMENT
10531             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10532             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10533             s8d = -(atempd(1,1)+atempd(2,2))*
10534      &           scalar2(cc(1,1,itl),vtemp2(1))
10535 #endif
10536             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10537      &           auxmatd(1,1))
10538             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10539             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10540 c      s1d=0.0d0
10541 c      s2d=0.0d0
10542 c      s8d=0.0d0
10543 c      s12d=0.0d0
10544 c      s13d=0.0d0
10545 #ifdef MOMENT
10546             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10547      &        - 0.5d0*(s1d+s2d)
10548 #else
10549             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10550      &        - 0.5d0*s2d
10551 #endif
10552 #ifdef MOMENT
10553             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10554      &        - 0.5d0*(s8d+s12d)
10555 #else
10556             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10557      &        - 0.5d0*s12d
10558 #endif
10559           enddo
10560         enddo
10561       enddo
10562 #ifdef MOMENT
10563       do kkk=1,5
10564         do lll=1,3
10565           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10566      &      achuj_tempd(1,1))
10567           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10568           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10569           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10570           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10571           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10572      &      vtemp4d(1))
10573           ss13d = scalar2(b1(1,k),vtemp4d(1))
10574           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10575           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10576         enddo
10577       enddo
10578 #endif
10579 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10580 cd     &  16*eel_turn6_num
10581 cd      goto 1112
10582       if (j.lt.nres-1) then
10583         j1=j+1
10584         j2=j-1
10585       else
10586         j1=j-1
10587         j2=j-2
10588       endif
10589       if (l.lt.nres-1) then
10590         l1=l+1
10591         l2=l-1
10592       else
10593         l1=l-1
10594         l2=l-2
10595       endif
10596       do ll=1,3
10597 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10598 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10599 cgrad        ghalf=0.5d0*ggg1(ll)
10600 cd        ghalf=0.0d0
10601         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10602         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10603         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10604      &    +ekont*derx_turn(ll,2,1)
10605         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10606         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10607      &    +ekont*derx_turn(ll,4,1)
10608         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10609         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10610         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10611 cgrad        ghalf=0.5d0*ggg2(ll)
10612 cd        ghalf=0.0d0
10613         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10614      &    +ekont*derx_turn(ll,2,2)
10615         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10616         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10617      &    +ekont*derx_turn(ll,4,2)
10618         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10619         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10620         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10621       enddo
10622 cd      goto 1112
10623 cgrad      do m=i+1,j-1
10624 cgrad        do ll=1,3
10625 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10626 cgrad        enddo
10627 cgrad      enddo
10628 cgrad      do m=k+1,l-1
10629 cgrad        do ll=1,3
10630 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10631 cgrad        enddo
10632 cgrad      enddo
10633 cgrad1112  continue
10634 cgrad      do m=i+2,j2
10635 cgrad        do ll=1,3
10636 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10637 cgrad        enddo
10638 cgrad      enddo
10639 cgrad      do m=k+2,l2
10640 cgrad        do ll=1,3
10641 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10642 cgrad        enddo
10643 cgrad      enddo
10644 cd      do iii=1,nres-3
10645 cd        write (2,*) iii,g_corr6_loc(iii)
10646 cd      enddo
10647       eello_turn6=ekont*eel_turn6
10648 cd      write (2,*) 'ekont',ekont
10649 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10650       return
10651       end
10652
10653 C-----------------------------------------------------------------------------
10654       double precision function scalar(u,v)
10655 !DIR$ INLINEALWAYS scalar
10656 #ifndef OSF
10657 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10658 #endif
10659       implicit none
10660       double precision u(3),v(3)
10661 cd      double precision sc
10662 cd      integer i
10663 cd      sc=0.0d0
10664 cd      do i=1,3
10665 cd        sc=sc+u(i)*v(i)
10666 cd      enddo
10667 cd      scalar=sc
10668
10669       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10670       return
10671       end
10672 crc-------------------------------------------------
10673       SUBROUTINE MATVEC2(A1,V1,V2)
10674 !DIR$ INLINEALWAYS MATVEC2
10675 #ifndef OSF
10676 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10677 #endif
10678       implicit real*8 (a-h,o-z)
10679       include 'DIMENSIONS'
10680       DIMENSION A1(2,2),V1(2),V2(2)
10681 c      DO 1 I=1,2
10682 c        VI=0.0
10683 c        DO 3 K=1,2
10684 c    3     VI=VI+A1(I,K)*V1(K)
10685 c        Vaux(I)=VI
10686 c    1 CONTINUE
10687
10688       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10689       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10690
10691       v2(1)=vaux1
10692       v2(2)=vaux2
10693       END
10694 C---------------------------------------
10695       SUBROUTINE MATMAT2(A1,A2,A3)
10696 #ifndef OSF
10697 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10698 #endif
10699       implicit real*8 (a-h,o-z)
10700       include 'DIMENSIONS'
10701       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10702 c      DIMENSION AI3(2,2)
10703 c        DO  J=1,2
10704 c          A3IJ=0.0
10705 c          DO K=1,2
10706 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10707 c          enddo
10708 c          A3(I,J)=A3IJ
10709 c       enddo
10710 c      enddo
10711
10712       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10713       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10714       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10715       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10716
10717       A3(1,1)=AI3_11
10718       A3(2,1)=AI3_21
10719       A3(1,2)=AI3_12
10720       A3(2,2)=AI3_22
10721       END
10722
10723 c-------------------------------------------------------------------------
10724       double precision function scalar2(u,v)
10725 !DIR$ INLINEALWAYS scalar2
10726       implicit none
10727       double precision u(2),v(2)
10728       double precision sc
10729       integer i
10730       scalar2=u(1)*v(1)+u(2)*v(2)
10731       return
10732       end
10733
10734 C-----------------------------------------------------------------------------
10735
10736       subroutine transpose2(a,at)
10737 !DIR$ INLINEALWAYS transpose2
10738 #ifndef OSF
10739 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10740 #endif
10741       implicit none
10742       double precision a(2,2),at(2,2)
10743       at(1,1)=a(1,1)
10744       at(1,2)=a(2,1)
10745       at(2,1)=a(1,2)
10746       at(2,2)=a(2,2)
10747       return
10748       end
10749 c--------------------------------------------------------------------------
10750       subroutine transpose(n,a,at)
10751       implicit none
10752       integer n,i,j
10753       double precision a(n,n),at(n,n)
10754       do i=1,n
10755         do j=1,n
10756           at(j,i)=a(i,j)
10757         enddo
10758       enddo
10759       return
10760       end
10761 C---------------------------------------------------------------------------
10762       subroutine prodmat3(a1,a2,kk,transp,prod)
10763 !DIR$ INLINEALWAYS prodmat3
10764 #ifndef OSF
10765 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10766 #endif
10767       implicit none
10768       integer i,j
10769       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10770       logical transp
10771 crc      double precision auxmat(2,2),prod_(2,2)
10772
10773       if (transp) then
10774 crc        call transpose2(kk(1,1),auxmat(1,1))
10775 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10776 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10777
10778            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10779      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10780            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10781      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10782            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10783      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10784            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10785      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10786
10787       else
10788 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10789 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10790
10791            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10792      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10793            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10794      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10795            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10796      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10797            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10798      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10799
10800       endif
10801 c      call transpose2(a2(1,1),a2t(1,1))
10802
10803 crc      print *,transp
10804 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10805 crc      print *,((prod(i,j),i=1,2),j=1,2)
10806
10807       return
10808       end
10809 CCC----------------------------------------------
10810       subroutine Eliptransfer(eliptran)
10811       implicit real*8 (a-h,o-z)
10812       include 'DIMENSIONS'
10813       include 'COMMON.GEO'
10814       include 'COMMON.VAR'
10815       include 'COMMON.LOCAL'
10816       include 'COMMON.CHAIN'
10817       include 'COMMON.DERIV'
10818       include 'COMMON.NAMES'
10819       include 'COMMON.INTERACT'
10820       include 'COMMON.IOUNITS'
10821       include 'COMMON.CALC'
10822       include 'COMMON.CONTROL'
10823       include 'COMMON.SPLITELE'
10824       include 'COMMON.SBRIDGE'
10825 C this is done by Adasko
10826 C      print *,"wchodze"
10827 C structure of box:
10828 C      water
10829 C--bordliptop-- buffore starts
10830 C--bufliptop--- here true lipid starts
10831 C      lipid
10832 C--buflipbot--- lipid ends buffore starts
10833 C--bordlipbot--buffore ends
10834       eliptran=0.0
10835       do i=ilip_start,ilip_end
10836 C       do i=1,1
10837         if (itype(i).eq.ntyp1) cycle
10838
10839         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10840         if (positi.le.0) positi=positi+boxzsize
10841 C        print *,i
10842 C first for peptide groups
10843 c for each residue check if it is in lipid or lipid water border area
10844        if ((positi.gt.bordlipbot)
10845      &.and.(positi.lt.bordliptop)) then
10846 C the energy transfer exist
10847         if (positi.lt.buflipbot) then
10848 C what fraction I am in
10849          fracinbuf=1.0d0-
10850      &        ((positi-bordlipbot)/lipbufthick)
10851 C lipbufthick is thickenes of lipid buffore
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
10859 C        print *,"doing sccale for lower part"
10860 C         print *,i,sslip,fracinbuf,ssgradlip
10861         elseif (positi.gt.bufliptop) then
10862          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10863          sslip=sscalelip(fracinbuf)
10864          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10865          eliptran=eliptran+sslip*pepliptran
10866          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10867          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10868 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10869 C          print *, "doing sscalefor top part"
10870 C         print *,i,sslip,fracinbuf,ssgradlip
10871         else
10872          eliptran=eliptran+pepliptran
10873 C         print *,"I am in true lipid"
10874         endif
10875 C       else
10876 C       eliptran=elpitran+0.0 ! I am in water
10877        endif
10878        enddo
10879 C       print *, "nic nie bylo w lipidzie?"
10880 C now multiply all by the peptide group transfer factor
10881 C       eliptran=eliptran*pepliptran
10882 C now the same for side chains
10883 CV       do i=1,1
10884        do i=ilip_start,ilip_end
10885         if (itype(i).eq.ntyp1) cycle
10886         positi=(mod(c(3,i+nres),boxzsize))
10887         if (positi.le.0) positi=positi+boxzsize
10888 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10889 c for each residue check if it is in lipid or lipid water border area
10890 C       respos=mod(c(3,i+nres),boxzsize)
10891 C       print *,positi,bordlipbot,buflipbot
10892        if ((positi.gt.bordlipbot)
10893      & .and.(positi.lt.bordliptop)) then
10894 C the energy transfer exist
10895         if (positi.lt.buflipbot) then
10896          fracinbuf=1.0d0-
10897      &     ((positi-bordlipbot)/lipbufthick)
10898 C lipbufthick is thickenes of lipid buffore
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 sccale for lower part"
10907         elseif (positi.gt.bufliptop) then
10908          fracinbuf=1.0d0-
10909      &((bordliptop-positi)/lipbufthick)
10910          sslip=sscalelip(fracinbuf)
10911          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10912          eliptran=eliptran+sslip*liptranene(itype(i))
10913          gliptranx(3,i)=gliptranx(3,i)
10914      &+ssgradlip*liptranene(itype(i))
10915          gliptranc(3,i-1)= gliptranc(3,i-1)
10916      &+ssgradlip*liptranene(itype(i))
10917 C          print *, "doing sscalefor top part",sslip,fracinbuf
10918         else
10919          eliptran=eliptran+liptranene(itype(i))
10920 C         print *,"I am in true lipid"
10921         endif
10922         endif ! if in lipid or buffor
10923 C       else
10924 C       eliptran=elpitran+0.0 ! I am in water
10925        enddo
10926        return
10927        end
10928 C---------------------------------------------------------
10929 C AFM soubroutine for constant force
10930        subroutine AFMforce(Eafmforce)
10931        implicit real*8 (a-h,o-z)
10932       include 'DIMENSIONS'
10933       include 'COMMON.GEO'
10934       include 'COMMON.VAR'
10935       include 'COMMON.LOCAL'
10936       include 'COMMON.CHAIN'
10937       include 'COMMON.DERIV'
10938       include 'COMMON.NAMES'
10939       include 'COMMON.INTERACT'
10940       include 'COMMON.IOUNITS'
10941       include 'COMMON.CALC'
10942       include 'COMMON.CONTROL'
10943       include 'COMMON.SPLITELE'
10944       include 'COMMON.SBRIDGE'
10945       real*8 diffafm(3)
10946       dist=0.0d0
10947       Eafmforce=0.0d0
10948       do i=1,3
10949       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10950       dist=dist+diffafm(i)**2
10951       enddo
10952       dist=dsqrt(dist)
10953       Eafmforce=-forceAFMconst*(dist-distafminit)
10954       do i=1,3
10955       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10956       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10957       enddo
10958 C      print *,'AFM',Eafmforce
10959       return
10960       end
10961 C---------------------------------------------------------
10962 C AFM subroutine with pseudoconstant velocity
10963        subroutine AFMvel(Eafmforce)
10964        implicit real*8 (a-h,o-z)
10965       include 'DIMENSIONS'
10966       include 'COMMON.GEO'
10967       include 'COMMON.VAR'
10968       include 'COMMON.LOCAL'
10969       include 'COMMON.CHAIN'
10970       include 'COMMON.DERIV'
10971       include 'COMMON.NAMES'
10972       include 'COMMON.INTERACT'
10973       include 'COMMON.IOUNITS'
10974       include 'COMMON.CALC'
10975       include 'COMMON.CONTROL'
10976       include 'COMMON.SPLITELE'
10977       include 'COMMON.SBRIDGE'
10978       real*8 diffafm(3)
10979 C Only for check grad COMMENT if not used for checkgrad
10980 C      totT=3.0d0
10981 C--------------------------------------------------------
10982 C      print *,"wchodze"
10983       dist=0.0d0
10984       Eafmforce=0.0d0
10985       do i=1,3
10986       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10987       dist=dist+diffafm(i)**2
10988       enddo
10989       dist=dsqrt(dist)
10990       Eafmforce=0.5d0*forceAFMconst
10991      & *(distafminit+totTafm*velAFMconst-dist)**2
10992 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10993       do i=1,3
10994       gradafm(i,afmend-1)=-forceAFMconst*
10995      &(distafminit+totTafm*velAFMconst-dist)
10996      &*diffafm(i)/dist
10997       gradafm(i,afmbeg-1)=forceAFMconst*
10998      &(distafminit+totTafm*velAFMconst-dist)
10999      &*diffafm(i)/dist
11000       enddo
11001 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11002       return
11003       end
11004