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