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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444 #endif
 445       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 446      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 #define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 #undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 #define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 #undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423       evdw=0.0D0
1424 ccccc      energy_dec=.false.
1425 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427       lprn=.false.
1428 c     if (icall.eq.0) lprn=.false.
1429       ind=0
1430       do i=iatsc_s,iatsc_e
1431         itypi=iabs(itype(i))
1432         if (itypi.eq.ntyp1) cycle
1433         itypi1=iabs(itype(i+1))
1434         xi=c(1,nres+i)
1435         yi=c(2,nres+i)
1436         zi=c(3,nres+i)
1437         dxi=dc_norm(1,nres+i)
1438         dyi=dc_norm(2,nres+i)
1439         dzi=dc_norm(3,nres+i)
1440 c        dsci_inv=dsc_inv(itypi)
1441         dsci_inv=vbld_inv(i+nres)
1442 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1443 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1450               call dyn_ssbond_ene(i,j,evdwij)
1451               evdw=evdw+evdwij
1452               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1453      &                        'evdw',i,j,evdwij,' ss'
1454             ELSE
1455             ind=ind+1
1456             itypj=iabs(itype(j))
1457             if (itypj.eq.ntyp1) cycle
1458 c            dscj_inv=dsc_inv(itypj)
1459             dscj_inv=vbld_inv(j+nres)
1460 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1461 c     &       1.0d0/vbld(j+nres)
1462 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1463             sig0ij=sigma(itypi,itypj)
1464             chi1=chi(itypi,itypj)
1465             chi2=chi(itypj,itypi)
1466             chi12=chi1*chi2
1467             chip1=chip(itypi)
1468             chip2=chip(itypj)
1469             chip12=chip1*chip2
1470             alf1=alp(itypi)
1471             alf2=alp(itypj)
1472             alf12=0.5D0*(alf1+alf2)
1473 C For diagnostics only!!!
1474 c           chi1=0.0D0
1475 c           chi2=0.0D0
1476 c           chi12=0.0D0
1477 c           chip1=0.0D0
1478 c           chip2=0.0D0
1479 c           chip12=0.0D0
1480 c           alf1=0.0D0
1481 c           alf2=0.0D0
1482 c           alf12=0.0D0
1483             xj=c(1,nres+j)-xi
1484             yj=c(2,nres+j)-yi
1485             zj=c(3,nres+j)-zi
1486             dxj=dc_norm(1,nres+j)
1487             dyj=dc_norm(2,nres+j)
1488             dzj=dc_norm(3,nres+j)
1489 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1490 c            write (iout,*) "j",j," dc_norm",
1491 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1492             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1493             rij=dsqrt(rrij)
1494 C Calculate angle-dependent terms of energy and contributions to their
1495 C derivatives.
1496             call sc_angular
1497             sigsq=1.0D0/sigsq
1498             sig=sig0ij*dsqrt(sigsq)
1499             rij_shift=1.0D0/rij-sig+sig0ij
1500 c for diagnostics; uncomment
1501 c            rij_shift=1.2*sig0ij
1502 C I hate to put IF's in the loops, but here don't have another choice!!!!
1503             if (rij_shift.le.0.0D0) then
1504               evdw=1.0D20
1505 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1506 cd     &        restyp(itypi),i,restyp(itypj),j,
1507 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1508               return
1509             endif
1510             sigder=-sig*sigsq
1511 c---------------------------------------------------------------
1512             rij_shift=1.0D0/rij_shift
1513             fac=rij_shift**expon
1514             e1=fac*fac*aa(itypi,itypj)
1515             e2=fac*bb(itypi,itypj)
1516             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1517             eps2der=evdwij*eps3rt
1518             eps3der=evdwij*eps2rt
1519 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1520 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1521             evdwij=evdwij*eps2rt*eps3rt
1522             evdw=evdw+evdwij
1523             if (lprn) then
1524             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1525             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1526             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1527      &        restyp(itypi),i,restyp(itypj),j,
1528      &        epsi,sigm,chi1,chi2,chip1,chip2,
1529      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1530      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1531      &        evdwij
1532             endif
1533
1534             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1535      &                        'evdw',i,j,evdwij
1536
1537 C Calculate gradient components.
1538             e1=e1*eps1*eps2rt**2*eps3rt**2
1539             fac=-expon*(e1+evdwij)*rij_shift
1540             sigder=fac*sigder
1541             fac=rij*fac
1542 c            fac=0.0d0
1543 C Calculate the radial part of the gradient
1544             gg(1)=xj*fac
1545             gg(2)=yj*fac
1546             gg(3)=zj*fac
1547 C Calculate angular part of the gradient.
1548             call sc_grad
1549             ENDIF    ! dyn_ss
1550           enddo      ! j
1551         enddo        ! iint
1552       enddo          ! i
1553 c      write (iout,*) "Number of loop steps in EGB:",ind
1554 cccc      energy_dec=.false.
1555       return
1556       end
1557 C-----------------------------------------------------------------------------
1558       subroutine egbv(evdw)
1559 C
1560 C This subroutine calculates the interaction energy of nonbonded side chains
1561 C assuming the Gay-Berne-Vorobjev potential of interaction.
1562 C
1563       implicit real*8 (a-h,o-z)
1564       include 'DIMENSIONS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.NAMES'
1571       include 'COMMON.INTERACT'
1572       include 'COMMON.IOUNITS'
1573       include 'COMMON.CALC'
1574       common /srutu/ icall
1575       logical lprn
1576       evdw=0.0D0
1577 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1578       evdw=0.0D0
1579       lprn=.false.
1580 c     if (icall.eq.0) lprn=.true.
1581       ind=0
1582       do i=iatsc_s,iatsc_e
1583         itypi=iabs(itype(i))
1584         if (itypi.eq.ntyp1) cycle
1585         itypi1=iabs(itype(i+1))
1586         xi=c(1,nres+i)
1587         yi=c(2,nres+i)
1588         zi=c(3,nres+i)
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 C
1595 C Calculate SC interaction energy.
1596 C
1597         do iint=1,nint_gr(i)
1598           do j=istart(i,iint),iend(i,iint)
1599             ind=ind+1
1600             itypj=iabs(itype(j))
1601             if (itypj.eq.ntyp1) cycle
1602 c            dscj_inv=dsc_inv(itypj)
1603             dscj_inv=vbld_inv(j+nres)
1604             sig0ij=sigma(itypi,itypj)
1605             r0ij=r0(itypi,itypj)
1606             chi1=chi(itypi,itypj)
1607             chi2=chi(itypj,itypi)
1608             chi12=chi1*chi2
1609             chip1=chip(itypi)
1610             chip2=chip(itypj)
1611             chip12=chip1*chip2
1612             alf1=alp(itypi)
1613             alf2=alp(itypj)
1614             alf12=0.5D0*(alf1+alf2)
1615 C For diagnostics only!!!
1616 c           chi1=0.0D0
1617 c           chi2=0.0D0
1618 c           chi12=0.0D0
1619 c           chip1=0.0D0
1620 c           chip2=0.0D0
1621 c           chip12=0.0D0
1622 c           alf1=0.0D0
1623 c           alf2=0.0D0
1624 c           alf12=0.0D0
1625             xj=c(1,nres+j)-xi
1626             yj=c(2,nres+j)-yi
1627             zj=c(3,nres+j)-zi
1628             dxj=dc_norm(1,nres+j)
1629             dyj=dc_norm(2,nres+j)
1630             dzj=dc_norm(3,nres+j)
1631             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1632             rij=dsqrt(rrij)
1633 C Calculate angle-dependent terms of energy and contributions to their
1634 C derivatives.
1635             call sc_angular
1636             sigsq=1.0D0/sigsq
1637             sig=sig0ij*dsqrt(sigsq)
1638             rij_shift=1.0D0/rij-sig+r0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642               return
1643             endif
1644             sigder=-sig*sigsq
1645 c---------------------------------------------------------------
1646             rij_shift=1.0D0/rij_shift
1647             fac=rij_shift**expon
1648             e1=fac*fac*aa(itypi,itypj)
1649             e2=fac*bb(itypi,itypj)
1650             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1651             eps2der=evdwij*eps3rt
1652             eps3der=evdwij*eps2rt
1653             fac_augm=rrij**expon
1654             e_augm=augm(itypi,itypj)*fac_augm
1655             evdwij=evdwij*eps2rt*eps3rt
1656             evdw=evdw+evdwij+e_augm
1657             if (lprn) then
1658             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1659             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1660             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1661      &        restyp(itypi),i,restyp(itypj),j,
1662      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1663      &        chi1,chi2,chip1,chip2,
1664      &        eps1,eps2rt**2,eps3rt**2,
1665      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1666      &        evdwij+e_augm
1667             endif
1668 C Calculate gradient components.
1669             e1=e1*eps1*eps2rt**2*eps3rt**2
1670             fac=-expon*(e1+evdwij)*rij_shift
1671             sigder=fac*sigder
1672             fac=rij*fac-2*expon*rrij*e_augm
1673 C Calculate the radial part of the gradient
1674             gg(1)=xj*fac
1675             gg(2)=yj*fac
1676             gg(3)=zj*fac
1677 C Calculate angular part of the gradient.
1678             call sc_grad
1679           enddo      ! j
1680         enddo        ! iint
1681       enddo          ! i
1682       end
1683 C-----------------------------------------------------------------------------
1684       subroutine sc_angular
1685 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1686 C om12. Called by ebp, egb, and egbv.
1687       implicit none
1688       include 'COMMON.CALC'
1689       include 'COMMON.IOUNITS'
1690       erij(1)=xj*rij
1691       erij(2)=yj*rij
1692       erij(3)=zj*rij
1693       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1694       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1695       om12=dxi*dxj+dyi*dyj+dzi*dzj
1696       chiom12=chi12*om12
1697 C Calculate eps1(om12) and its derivative in om12
1698       faceps1=1.0D0-om12*chiom12
1699       faceps1_inv=1.0D0/faceps1
1700       eps1=dsqrt(faceps1_inv)
1701 C Following variable is eps1*deps1/dom12
1702       eps1_om12=faceps1_inv*chiom12
1703 c diagnostics only
1704 c      faceps1_inv=om12
1705 c      eps1=om12
1706 c      eps1_om12=1.0d0
1707 c      write (iout,*) "om12",om12," eps1",eps1
1708 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1709 C and om12.
1710       om1om2=om1*om2
1711       chiom1=chi1*om1
1712       chiom2=chi2*om2
1713       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1714       sigsq=1.0D0-facsig*faceps1_inv
1715       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1716       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1717       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1718 c diagnostics only
1719 c      sigsq=1.0d0
1720 c      sigsq_om1=0.0d0
1721 c      sigsq_om2=0.0d0
1722 c      sigsq_om12=0.0d0
1723 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1724 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1725 c     &    " eps1",eps1
1726 C Calculate eps2 and its derivatives in om1, om2, and om12.
1727       chipom1=chip1*om1
1728       chipom2=chip2*om2
1729       chipom12=chip12*om12
1730       facp=1.0D0-om12*chipom12
1731       facp_inv=1.0D0/facp
1732       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1733 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1734 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1735 C Following variable is the square root of eps2
1736       eps2rt=1.0D0-facp1*facp_inv
1737 C Following three variables are the derivatives of the square root of eps
1738 C in om1, om2, and om12.
1739       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1740       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1741       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1742 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1743       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1744 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1745 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1746 c     &  " eps2rt_om12",eps2rt_om12
1747 C Calculate whole angle-dependent part of epsilon and contributions
1748 C to its derivatives
1749       return
1750       end
1751 C----------------------------------------------------------------------------
1752       subroutine sc_grad
1753       implicit real*8 (a-h,o-z)
1754       include 'DIMENSIONS'
1755       include 'COMMON.CHAIN'
1756       include 'COMMON.DERIV'
1757       include 'COMMON.CALC'
1758       include 'COMMON.IOUNITS'
1759       double precision dcosom1(3),dcosom2(3)
1760       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1761       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1762       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1763      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1764 c diagnostics only
1765 c      eom1=0.0d0
1766 c      eom2=0.0d0
1767 c      eom12=evdwij*eps1_om12
1768 c end diagnostics
1769 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1770 c     &  " sigder",sigder
1771 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1772 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1773       do k=1,3
1774         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1775         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1776       enddo
1777       do k=1,3
1778         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1779       enddo
1780 c      write (iout,*) "gg",(gg(k),k=1,3)
1781       do k=1,3
1782         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1783      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1784      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1785         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1786      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1787      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1788 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1789 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1790 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1791 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1792       enddo
1793 C
1794 C Calculate the components of the gradient in DC and X
1795 C
1796 cgrad      do k=i,j-1
1797 cgrad        do l=1,3
1798 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1799 cgrad        enddo
1800 cgrad      enddo
1801       do l=1,3
1802         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1803         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1804       enddo
1805       return
1806       end
1807 C-----------------------------------------------------------------------
1808       subroutine e_softsphere(evdw)
1809 C
1810 C This subroutine calculates the interaction energy of nonbonded side chains
1811 C assuming the LJ potential of interaction.
1812 C
1813       implicit real*8 (a-h,o-z)
1814       include 'DIMENSIONS'
1815       parameter (accur=1.0d-10)
1816       include 'COMMON.GEO'
1817       include 'COMMON.VAR'
1818       include 'COMMON.LOCAL'
1819       include 'COMMON.CHAIN'
1820       include 'COMMON.DERIV'
1821       include 'COMMON.INTERACT'
1822       include 'COMMON.TORSION'
1823       include 'COMMON.SBRIDGE'
1824       include 'COMMON.NAMES'
1825       include 'COMMON.IOUNITS'
1826       include 'COMMON.CONTACTS'
1827       dimension gg(3)
1828 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1829       evdw=0.0D0
1830       do i=iatsc_s,iatsc_e
1831         itypi=iabs(itype(i))
1832         if (itypi.eq.ntyp1) cycle
1833         itypi1=iabs(itype(i+1))
1834         xi=c(1,nres+i)
1835         yi=c(2,nres+i)
1836         zi=c(3,nres+i)
1837 C
1838 C Calculate SC interaction energy.
1839 C
1840         do iint=1,nint_gr(i)
1841 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1842 cd   &                  'iend=',iend(i,iint)
1843           do j=istart(i,iint),iend(i,iint)
1844             itypj=iabs(itype(j))
1845             if (itypj.eq.ntyp1) cycle
1846             xj=c(1,nres+j)-xi
1847             yj=c(2,nres+j)-yi
1848             zj=c(3,nres+j)-zi
1849             rij=xj*xj+yj*yj+zj*zj
1850 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1851             r0ij=r0(itypi,itypj)
1852             r0ijsq=r0ij*r0ij
1853 c            print *,i,j,r0ij,dsqrt(rij)
1854             if (rij.lt.r0ijsq) then
1855               evdwij=0.25d0*(rij-r0ijsq)**2
1856               fac=rij-r0ijsq
1857             else
1858               evdwij=0.0d0
1859               fac=0.0d0
1860             endif
1861             evdw=evdw+evdwij
1862 C
1863 C Calculate the components of the gradient in DC and X
1864 C
1865             gg(1)=xj*fac
1866             gg(2)=yj*fac
1867             gg(3)=zj*fac
1868             do k=1,3
1869               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1870               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1871               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1872               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1873             enddo
1874 cgrad            do k=i,j-1
1875 cgrad              do l=1,3
1876 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1877 cgrad              enddo
1878 cgrad            enddo
1879           enddo ! j
1880         enddo ! iint
1881       enddo ! i
1882       return
1883       end
1884 C--------------------------------------------------------------------------
1885       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1886      &              eello_turn4)
1887 C
1888 C Soft-sphere potential of p-p interaction
1889 C
1890       implicit real*8 (a-h,o-z)
1891       include 'DIMENSIONS'
1892       include 'COMMON.CONTROL'
1893       include 'COMMON.IOUNITS'
1894       include 'COMMON.GEO'
1895       include 'COMMON.VAR'
1896       include 'COMMON.LOCAL'
1897       include 'COMMON.CHAIN'
1898       include 'COMMON.DERIV'
1899       include 'COMMON.INTERACT'
1900       include 'COMMON.CONTACTS'
1901       include 'COMMON.TORSION'
1902       include 'COMMON.VECTORS'
1903       include 'COMMON.FFIELD'
1904       dimension ggg(3)
1905 cd      write(iout,*) 'In EELEC_soft_sphere'
1906       ees=0.0D0
1907       evdw1=0.0D0
1908       eel_loc=0.0d0
1909       eello_turn3=0.0d0
1910       eello_turn4=0.0d0
1911       ind=0
1912       do i=iatel_s,iatel_e
1913         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1914         dxi=dc(1,i)
1915         dyi=dc(2,i)
1916         dzi=dc(3,i)
1917         xmedi=c(1,i)+0.5d0*dxi
1918         ymedi=c(2,i)+0.5d0*dyi
1919         zmedi=c(3,i)+0.5d0*dzi
1920         num_conti=0
1921 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1922         do j=ielstart(i),ielend(i)
1923           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1924           ind=ind+1
1925           iteli=itel(i)
1926           itelj=itel(j)
1927           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1928           r0ij=rpp(iteli,itelj)
1929           r0ijsq=r0ij*r0ij
1930           dxj=dc(1,j)
1931           dyj=dc(2,j)
1932           dzj=dc(3,j)
1933           xj=c(1,j)+0.5D0*dxj-xmedi
1934           yj=c(2,j)+0.5D0*dyj-ymedi
1935           zj=c(3,j)+0.5D0*dzj-zmedi
1936           rij=xj*xj+yj*yj+zj*zj
1937           if (rij.lt.r0ijsq) then
1938             evdw1ij=0.25d0*(rij-r0ijsq)**2
1939             fac=rij-r0ijsq
1940           else
1941             evdw1ij=0.0d0
1942             fac=0.0d0
1943           endif
1944           evdw1=evdw1+evdw1ij
1945 C
1946 C Calculate contributions to the Cartesian gradient.
1947 C
1948           ggg(1)=fac*xj
1949           ggg(2)=fac*yj
1950           ggg(3)=fac*zj
1951           do k=1,3
1952             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1953             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1954           enddo
1955 *
1956 * Loop over residues i+1 thru j-1.
1957 *
1958 cgrad          do k=i+1,j-1
1959 cgrad            do l=1,3
1960 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1961 cgrad            enddo
1962 cgrad          enddo
1963         enddo ! j
1964       enddo   ! i
1965 cgrad      do i=nnt,nct-1
1966 cgrad        do k=1,3
1967 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1968 cgrad        enddo
1969 cgrad        do j=i+1,nct-1
1970 cgrad          do k=1,3
1971 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1972 cgrad          enddo
1973 cgrad        enddo
1974 cgrad      enddo
1975       return
1976       end
1977 c------------------------------------------------------------------------------
1978       subroutine vec_and_deriv
1979       implicit real*8 (a-h,o-z)
1980       include 'DIMENSIONS'
1981 #ifdef MPI
1982       include 'mpif.h'
1983 #endif
1984       include 'COMMON.IOUNITS'
1985       include 'COMMON.GEO'
1986       include 'COMMON.VAR'
1987       include 'COMMON.LOCAL'
1988       include 'COMMON.CHAIN'
1989       include 'COMMON.VECTORS'
1990       include 'COMMON.SETUP'
1991       include 'COMMON.TIME1'
1992       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1993 C Compute the local reference systems. For reference system (i), the
1994 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1995 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1996 #ifdef PARVEC
1997       do i=ivec_start,ivec_end
1998 #else
1999       do i=1,nres-1
2000 #endif
2001           if (i.eq.nres-1) then
2002 C Case of the last full residue
2003 C Compute the Z-axis
2004             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2005             costh=dcos(pi-theta(nres))
2006             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2007             do k=1,3
2008               uz(k,i)=fac*uz(k,i)
2009             enddo
2010 C Compute the derivatives of uz
2011             uzder(1,1,1)= 0.0d0
2012             uzder(2,1,1)=-dc_norm(3,i-1)
2013             uzder(3,1,1)= dc_norm(2,i-1)
2014             uzder(1,2,1)= dc_norm(3,i-1)
2015             uzder(2,2,1)= 0.0d0
2016             uzder(3,2,1)=-dc_norm(1,i-1)
2017             uzder(1,3,1)=-dc_norm(2,i-1)
2018             uzder(2,3,1)= dc_norm(1,i-1)
2019             uzder(3,3,1)= 0.0d0
2020             uzder(1,1,2)= 0.0d0
2021             uzder(2,1,2)= dc_norm(3,i)
2022             uzder(3,1,2)=-dc_norm(2,i)
2023             uzder(1,2,2)=-dc_norm(3,i)
2024             uzder(2,2,2)= 0.0d0
2025             uzder(3,2,2)= dc_norm(1,i)
2026             uzder(1,3,2)= dc_norm(2,i)
2027             uzder(2,3,2)=-dc_norm(1,i)
2028             uzder(3,3,2)= 0.0d0
2029 C Compute the Y-axis
2030             facy=fac
2031             do k=1,3
2032               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2033             enddo
2034 C Compute the derivatives of uy
2035             do j=1,3
2036               do k=1,3
2037                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2038      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2039                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2040               enddo
2041               uyder(j,j,1)=uyder(j,j,1)-costh
2042               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2043             enddo
2044             do j=1,2
2045               do k=1,3
2046                 do l=1,3
2047                   uygrad(l,k,j,i)=uyder(l,k,j)
2048                   uzgrad(l,k,j,i)=uzder(l,k,j)
2049                 enddo
2050               enddo
2051             enddo
2052             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2053             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2054             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2055             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2056           else
2057 C Other residues
2058 C Compute the Z-axis
2059             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2060             costh=dcos(pi-theta(i+2))
2061             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2062             do k=1,3
2063               uz(k,i)=fac*uz(k,i)
2064             enddo
2065 C Compute the derivatives of uz
2066             uzder(1,1,1)= 0.0d0
2067             uzder(2,1,1)=-dc_norm(3,i+1)
2068             uzder(3,1,1)= dc_norm(2,i+1)
2069             uzder(1,2,1)= dc_norm(3,i+1)
2070             uzder(2,2,1)= 0.0d0
2071             uzder(3,2,1)=-dc_norm(1,i+1)
2072             uzder(1,3,1)=-dc_norm(2,i+1)
2073             uzder(2,3,1)= dc_norm(1,i+1)
2074             uzder(3,3,1)= 0.0d0
2075             uzder(1,1,2)= 0.0d0
2076             uzder(2,1,2)= dc_norm(3,i)
2077             uzder(3,1,2)=-dc_norm(2,i)
2078             uzder(1,2,2)=-dc_norm(3,i)
2079             uzder(2,2,2)= 0.0d0
2080             uzder(3,2,2)= dc_norm(1,i)
2081             uzder(1,3,2)= dc_norm(2,i)
2082             uzder(2,3,2)=-dc_norm(1,i)
2083             uzder(3,3,2)= 0.0d0
2084 C Compute the Y-axis
2085             facy=fac
2086             do k=1,3
2087               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2088             enddo
2089 C Compute the derivatives of uy
2090             do j=1,3
2091               do k=1,3
2092                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2093      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2094                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2095               enddo
2096               uyder(j,j,1)=uyder(j,j,1)-costh
2097               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2098             enddo
2099             do j=1,2
2100               do k=1,3
2101                 do l=1,3
2102                   uygrad(l,k,j,i)=uyder(l,k,j)
2103                   uzgrad(l,k,j,i)=uzder(l,k,j)
2104                 enddo
2105               enddo
2106             enddo
2107             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2108             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2109             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2110             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2111           endif
2112       enddo
2113       do i=1,nres-1
2114         vbld_inv_temp(1)=vbld_inv(i+1)
2115         if (i.lt.nres-1) then
2116           vbld_inv_temp(2)=vbld_inv(i+2)
2117           else
2118           vbld_inv_temp(2)=vbld_inv(i)
2119           endif
2120         do j=1,2
2121           do k=1,3
2122             do l=1,3
2123               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2124               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2125             enddo
2126           enddo
2127         enddo
2128       enddo
2129 #if defined(PARVEC) && defined(MPI)
2130       if (nfgtasks1.gt.1) then
2131         time00=MPI_Wtime()
2132 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2133 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2134 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2135         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2136      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2137      &   FG_COMM1,IERR)
2138         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2139      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2140      &   FG_COMM1,IERR)
2141         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2142      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2143      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2144         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2145      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2146      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2147         time_gather=time_gather+MPI_Wtime()-time00
2148       endif
2149 c      if (fg_rank.eq.0) then
2150 c        write (iout,*) "Arrays UY and UZ"
2151 c        do i=1,nres-1
2152 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2153 c     &     (uz(k,i),k=1,3)
2154 c        enddo
2155 c      endif
2156 #endif
2157       return
2158       end
2159 C-----------------------------------------------------------------------------
2160       subroutine check_vecgrad
2161       implicit real*8 (a-h,o-z)
2162       include 'DIMENSIONS'
2163       include 'COMMON.IOUNITS'
2164       include 'COMMON.GEO'
2165       include 'COMMON.VAR'
2166       include 'COMMON.LOCAL'
2167       include 'COMMON.CHAIN'
2168       include 'COMMON.VECTORS'
2169       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2170       dimension uyt(3,maxres),uzt(3,maxres)
2171       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2172       double precision delta /1.0d-7/
2173       call vec_and_deriv
2174 cd      do i=1,nres
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2177 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2178 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2179 cd     &     (dc_norm(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2181 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2182 cd          write(iout,'(a)')
2183 cd      enddo
2184       do i=1,nres
2185         do j=1,2
2186           do k=1,3
2187             do l=1,3
2188               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2189               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2190             enddo
2191           enddo
2192         enddo
2193       enddo
2194       call vec_and_deriv
2195       do i=1,nres
2196         do j=1,3
2197           uyt(j,i)=uy(j,i)
2198           uzt(j,i)=uz(j,i)
2199         enddo
2200       enddo
2201       do i=1,nres
2202 cd        write (iout,*) 'i=',i
2203         do k=1,3
2204           erij(k)=dc_norm(k,i)
2205         enddo
2206         do j=1,3
2207           do k=1,3
2208             dc_norm(k,i)=erij(k)
2209           enddo
2210           dc_norm(j,i)=dc_norm(j,i)+delta
2211 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2212 c          do k=1,3
2213 c            dc_norm(k,i)=dc_norm(k,i)/fac
2214 c          enddo
2215 c          write (iout,*) (dc_norm(k,i),k=1,3)
2216 c          write (iout,*) (erij(k),k=1,3)
2217           call vec_and_deriv
2218           do k=1,3
2219             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2220             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2221             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2222             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2223           enddo
2224 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2225 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2226 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2227         enddo
2228         do k=1,3
2229           dc_norm(k,i)=erij(k)
2230         enddo
2231 cd        do k=1,3
2232 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2233 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2234 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2235 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2236 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2237 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2238 cd          write (iout,'(a)')
2239 cd        enddo
2240       enddo
2241       return
2242       end
2243 C--------------------------------------------------------------------------
2244       subroutine set_matrices
2245       implicit real*8 (a-h,o-z)
2246       include 'DIMENSIONS'
2247 #ifdef MPI
2248       include "mpif.h"
2249       include "COMMON.SETUP"
2250       integer IERR
2251       integer status(MPI_STATUS_SIZE)
2252 #endif
2253       include 'COMMON.IOUNITS'
2254       include 'COMMON.GEO'
2255       include 'COMMON.VAR'
2256       include 'COMMON.LOCAL'
2257       include 'COMMON.CHAIN'
2258       include 'COMMON.DERIV'
2259       include 'COMMON.INTERACT'
2260       include 'COMMON.CONTACTS'
2261       include 'COMMON.TORSION'
2262       include 'COMMON.VECTORS'
2263       include 'COMMON.FFIELD'
2264       double precision auxvec(2),auxmat(2,2)
2265 C
2266 C Compute the virtual-bond-torsional-angle dependent quantities needed
2267 C to calculate the el-loc multibody terms of various order.
2268 C
2269 c      write(iout,*) 'nphi=',nphi,nres
2270 #ifdef PARMAT
2271       do i=ivec_start+2,ivec_end+2
2272 #else
2273       do i=3,nres+1
2274 #endif
2275 #ifdef NEWCORR
2276         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2277           iti = itortyp(itype(i-2))
2278         else
2279           iti=ntortyp+1
2280         endif
2281 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2282         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2283           iti1 = itortyp(itype(i-1))
2284         else
2285           iti1=ntortyp+1
2286         endif
2287 c        write(iout,*),i
2288         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2289      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2290      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2291         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2292      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2293      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2294 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2295 c     &*(cos(theta(i)/2.0)
2296         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2297      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2298      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2299 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2300 c     &*(cos(theta(i)/2.0)
2301         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2302      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2303      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2304 c        if (ggb1(1,i).eq.0.0d0) then
2305 c        write(iout,*) 'i=',i,ggb1(1,i),
2306 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2307 c     &bnew1(2,1,iti)*cos(theta(i)),
2308 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2309 c        endif
2310         b1(2,i-2)=bnew1(1,2,iti)
2311         gtb1(2,i-2)=0.0
2312         b2(2,i-2)=bnew2(1,2,iti)
2313         gtb2(2,i-2)=0.0
2314         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2315         EE(1,2,i-2)=eeold(1,2,iti)
2316         EE(2,1,i-2)=eeold(2,1,iti)
2317         EE(2,2,i-2)=eeold(2,2,iti)
2318         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2319         gtEE(1,2,i-2)=0.0d0
2320         gtEE(2,2,i-2)=0.0d0
2321         gtEE(2,1,i-2)=0.0d0
2322 c        EE(2,2,iti)=0.0d0
2323 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2324 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2325 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2326 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2327        b1tilde(1,i-2)=b1(1,i-2)
2328        b1tilde(2,i-2)=-b1(2,i-2)
2329        b2tilde(1,i-2)=b2(1,i-2)
2330        b2tilde(2,i-2)=-b2(2,i-2)
2331 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2332 c       write(iout,*)  'b1=',b1(1,i-2)
2333 c       write (iout,*) 'theta=', theta(i-1)
2334        enddo
2335 #ifdef PARMAT
2336       do i=ivec_start+2,ivec_end+2
2337 #else
2338       do i=3,nres+1
2339 #endif
2340 #endif
2341         if (i .lt. nres+1) then
2342           sin1=dsin(phi(i))
2343           cos1=dcos(phi(i))
2344           sintab(i-2)=sin1
2345           costab(i-2)=cos1
2346           obrot(1,i-2)=cos1
2347           obrot(2,i-2)=sin1
2348           sin2=dsin(2*phi(i))
2349           cos2=dcos(2*phi(i))
2350           sintab2(i-2)=sin2
2351           costab2(i-2)=cos2
2352           obrot2(1,i-2)=cos2
2353           obrot2(2,i-2)=sin2
2354           Ug(1,1,i-2)=-cos1
2355           Ug(1,2,i-2)=-sin1
2356           Ug(2,1,i-2)=-sin1
2357           Ug(2,2,i-2)= cos1
2358           Ug2(1,1,i-2)=-cos2
2359           Ug2(1,2,i-2)=-sin2
2360           Ug2(2,1,i-2)=-sin2
2361           Ug2(2,2,i-2)= cos2
2362         else
2363           costab(i-2)=1.0d0
2364           sintab(i-2)=0.0d0
2365           obrot(1,i-2)=1.0d0
2366           obrot(2,i-2)=0.0d0
2367           obrot2(1,i-2)=0.0d0
2368           obrot2(2,i-2)=0.0d0
2369           Ug(1,1,i-2)=1.0d0
2370           Ug(1,2,i-2)=0.0d0
2371           Ug(2,1,i-2)=0.0d0
2372           Ug(2,2,i-2)=1.0d0
2373           Ug2(1,1,i-2)=0.0d0
2374           Ug2(1,2,i-2)=0.0d0
2375           Ug2(2,1,i-2)=0.0d0
2376           Ug2(2,2,i-2)=0.0d0
2377         endif
2378         if (i .gt. 3 .and. i .lt. nres+1) then
2379           obrot_der(1,i-2)=-sin1
2380           obrot_der(2,i-2)= cos1
2381           Ugder(1,1,i-2)= sin1
2382           Ugder(1,2,i-2)=-cos1
2383           Ugder(2,1,i-2)=-cos1
2384           Ugder(2,2,i-2)=-sin1
2385           dwacos2=cos2+cos2
2386           dwasin2=sin2+sin2
2387           obrot2_der(1,i-2)=-dwasin2
2388           obrot2_der(2,i-2)= dwacos2
2389           Ug2der(1,1,i-2)= dwasin2
2390           Ug2der(1,2,i-2)=-dwacos2
2391           Ug2der(2,1,i-2)=-dwacos2
2392           Ug2der(2,2,i-2)=-dwasin2
2393         else
2394           obrot_der(1,i-2)=0.0d0
2395           obrot_der(2,i-2)=0.0d0
2396           Ugder(1,1,i-2)=0.0d0
2397           Ugder(1,2,i-2)=0.0d0
2398           Ugder(2,1,i-2)=0.0d0
2399           Ugder(2,2,i-2)=0.0d0
2400           obrot2_der(1,i-2)=0.0d0
2401           obrot2_der(2,i-2)=0.0d0
2402           Ug2der(1,1,i-2)=0.0d0
2403           Ug2der(1,2,i-2)=0.0d0
2404           Ug2der(2,1,i-2)=0.0d0
2405           Ug2der(2,2,i-2)=0.0d0
2406         endif
2407 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2408         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2409           iti = itortyp(itype(i-2))
2410         else
2411           iti=ntortyp+1
2412         endif
2413 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2414         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2415           iti1 = itortyp(itype(i-1))
2416         else
2417           iti1=ntortyp+1
2418         endif
2419 cd        write (iout,*) '*******i',i,' iti1',iti
2420 cd        write (iout,*) 'b1',b1(:,iti)
2421 cd        write (iout,*) 'b2',b2(:,iti)
2422 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2423 c        if (i .gt. iatel_s+2) then
2424         if (i .gt. nnt+2) then
2425           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2426 #ifdef NEWCORR
2427           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2428 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2429 #endif
2430 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2431 c     &    EE(1,2,iti),EE(2,2,iti)
2432           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2433           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2434 c          write(iout,*) "Macierz EUG",
2435 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2436 c     &    eug(2,2,i-2)
2437           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2438      &    then
2439           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2440           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2441           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2442           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2443           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2444           endif
2445         else
2446           do k=1,2
2447             Ub2(k,i-2)=0.0d0
2448             Ctobr(k,i-2)=0.0d0
2449             Dtobr2(k,i-2)=0.0d0
2450             do l=1,2
2451               EUg(l,k,i-2)=0.0d0
2452               CUg(l,k,i-2)=0.0d0
2453               DUg(l,k,i-2)=0.0d0
2454               DtUg2(l,k,i-2)=0.0d0
2455             enddo
2456           enddo
2457         endif
2458         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2459         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2460         do k=1,2
2461           muder(k,i-2)=Ub2der(k,i-2)
2462         enddo
2463 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2464         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2465           if (itype(i-1).le.ntyp) then
2466             iti1 = itortyp(itype(i-1))
2467           else
2468             iti1=ntortyp+1
2469           endif
2470         else
2471           iti1=ntortyp+1
2472         endif
2473         do k=1,2
2474           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2475         enddo
2476 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2477 cd        write (iout,*) 'mu1',mu1(:,i-2)
2478 cd        write (iout,*) 'mu2',mu2(:,i-2)
2479         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2480      &  then
2481         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2482         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2483         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2484         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2485         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2486 C Vectors and matrices dependent on a single virtual-bond dihedral.
2487         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2488         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2489         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2490         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2491         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2492         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2493         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2494         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2495         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2496         endif
2497       enddo
2498 C Matrices dependent on two consecutive virtual-bond dihedrals.
2499 C The order of matrices is from left to right.
2500       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2501      &then
2502 c      do i=max0(ivec_start,2),ivec_end
2503       do i=2,nres-1
2504         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2505         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2506         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2507         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2508         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2509         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2510         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2511         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2512       enddo
2513       endif
2514 #if defined(MPI) && defined(PARMAT)
2515 #ifdef DEBUG
2516 c      if (fg_rank.eq.0) then
2517         write (iout,*) "Arrays UG and UGDER before GATHER"
2518         do i=1,nres-1
2519           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2520      &     ((ug(l,k,i),l=1,2),k=1,2),
2521      &     ((ugder(l,k,i),l=1,2),k=1,2)
2522         enddo
2523         write (iout,*) "Arrays UG2 and UG2DER"
2524         do i=1,nres-1
2525           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2526      &     ((ug2(l,k,i),l=1,2),k=1,2),
2527      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2528         enddo
2529         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2530         do i=1,nres-1
2531           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2532      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2533      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2534         enddo
2535         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2536         do i=1,nres-1
2537           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2538      &     costab(i),sintab(i),costab2(i),sintab2(i)
2539         enddo
2540         write (iout,*) "Array MUDER"
2541         do i=1,nres-1
2542           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2543         enddo
2544 c      endif
2545 #endif
2546       if (nfgtasks.gt.1) then
2547         time00=MPI_Wtime()
2548 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2551 #ifdef MATGATHER
2552         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2571      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2572      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2573         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2574      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2575      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2576         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2577      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2578      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2579         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2580      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2581      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2582         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2583      &  then
2584         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2591      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2592      &   FG_COMM1,IERR)
2593        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2597      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2598      &   FG_COMM1,IERR)
2599         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2600      &   ivec_count(fg_rank1),
2601      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614      &   FG_COMM1,IERR)
2615         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2622      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2623      &   FG_COMM1,IERR)
2624         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2625      &   ivec_count(fg_rank1),
2626      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2630      &   FG_COMM1,IERR)
2631        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2641      &   ivec_count(fg_rank1),
2642      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2645      &   ivec_count(fg_rank1),
2646      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2647      &   FG_COMM1,IERR)
2648         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2649      &   ivec_count(fg_rank1),
2650      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2651      &   MPI_MAT2,FG_COMM1,IERR)
2652         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),
2654      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2655      &   MPI_MAT2,FG_COMM1,IERR)
2656         endif
2657 #else
2658 c Passes matrix info through the ring
2659       isend=fg_rank1
2660       irecv=fg_rank1-1
2661       if (irecv.lt.0) irecv=nfgtasks1-1
2662       iprev=irecv
2663       inext=fg_rank1+1
2664       if (inext.ge.nfgtasks1) inext=0
2665       do i=1,nfgtasks1-1
2666 c        write (iout,*) "isend",isend," irecv",irecv
2667 c        call flush(iout)
2668         lensend=lentyp(isend)
2669         lenrecv=lentyp(irecv)
2670 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2671 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2672 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2673 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2674 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2675 c        write (iout,*) "Gather ROTAT1"
2676 c        call flush(iout)
2677 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2678 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2679 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2680 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2681 c        write (iout,*) "Gather ROTAT2"
2682 c        call flush(iout)
2683         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2684      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2685      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2686      &   iprev,4400+irecv,FG_COMM,status,IERR)
2687 c        write (iout,*) "Gather ROTAT_OLD"
2688 c        call flush(iout)
2689         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2690      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2691      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2692      &   iprev,5500+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP11"
2694 c        call flush(iout)
2695         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2696      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2697      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2698      &   iprev,6600+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP12"
2700 c        call flush(iout)
2701         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2702      &  then
2703         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2704      &   MPI_ROTAT2(lensend),inext,7700+isend,
2705      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2706      &   iprev,7700+irecv,FG_COMM,status,IERR)
2707 c        write (iout,*) "Gather PRECOMP21"
2708 c        call flush(iout)
2709         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2710      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2711      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2712      &   iprev,8800+irecv,FG_COMM,status,IERR)
2713 c        write (iout,*) "Gather PRECOMP22"
2714 c        call flush(iout)
2715         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2716      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2717      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2718      &   MPI_PRECOMP23(lenrecv),
2719      &   iprev,9900+irecv,FG_COMM,status,IERR)
2720 c        write (iout,*) "Gather PRECOMP23"
2721 c        call flush(iout)
2722         endif
2723         isend=irecv
2724         irecv=irecv-1
2725         if (irecv.lt.0) irecv=nfgtasks1-1
2726       enddo
2727 #endif
2728         time_gather=time_gather+MPI_Wtime()-time00
2729       endif
2730 #ifdef DEBUG
2731 c      if (fg_rank.eq.0) then
2732         write (iout,*) "Arrays UG and UGDER"
2733         do i=1,nres-1
2734           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2735      &     ((ug(l,k,i),l=1,2),k=1,2),
2736      &     ((ugder(l,k,i),l=1,2),k=1,2)
2737         enddo
2738         write (iout,*) "Arrays UG2 and UG2DER"
2739         do i=1,nres-1
2740           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2741      &     ((ug2(l,k,i),l=1,2),k=1,2),
2742      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2743         enddo
2744         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2745         do i=1,nres-1
2746           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2747      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2748      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2749         enddo
2750         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2751         do i=1,nres-1
2752           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2753      &     costab(i),sintab(i),costab2(i),sintab2(i)
2754         enddo
2755         write (iout,*) "Array MUDER"
2756         do i=1,nres-1
2757           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2758         enddo
2759 c      endif
2760 #endif
2761 #endif
2762 cd      do i=1,nres
2763 cd        iti = itortyp(itype(i))
2764 cd        write (iout,*) i
2765 cd        do j=1,2
2766 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2767 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2768 cd        enddo
2769 cd      enddo
2770       return
2771       end
2772 C--------------------------------------------------------------------------
2773       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2774 C
2775 C This subroutine calculates the average interaction energy and its gradient
2776 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2777 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2778 C The potential depends both on the distance of peptide-group centers and on
2779 C the orientation of the CA-CA virtual bonds.
2780 C
2781       implicit real*8 (a-h,o-z)
2782 #ifdef MPI
2783       include 'mpif.h'
2784 #endif
2785       include 'DIMENSIONS'
2786       include 'COMMON.CONTROL'
2787       include 'COMMON.SETUP'
2788       include 'COMMON.IOUNITS'
2789       include 'COMMON.GEO'
2790       include 'COMMON.VAR'
2791       include 'COMMON.LOCAL'
2792       include 'COMMON.CHAIN'
2793       include 'COMMON.DERIV'
2794       include 'COMMON.INTERACT'
2795       include 'COMMON.CONTACTS'
2796       include 'COMMON.TORSION'
2797       include 'COMMON.VECTORS'
2798       include 'COMMON.FFIELD'
2799       include 'COMMON.TIME1'
2800       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2801      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2802       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2803      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2804       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2805      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2806      &    num_conti,j1,j2
2807 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2808 #ifdef MOMENT
2809       double precision scal_el /1.0d0/
2810 #else
2811       double precision scal_el /0.5d0/
2812 #endif
2813 C 12/13/98
2814 C 13-go grudnia roku pamietnego...
2815       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2816      &                   0.0d0,1.0d0,0.0d0,
2817      &                   0.0d0,0.0d0,1.0d0/
2818 cd      write(iout,*) 'In EELEC'
2819 cd      do i=1,nloctyp
2820 cd        write(iout,*) 'Type',i
2821 cd        write(iout,*) 'B1',B1(:,i)
2822 cd        write(iout,*) 'B2',B2(:,i)
2823 cd        write(iout,*) 'CC',CC(:,:,i)
2824 cd        write(iout,*) 'DD',DD(:,:,i)
2825 cd        write(iout,*) 'EE',EE(:,:,i)
2826 cd      enddo
2827 cd      call check_vecgrad
2828 cd      stop
2829       if (icheckgrad.eq.1) then
2830         do i=1,nres-1
2831           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2832           do k=1,3
2833             dc_norm(k,i)=dc(k,i)*fac
2834           enddo
2835 c          write (iout,*) 'i',i,' fac',fac
2836         enddo
2837       endif
2838       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2839      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2840      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2841 c        call vec_and_deriv
2842 #ifdef TIMING
2843         time01=MPI_Wtime()
2844 #endif
2845         call set_matrices
2846 #ifdef TIMING
2847         time_mat=time_mat+MPI_Wtime()-time01
2848 #endif
2849       endif
2850 cd      do i=1,nres-1
2851 cd        write (iout,*) 'i=',i
2852 cd        do k=1,3
2853 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2854 cd        enddo
2855 cd        do k=1,3
2856 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2857 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2858 cd        enddo
2859 cd      enddo
2860       t_eelecij=0.0d0
2861       ees=0.0D0
2862       evdw1=0.0D0
2863       eel_loc=0.0d0
2864       eello_turn3=0.0d0
2865       eello_turn4=0.0d0
2866       ind=0
2867       do i=1,nres
2868         num_cont_hb(i)=0
2869       enddo
2870 cd      print '(a)','Enter EELEC'
2871 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2872       do i=1,nres
2873         gel_loc_loc(i)=0.0d0
2874         gcorr_loc(i)=0.0d0
2875       enddo
2876 c
2877 c
2878 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2879 C
2880 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2881 C
2882       do i=iturn3_start,iturn3_end
2883         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2884      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2885         dxi=dc(1,i)
2886         dyi=dc(2,i)
2887         dzi=dc(3,i)
2888         dx_normi=dc_norm(1,i)
2889         dy_normi=dc_norm(2,i)
2890         dz_normi=dc_norm(3,i)
2891         xmedi=c(1,i)+0.5d0*dxi
2892         ymedi=c(2,i)+0.5d0*dyi
2893         zmedi=c(3,i)+0.5d0*dzi
2894         num_conti=0
2895         call eelecij(i,i+2,ees,evdw1,eel_loc)
2896         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2897         num_cont_hb(i)=num_conti
2898       enddo
2899       do i=iturn4_start,iturn4_end
2900         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2901      &    .or. itype(i+3).eq.ntyp1
2902      &    .or. itype(i+4).eq.ntyp1) cycle
2903         dxi=dc(1,i)
2904         dyi=dc(2,i)
2905         dzi=dc(3,i)
2906         dx_normi=dc_norm(1,i)
2907         dy_normi=dc_norm(2,i)
2908         dz_normi=dc_norm(3,i)
2909         xmedi=c(1,i)+0.5d0*dxi
2910         ymedi=c(2,i)+0.5d0*dyi
2911         zmedi=c(3,i)+0.5d0*dzi
2912         num_conti=num_cont_hb(i)
2913 c        write(iout,*) "JESTEM W PETLI"
2914         call eelecij(i,i+3,ees,evdw1,eel_loc)
2915         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2916      &   call eturn4(i,eello_turn4)
2917         num_cont_hb(i)=num_conti
2918       enddo   ! i
2919 c
2920 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2921 c
2922       do i=iatel_s,iatel_e
2923 c       do i=7,7
2924         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2925         dxi=dc(1,i)
2926         dyi=dc(2,i)
2927         dzi=dc(3,i)
2928         dx_normi=dc_norm(1,i)
2929         dy_normi=dc_norm(2,i)
2930         dz_normi=dc_norm(3,i)
2931         xmedi=c(1,i)+0.5d0*dxi
2932         ymedi=c(2,i)+0.5d0*dyi
2933         zmedi=c(3,i)+0.5d0*dzi
2934 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2935         num_conti=num_cont_hb(i)
2936         do j=ielstart(i),ielend(i)
2937 c         do j=13,13
2938 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2939           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2940           call eelecij(i,j,ees,evdw1,eel_loc)
2941         enddo ! j
2942         num_cont_hb(i)=num_conti
2943       enddo   ! i
2944 c      write (iout,*) "Number of loop steps in EELEC:",ind
2945 cd      do i=1,nres
2946 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2947 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2948 cd      enddo
2949 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2950 ccc      eel_loc=eel_loc+eello_turn3
2951 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2952       return
2953       end
2954 C-------------------------------------------------------------------------------
2955       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2956       implicit real*8 (a-h,o-z)
2957       include 'DIMENSIONS'
2958 #ifdef MPI
2959       include "mpif.h"
2960 #endif
2961       include 'COMMON.CONTROL'
2962       include 'COMMON.IOUNITS'
2963       include 'COMMON.GEO'
2964       include 'COMMON.VAR'
2965       include 'COMMON.LOCAL'
2966       include 'COMMON.CHAIN'
2967       include 'COMMON.DERIV'
2968       include 'COMMON.INTERACT'
2969       include 'COMMON.CONTACTS'
2970       include 'COMMON.TORSION'
2971       include 'COMMON.VECTORS'
2972       include 'COMMON.FFIELD'
2973       include 'COMMON.TIME1'
2974       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2975      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2976       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2977      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2978      &    gmuij2(4),gmuji2(4)
2979       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2980      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2981      &    num_conti,j1,j2
2982 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2983 #ifdef MOMENT
2984       double precision scal_el /1.0d0/
2985 #else
2986       double precision scal_el /0.5d0/
2987 #endif
2988 C 12/13/98
2989 C 13-go grudnia roku pamietnego...
2990       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2991      &                   0.0d0,1.0d0,0.0d0,
2992      &                   0.0d0,0.0d0,1.0d0/
2993 c          time00=MPI_Wtime()
2994 cd      write (iout,*) "eelecij",i,j
2995 c          ind=ind+1
2996           iteli=itel(i)
2997           itelj=itel(j)
2998           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2999           aaa=app(iteli,itelj)
3000           bbb=bpp(iteli,itelj)
3001           ael6i=ael6(iteli,itelj)
3002           ael3i=ael3(iteli,itelj)
3003           dxj=dc(1,j)
3004           dyj=dc(2,j)
3005           dzj=dc(3,j)
3006           dx_normj=dc_norm(1,j)
3007           dy_normj=dc_norm(2,j)
3008           dz_normj=dc_norm(3,j)
3009           xj=c(1,j)+0.5D0*dxj-xmedi
3010           yj=c(2,j)+0.5D0*dyj-ymedi
3011           zj=c(3,j)+0.5D0*dzj-zmedi
3012           rij=xj*xj+yj*yj+zj*zj
3013           rrmij=1.0D0/rij
3014           rij=dsqrt(rij)
3015           rmij=1.0D0/rij
3016           r3ij=rrmij*rmij
3017           r6ij=r3ij*r3ij
3018           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3019           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3020           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3021           fac=cosa-3.0D0*cosb*cosg
3022           ev1=aaa*r6ij*r6ij
3023 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3024           if (j.eq.i+2) ev1=scal_el*ev1
3025           ev2=bbb*r6ij
3026           fac3=ael6i*r6ij
3027           fac4=ael3i*r3ij
3028           evdwij=ev1+ev2
3029           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3030           el2=fac4*fac
3031           eesij=el1+el2
3032 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3033           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3034           ees=ees+eesij
3035           evdw1=evdw1+evdwij
3036 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3037 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3038 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3039 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3040
3041           if (energy_dec) then
3042               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3043      &'evdw1',i,j,evdwij
3044      &,iteli,itelj,aaa,evdw1
3045               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3046           endif
3047
3048 C
3049 C Calculate contributions to the Cartesian gradient.
3050 C
3051 #ifdef SPLITELE
3052           facvdw=-6*rrmij*(ev1+evdwij)
3053           facel=-3*rrmij*(el1+eesij)
3054           fac1=fac
3055           erij(1)=xj*rmij
3056           erij(2)=yj*rmij
3057           erij(3)=zj*rmij
3058 *
3059 * Radial derivatives. First process both termini of the fragment (i,j)
3060 *
3061           ggg(1)=facel*xj
3062           ggg(2)=facel*yj
3063           ggg(3)=facel*zj
3064 c          do k=1,3
3065 c            ghalf=0.5D0*ggg(k)
3066 c            gelc(k,i)=gelc(k,i)+ghalf
3067 c            gelc(k,j)=gelc(k,j)+ghalf
3068 c          enddo
3069 c 9/28/08 AL Gradient compotents will be summed only at the end
3070           do k=1,3
3071             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3072             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3073           enddo
3074 *
3075 * Loop over residues i+1 thru j-1.
3076 *
3077 cgrad          do k=i+1,j-1
3078 cgrad            do l=1,3
3079 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3080 cgrad            enddo
3081 cgrad          enddo
3082           ggg(1)=facvdw*xj
3083           ggg(2)=facvdw*yj
3084           ggg(3)=facvdw*zj
3085 c          do k=1,3
3086 c            ghalf=0.5D0*ggg(k)
3087 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3088 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3089 c          enddo
3090 c 9/28/08 AL Gradient compotents will be summed only at the end
3091           do k=1,3
3092             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3093             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3094           enddo
3095 *
3096 * Loop over residues i+1 thru j-1.
3097 *
3098 cgrad          do k=i+1,j-1
3099 cgrad            do l=1,3
3100 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3101 cgrad            enddo
3102 cgrad          enddo
3103 #else
3104           facvdw=ev1+evdwij
3105           facel=el1+eesij
3106           fac1=fac
3107           fac=-3*rrmij*(facvdw+facvdw+facel)
3108           erij(1)=xj*rmij
3109           erij(2)=yj*rmij
3110           erij(3)=zj*rmij
3111 *
3112 * Radial derivatives. First process both termini of the fragment (i,j)
3113 *
3114           ggg(1)=fac*xj
3115           ggg(2)=fac*yj
3116           ggg(3)=fac*zj
3117 c          do k=1,3
3118 c            ghalf=0.5D0*ggg(k)
3119 c            gelc(k,i)=gelc(k,i)+ghalf
3120 c            gelc(k,j)=gelc(k,j)+ghalf
3121 c          enddo
3122 c 9/28/08 AL Gradient compotents will be summed only at the end
3123           do k=1,3
3124             gelc_long(k,j)=gelc(k,j)+ggg(k)
3125             gelc_long(k,i)=gelc(k,i)-ggg(k)
3126           enddo
3127 *
3128 * Loop over residues i+1 thru j-1.
3129 *
3130 cgrad          do k=i+1,j-1
3131 cgrad            do l=1,3
3132 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3133 cgrad            enddo
3134 cgrad          enddo
3135 c 9/28/08 AL Gradient compotents will be summed only at the end
3136           ggg(1)=facvdw*xj
3137           ggg(2)=facvdw*yj
3138           ggg(3)=facvdw*zj
3139           do k=1,3
3140             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3141             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3142           enddo
3143 #endif
3144 *
3145 * Angular part
3146 *
3147           ecosa=2.0D0*fac3*fac1+fac4
3148           fac4=-3.0D0*fac4
3149           fac3=-6.0D0*fac3
3150           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3151           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3152           do k=1,3
3153             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3154             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3155           enddo
3156 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3157 cd   &          (dcosg(k),k=1,3)
3158           do k=1,3
3159             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3160           enddo
3161 c          do k=1,3
3162 c            ghalf=0.5D0*ggg(k)
3163 c            gelc(k,i)=gelc(k,i)+ghalf
3164 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3165 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3166 c            gelc(k,j)=gelc(k,j)+ghalf
3167 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3168 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3169 c          enddo
3170 cgrad          do k=i+1,j-1
3171 cgrad            do l=1,3
3172 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3173 cgrad            enddo
3174 cgrad          enddo
3175           do k=1,3
3176             gelc(k,i)=gelc(k,i)
3177      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3178      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3179             gelc(k,j)=gelc(k,j)
3180      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3181      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3182             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3183             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3184           enddo
3185           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3186      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3187      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3188 C
3189 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3190 C   energy of a peptide unit is assumed in the form of a second-order
3191 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3192 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3193 C   are computed for EVERY pair of non-contiguous peptide groups.
3194 C
3195
3196           if (j.lt.nres-1) then
3197             j1=j+1
3198             j2=j-1
3199           else
3200             j1=j-1
3201             j2=j-2
3202           endif
3203           kkk=0
3204           lll=0
3205           do k=1,2
3206             do l=1,2
3207               kkk=kkk+1
3208               muij(kkk)=mu(k,i)*mu(l,j)
3209 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3210 #ifdef NEWCORR
3211              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3212 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3213              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3214              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3215 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3216              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3217 #endif
3218             enddo
3219           enddo
3220 cd         write (iout,*) 'EELEC: i',i,' j',j
3221 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3222 cd          write(iout,*) 'muij',muij
3223           ury=scalar(uy(1,i),erij)
3224           urz=scalar(uz(1,i),erij)
3225           vry=scalar(uy(1,j),erij)
3226           vrz=scalar(uz(1,j),erij)
3227           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3228           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3229           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3230           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3231           fac=dsqrt(-ael6i)*r3ij
3232           a22=a22*fac
3233           a23=a23*fac
3234           a32=a32*fac
3235           a33=a33*fac
3236 cd          write (iout,'(4i5,4f10.5)')
3237 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3238 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3239 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3240 cd     &      uy(:,j),uz(:,j)
3241 cd          write (iout,'(4f10.5)')
3242 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3243 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3244 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3245 cd           write (iout,'(9f10.5/)')
3246 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3247 C Derivatives of the elements of A in virtual-bond vectors
3248           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3249           do k=1,3
3250             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3251             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3252             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3253             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3254             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3255             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3256             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3257             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3258             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3259             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3260             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3261             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3262           enddo
3263 C Compute radial contributions to the gradient
3264           facr=-3.0d0*rrmij
3265           a22der=a22*facr
3266           a23der=a23*facr
3267           a32der=a32*facr
3268           a33der=a33*facr
3269           agg(1,1)=a22der*xj
3270           agg(2,1)=a22der*yj
3271           agg(3,1)=a22der*zj
3272           agg(1,2)=a23der*xj
3273           agg(2,2)=a23der*yj
3274           agg(3,2)=a23der*zj
3275           agg(1,3)=a32der*xj
3276           agg(2,3)=a32der*yj
3277           agg(3,3)=a32der*zj
3278           agg(1,4)=a33der*xj
3279           agg(2,4)=a33der*yj
3280           agg(3,4)=a33der*zj
3281 C Add the contributions coming from er
3282           fac3=-3.0d0*fac
3283           do k=1,3
3284             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3285             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3286             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3287             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3288           enddo
3289           do k=1,3
3290 C Derivatives in DC(i)
3291 cgrad            ghalf1=0.5d0*agg(k,1)
3292 cgrad            ghalf2=0.5d0*agg(k,2)
3293 cgrad            ghalf3=0.5d0*agg(k,3)
3294 cgrad            ghalf4=0.5d0*agg(k,4)
3295             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3296      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3297             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3298      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3299             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3300      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3301             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3302      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3303 C Derivatives in DC(i+1)
3304             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3305      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3306             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3307      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3308             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3309      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3310             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3311      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3312 C Derivatives in DC(j)
3313             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3314      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3315             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3316      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3317             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3318      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3319             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3320      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3321 C Derivatives in DC(j+1) or DC(nres-1)
3322             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3323      &      -3.0d0*vryg(k,3)*ury)
3324             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3325      &      -3.0d0*vrzg(k,3)*ury)
3326             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3327      &      -3.0d0*vryg(k,3)*urz)
3328             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3329      &      -3.0d0*vrzg(k,3)*urz)
3330 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3331 cgrad              do l=1,4
3332 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3333 cgrad              enddo
3334 cgrad            endif
3335           enddo
3336           acipa(1,1)=a22
3337           acipa(1,2)=a23
3338           acipa(2,1)=a32
3339           acipa(2,2)=a33
3340           a22=-a22
3341           a23=-a23
3342           do l=1,2
3343             do k=1,3
3344               agg(k,l)=-agg(k,l)
3345               aggi(k,l)=-aggi(k,l)
3346               aggi1(k,l)=-aggi1(k,l)
3347               aggj(k,l)=-aggj(k,l)
3348               aggj1(k,l)=-aggj1(k,l)
3349             enddo
3350           enddo
3351           if (j.lt.nres-1) then
3352             a22=-a22
3353             a32=-a32
3354             do l=1,3,2
3355               do k=1,3
3356                 agg(k,l)=-agg(k,l)
3357                 aggi(k,l)=-aggi(k,l)
3358                 aggi1(k,l)=-aggi1(k,l)
3359                 aggj(k,l)=-aggj(k,l)
3360                 aggj1(k,l)=-aggj1(k,l)
3361               enddo
3362             enddo
3363           else
3364             a22=-a22
3365             a23=-a23
3366             a32=-a32
3367             a33=-a33
3368             do l=1,4
3369               do k=1,3
3370                 agg(k,l)=-agg(k,l)
3371                 aggi(k,l)=-aggi(k,l)
3372                 aggi1(k,l)=-aggi1(k,l)
3373                 aggj(k,l)=-aggj(k,l)
3374                 aggj1(k,l)=-aggj1(k,l)
3375               enddo
3376             enddo
3377           endif
3378           ENDIF ! WCORR
3379           IF (wel_loc.gt.0.0d0) THEN
3380 C Contribution to the local-electrostatic energy coming from the i-j pair
3381           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3382      &     +a33*muij(4)
3383 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3384 C Calculate patrial derivative for theta angle
3385 #ifdef NEWCORR
3386          geel_loc_ij=a22*gmuij1(1)
3387      &     +a23*gmuij1(2)
3388      &     +a32*gmuij1(3)
3389      &     +a33*gmuij1(4)
3390 c         write(iout,*) "derivative over thatai"
3391 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3392 c     &   a33*gmuij1(4)
3393          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3394      &      geel_loc_ij*wel_loc
3395 c         write(iout,*) "derivative over thatai-1"
3396 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3397 c     &   a33*gmuij2(4)
3398          geel_loc_ij=
3399      &     a22*gmuij2(1)
3400      &     +a23*gmuij2(2)
3401      &     +a32*gmuij2(3)
3402      &     +a33*gmuij2(4)
3403          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3404      &      geel_loc_ij*wel_loc
3405 c  Derivative over j residue
3406          geel_loc_ji=a22*gmuji1(1)
3407      &     +a23*gmuji1(2)
3408      &     +a32*gmuji1(3)
3409      &     +a33*gmuji1(4)
3410 c         write(iout,*) "derivative over thataj"
3411 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3412 c     &   a33*gmuji1(4)
3413
3414         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3415      &      geel_loc_ji*wel_loc
3416          geel_loc_ji=
3417      &     +a22*gmuji2(1)
3418      &     +a23*gmuji2(2)
3419      &     +a32*gmuji2(3)
3420      &     +a33*gmuji2(4)
3421 c         write(iout,*) "derivative over thataj-1"
3422 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3423 c     &   a33*gmuji2(4)
3424          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3425      &      geel_loc_ji*wel_loc
3426 #endif
3427 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3428
3429           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3430      &            'eelloc',i,j,eel_loc_ij
3431 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3432
3433           eel_loc=eel_loc+eel_loc_ij
3434 C Partial derivatives in virtual-bond dihedral angles gamma
3435           if (i.gt.1)
3436      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3437      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3438      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3439           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3440      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3441      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3442 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3443           do l=1,3
3444             ggg(l)=agg(l,1)*muij(1)+
3445      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3446             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3447             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3448 cgrad            ghalf=0.5d0*ggg(l)
3449 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3450 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3451           enddo
3452 cgrad          do k=i+1,j2
3453 cgrad            do l=1,3
3454 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3455 cgrad            enddo
3456 cgrad          enddo
3457 C Remaining derivatives of eello
3458           do l=1,3
3459             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3460      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3461             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3462      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3463             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3464      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3465             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3466      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3467           enddo
3468           ENDIF
3469 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3470 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3471           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3472      &       .and. num_conti.le.maxconts) then
3473 c            write (iout,*) i,j," entered corr"
3474 C
3475 C Calculate the contact function. The ith column of the array JCONT will
3476 C contain the numbers of atoms that make contacts with the atom I (of numbers
3477 C greater than I). The arrays FACONT and GACONT will contain the values of
3478 C the contact function and its derivative.
3479 c           r0ij=1.02D0*rpp(iteli,itelj)
3480 c           r0ij=1.11D0*rpp(iteli,itelj)
3481             r0ij=2.20D0*rpp(iteli,itelj)
3482 c           r0ij=1.55D0*rpp(iteli,itelj)
3483             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3484             if (fcont.gt.0.0D0) then
3485               num_conti=num_conti+1
3486               if (num_conti.gt.maxconts) then
3487                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3488      &                         ' will skip next contacts for this conf.'
3489               else
3490                 jcont_hb(num_conti,i)=j
3491 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3492 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3493                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3494      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3495 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3496 C  terms.
3497                 d_cont(num_conti,i)=rij
3498 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3499 C     --- Electrostatic-interaction matrix ---
3500                 a_chuj(1,1,num_conti,i)=a22
3501                 a_chuj(1,2,num_conti,i)=a23
3502                 a_chuj(2,1,num_conti,i)=a32
3503                 a_chuj(2,2,num_conti,i)=a33
3504 C     --- Gradient of rij
3505                 do kkk=1,3
3506                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3507                 enddo
3508                 kkll=0
3509                 do k=1,2
3510                   do l=1,2
3511                     kkll=kkll+1
3512                     do m=1,3
3513                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3514                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3515                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3516                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3517                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3518                     enddo
3519                   enddo
3520                 enddo
3521                 ENDIF
3522                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3523 C Calculate contact energies
3524                 cosa4=4.0D0*cosa
3525                 wij=cosa-3.0D0*cosb*cosg
3526                 cosbg1=cosb+cosg
3527                 cosbg2=cosb-cosg
3528 c               fac3=dsqrt(-ael6i)/r0ij**3
3529                 fac3=dsqrt(-ael6i)*r3ij
3530 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3531                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3532                 if (ees0tmp.gt.0) then
3533                   ees0pij=dsqrt(ees0tmp)
3534                 else
3535                   ees0pij=0
3536                 endif
3537 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3538                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3539                 if (ees0tmp.gt.0) then
3540                   ees0mij=dsqrt(ees0tmp)
3541                 else
3542                   ees0mij=0
3543                 endif
3544 c               ees0mij=0.0D0
3545                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3546                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3547 C Diagnostics. Comment out or remove after debugging!
3548 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3549 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3550 c               ees0m(num_conti,i)=0.0D0
3551 C End diagnostics.
3552 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3553 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3554 C Angular derivatives of the contact function
3555                 ees0pij1=fac3/ees0pij
3556                 ees0mij1=fac3/ees0mij
3557                 fac3p=-3.0D0*fac3*rrmij
3558                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3559                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3560 c               ees0mij1=0.0D0
3561                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3562                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3563                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3564                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3565                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3566                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3567                 ecosap=ecosa1+ecosa2
3568                 ecosbp=ecosb1+ecosb2
3569                 ecosgp=ecosg1+ecosg2
3570                 ecosam=ecosa1-ecosa2
3571                 ecosbm=ecosb1-ecosb2
3572                 ecosgm=ecosg1-ecosg2
3573 C Diagnostics
3574 c               ecosap=ecosa1
3575 c               ecosbp=ecosb1
3576 c               ecosgp=ecosg1
3577 c               ecosam=0.0D0
3578 c               ecosbm=0.0D0
3579 c               ecosgm=0.0D0
3580 C End diagnostics
3581                 facont_hb(num_conti,i)=fcont
3582                 fprimcont=fprimcont/rij
3583 cd              facont_hb(num_conti,i)=1.0D0
3584 C Following line is for diagnostics.
3585 cd              fprimcont=0.0D0
3586                 do k=1,3
3587                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3588                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3589                 enddo
3590                 do k=1,3
3591                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3592                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3593                 enddo
3594                 gggp(1)=gggp(1)+ees0pijp*xj
3595                 gggp(2)=gggp(2)+ees0pijp*yj
3596                 gggp(3)=gggp(3)+ees0pijp*zj
3597                 gggm(1)=gggm(1)+ees0mijp*xj
3598                 gggm(2)=gggm(2)+ees0mijp*yj
3599                 gggm(3)=gggm(3)+ees0mijp*zj
3600 C Derivatives due to the contact function
3601                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3602                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3603                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3604                 do k=1,3
3605 c
3606 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3607 c          following the change of gradient-summation algorithm.
3608 c
3609 cgrad                  ghalfp=0.5D0*gggp(k)
3610 cgrad                  ghalfm=0.5D0*gggm(k)
3611                   gacontp_hb1(k,num_conti,i)=!ghalfp
3612      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3613      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3614                   gacontp_hb2(k,num_conti,i)=!ghalfp
3615      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3616      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3617                   gacontp_hb3(k,num_conti,i)=gggp(k)
3618                   gacontm_hb1(k,num_conti,i)=!ghalfm
3619      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3620      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3621                   gacontm_hb2(k,num_conti,i)=!ghalfm
3622      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3623      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3624                   gacontm_hb3(k,num_conti,i)=gggm(k)
3625                 enddo
3626 C Diagnostics. Comment out or remove after debugging!
3627 cdiag           do k=1,3
3628 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3629 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3630 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3631 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3632 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3633 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3634 cdiag           enddo
3635               ENDIF ! wcorr
3636               endif  ! num_conti.le.maxconts
3637             endif  ! fcont.gt.0
3638           endif    ! j.gt.i+1
3639           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3640             do k=1,4
3641               do l=1,3
3642                 ghalf=0.5d0*agg(l,k)
3643                 aggi(l,k)=aggi(l,k)+ghalf
3644                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3645                 aggj(l,k)=aggj(l,k)+ghalf
3646               enddo
3647             enddo
3648             if (j.eq.nres-1 .and. i.lt.j-2) then
3649               do k=1,4
3650                 do l=1,3
3651                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3652                 enddo
3653               enddo
3654             endif
3655           endif
3656 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3657       return
3658       end
3659 C-----------------------------------------------------------------------------
3660       subroutine eturn3(i,eello_turn3)
3661 C Third- and fourth-order contributions from turns
3662       implicit real*8 (a-h,o-z)
3663       include 'DIMENSIONS'
3664       include 'COMMON.IOUNITS'
3665       include 'COMMON.GEO'
3666       include 'COMMON.VAR'
3667       include 'COMMON.LOCAL'
3668       include 'COMMON.CHAIN'
3669       include 'COMMON.DERIV'
3670       include 'COMMON.INTERACT'
3671       include 'COMMON.CONTACTS'
3672       include 'COMMON.TORSION'
3673       include 'COMMON.VECTORS'
3674       include 'COMMON.FFIELD'
3675       include 'COMMON.CONTROL'
3676       dimension ggg(3)
3677       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3678      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3679      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3680      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3681      &  auxgmat2(2,2),auxgmatt2(2,2)
3682       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3683      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3684       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3685      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3686      &    num_conti,j1,j2
3687       j=i+2
3688 c      write (iout,*) "eturn3",i,j,j1,j2
3689       a_temp(1,1)=a22
3690       a_temp(1,2)=a23
3691       a_temp(2,1)=a32
3692       a_temp(2,2)=a33
3693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3694 C
3695 C               Third-order contributions
3696 C
3697 C                 (i+2)o----(i+3)
3698 C                      | |
3699 C                      | |
3700 C                 (i+1)o----i
3701 C
3702 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3703 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3704         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3705 c auxalary matices for theta gradient
3706 c auxalary matrix for i+1 and constant i+2
3707         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3708 c auxalary matrix for i+2 and constant i+1
3709         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3710         call transpose2(auxmat(1,1),auxmat1(1,1))
3711         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3712         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3713         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3714         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3715         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3716         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3717 C Derivatives in theta
3718         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3719      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3720         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3721      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3722
3723         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3724      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3725 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3726 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3727 cd     &    ' eello_turn3_num',4*eello_turn3_num
3728 C Derivatives in gamma(i)
3729         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3730         call transpose2(auxmat2(1,1),auxmat3(1,1))
3731         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3732         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3733 C Derivatives in gamma(i+1)
3734         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3735         call transpose2(auxmat2(1,1),auxmat3(1,1))
3736         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3737         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3738      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3739 C Cartesian derivatives
3740         do l=1,3
3741 c            ghalf1=0.5d0*agg(l,1)
3742 c            ghalf2=0.5d0*agg(l,2)
3743 c            ghalf3=0.5d0*agg(l,3)
3744 c            ghalf4=0.5d0*agg(l,4)
3745           a_temp(1,1)=aggi(l,1)!+ghalf1
3746           a_temp(1,2)=aggi(l,2)!+ghalf2
3747           a_temp(2,1)=aggi(l,3)!+ghalf3
3748           a_temp(2,2)=aggi(l,4)!+ghalf4
3749           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3750           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3751      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3752           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3753           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3754           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3755           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3756           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3757           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3758      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3759           a_temp(1,1)=aggj(l,1)!+ghalf1
3760           a_temp(1,2)=aggj(l,2)!+ghalf2
3761           a_temp(2,1)=aggj(l,3)!+ghalf3
3762           a_temp(2,2)=aggj(l,4)!+ghalf4
3763           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3764           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3765      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3766           a_temp(1,1)=aggj1(l,1)
3767           a_temp(1,2)=aggj1(l,2)
3768           a_temp(2,1)=aggj1(l,3)
3769           a_temp(2,2)=aggj1(l,4)
3770           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3771           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3772      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3773         enddo
3774       return
3775       end
3776 C-------------------------------------------------------------------------------
3777       subroutine eturn4(i,eello_turn4)
3778 C Third- and fourth-order contributions from turns
3779       implicit real*8 (a-h,o-z)
3780       include 'DIMENSIONS'
3781       include 'COMMON.IOUNITS'
3782       include 'COMMON.GEO'
3783       include 'COMMON.VAR'
3784       include 'COMMON.LOCAL'
3785       include 'COMMON.CHAIN'
3786       include 'COMMON.DERIV'
3787       include 'COMMON.INTERACT'
3788       include 'COMMON.CONTACTS'
3789       include 'COMMON.TORSION'
3790       include 'COMMON.VECTORS'
3791       include 'COMMON.FFIELD'
3792       include 'COMMON.CONTROL'
3793       dimension ggg(3)
3794       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3795      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3796      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3797      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3798      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3799      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3800      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3801       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3802      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3803       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3804      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3805      &    num_conti,j1,j2
3806       j=i+3
3807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3808 C
3809 C               Fourth-order contributions
3810 C
3811 C                 (i+3)o----(i+4)
3812 C                     /  |
3813 C               (i+2)o   |
3814 C                     \  |
3815 C                 (i+1)o----i
3816 C
3817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3818 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3819 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3820 c        write(iout,*)"WCHODZE W PROGRAM"
3821         a_temp(1,1)=a22
3822         a_temp(1,2)=a23
3823         a_temp(2,1)=a32
3824         a_temp(2,2)=a33
3825         iti1=itortyp(itype(i+1))
3826         iti2=itortyp(itype(i+2))
3827         iti3=itortyp(itype(i+3))
3828 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3829         call transpose2(EUg(1,1,i+1),e1t(1,1))
3830         call transpose2(Eug(1,1,i+2),e2t(1,1))
3831         call transpose2(Eug(1,1,i+3),e3t(1,1))
3832 C Ematrix derivative in theta
3833         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3834         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3835         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3836         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3837 c       eta1 in derivative theta
3838         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3839         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3840 c       auxgvec is derivative of Ub2 so i+3 theta
3841         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3842 c       auxalary matrix of E i+1
3843         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3844 c        s1=0.0
3845 c        gs1=0.0
3846         s1=scalar2(b1(1,i+2),auxvec(1))
3847 c derivative of theta i+2 with constant i+3
3848         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3849 c derivative of theta i+2 with constant i+2
3850         gs32=scalar2(b1(1,i+2),auxgvec(1))
3851 c derivative of E matix in theta of i+1
3852         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3853
3854         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3855 c       ea31 in derivative theta
3856         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3857         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3858 c auxilary matrix auxgvec of Ub2 with constant E matirx
3859         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3860 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3861         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3862
3863 c        s2=0.0
3864 c        gs2=0.0
3865         s2=scalar2(b1(1,i+1),auxvec(1))
3866 c derivative of theta i+1 with constant i+3
3867         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3868 c derivative of theta i+2 with constant i+1
3869         gs21=scalar2(b1(1,i+1),auxgvec(1))
3870 c derivative of theta i+3 with constant i+1
3871         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3872 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3873 c     &  gtb1(1,i+1)
3874         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3875 c two derivatives over diffetent matrices
3876 c gtae3e2 is derivative over i+3
3877         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3878 c ae3gte2 is derivative over i+2
3879         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3880         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3881 c three possible derivative over theta E matices
3882 c i+1
3883         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3884 c i+2
3885         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3886 c i+3
3887         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3888         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889
3890         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3891         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3892         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3893
3894         eello_turn4=eello_turn4-(s1+s2+s3)
3895 #ifdef NEWCORR
3896         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3897      &                  -(gs13+gsE13+gsEE1)*wturn4
3898         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3899      &                    -(gs23+gs21+gsEE2)*wturn4
3900         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3901      &                    -(gs32+gsE31+gsEE3)*wturn4
3902 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3903 c     &   gs2
3904 #endif
3905         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3906      &      'eturn4',i,j,-(s1+s2+s3)
3907 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3908 c     &    ' eello_turn4_num',8*eello_turn4_num
3909 C Derivatives in gamma(i)
3910         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3911         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3912         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3913         s1=scalar2(b1(1,i+2),auxvec(1))
3914         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3915         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3916         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3917 C Derivatives in gamma(i+1)
3918         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3919         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3920         s2=scalar2(b1(1,i+1),auxvec(1))
3921         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3922         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3923         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3924         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3925 C Derivatives in gamma(i+2)
3926         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3927         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3928         s1=scalar2(b1(1,i+2),auxvec(1))
3929         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3930         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3931         s2=scalar2(b1(1,i+1),auxvec(1))
3932         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3933         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3934         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3935         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3936 C Cartesian derivatives
3937 C Derivatives of this turn contributions in DC(i+2)
3938         if (j.lt.nres-1) then
3939           do l=1,3
3940             a_temp(1,1)=agg(l,1)
3941             a_temp(1,2)=agg(l,2)
3942             a_temp(2,1)=agg(l,3)
3943             a_temp(2,2)=agg(l,4)
3944             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3945             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3946             s1=scalar2(b1(1,i+2),auxvec(1))
3947             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3948             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3949             s2=scalar2(b1(1,i+1),auxvec(1))
3950             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3951             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3952             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3953             ggg(l)=-(s1+s2+s3)
3954             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3955           enddo
3956         endif
3957 C Remaining derivatives of this turn contribution
3958         do l=1,3
3959           a_temp(1,1)=aggi(l,1)
3960           a_temp(1,2)=aggi(l,2)
3961           a_temp(2,1)=aggi(l,3)
3962           a_temp(2,2)=aggi(l,4)
3963           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3964           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3965           s1=scalar2(b1(1,i+2),auxvec(1))
3966           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3967           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3968           s2=scalar2(b1(1,i+1),auxvec(1))
3969           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3970           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3971           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3973           a_temp(1,1)=aggi1(l,1)
3974           a_temp(1,2)=aggi1(l,2)
3975           a_temp(2,1)=aggi1(l,3)
3976           a_temp(2,2)=aggi1(l,4)
3977           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3978           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3979           s1=scalar2(b1(1,i+2),auxvec(1))
3980           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3981           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3982           s2=scalar2(b1(1,i+1),auxvec(1))
3983           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3984           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3985           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3986           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3987           a_temp(1,1)=aggj(l,1)
3988           a_temp(1,2)=aggj(l,2)
3989           a_temp(2,1)=aggj(l,3)
3990           a_temp(2,2)=aggj(l,4)
3991           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3992           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3993           s1=scalar2(b1(1,i+2),auxvec(1))
3994           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3995           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3996           s2=scalar2(b1(1,i+1),auxvec(1))
3997           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3998           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3999           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4000           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4001           a_temp(1,1)=aggj1(l,1)
4002           a_temp(1,2)=aggj1(l,2)
4003           a_temp(2,1)=aggj1(l,3)
4004           a_temp(2,2)=aggj1(l,4)
4005           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4006           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4007           s1=scalar2(b1(1,i+2),auxvec(1))
4008           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4009           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4010           s2=scalar2(b1(1,i+1),auxvec(1))
4011           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4012           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4013           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4014 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4015           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4016         enddo
4017       return
4018       end
4019 C-----------------------------------------------------------------------------
4020       subroutine vecpr(u,v,w)
4021       implicit real*8(a-h,o-z)
4022       dimension u(3),v(3),w(3)
4023       w(1)=u(2)*v(3)-u(3)*v(2)
4024       w(2)=-u(1)*v(3)+u(3)*v(1)
4025       w(3)=u(1)*v(2)-u(2)*v(1)
4026       return
4027       end
4028 C-----------------------------------------------------------------------------
4029       subroutine unormderiv(u,ugrad,unorm,ungrad)
4030 C This subroutine computes the derivatives of a normalized vector u, given
4031 C the derivatives computed without normalization conditions, ugrad. Returns
4032 C ungrad.
4033       implicit none
4034       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4035       double precision vec(3)
4036       double precision scalar
4037       integer i,j
4038 c      write (2,*) 'ugrad',ugrad
4039 c      write (2,*) 'u',u
4040       do i=1,3
4041         vec(i)=scalar(ugrad(1,i),u(1))
4042       enddo
4043 c      write (2,*) 'vec',vec
4044       do i=1,3
4045         do j=1,3
4046           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4047         enddo
4048       enddo
4049 c      write (2,*) 'ungrad',ungrad
4050       return
4051       end
4052 C-----------------------------------------------------------------------------
4053       subroutine escp_soft_sphere(evdw2,evdw2_14)
4054 C
4055 C This subroutine calculates the excluded-volume interaction energy between
4056 C peptide-group centers and side chains and its gradient in virtual-bond and
4057 C side-chain vectors.
4058 C
4059       implicit real*8 (a-h,o-z)
4060       include 'DIMENSIONS'
4061       include 'COMMON.GEO'
4062       include 'COMMON.VAR'
4063       include 'COMMON.LOCAL'
4064       include 'COMMON.CHAIN'
4065       include 'COMMON.DERIV'
4066       include 'COMMON.INTERACT'
4067       include 'COMMON.FFIELD'
4068       include 'COMMON.IOUNITS'
4069       include 'COMMON.CONTROL'
4070       dimension ggg(3)
4071       evdw2=0.0D0
4072       evdw2_14=0.0d0
4073       r0_scp=4.5d0
4074 cd    print '(a)','Enter ESCP'
4075 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4076       do i=iatscp_s,iatscp_e
4077         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4078         iteli=itel(i)
4079         xi=0.5D0*(c(1,i)+c(1,i+1))
4080         yi=0.5D0*(c(2,i)+c(2,i+1))
4081         zi=0.5D0*(c(3,i)+c(3,i+1))
4082
4083         do iint=1,nscp_gr(i)
4084
4085         do j=iscpstart(i,iint),iscpend(i,iint)
4086           if (itype(j).eq.ntyp1) cycle
4087           itypj=iabs(itype(j))
4088 C Uncomment following three lines for SC-p interactions
4089 c         xj=c(1,nres+j)-xi
4090 c         yj=c(2,nres+j)-yi
4091 c         zj=c(3,nres+j)-zi
4092 C Uncomment following three lines for Ca-p interactions
4093           xj=c(1,j)-xi
4094           yj=c(2,j)-yi
4095           zj=c(3,j)-zi
4096           rij=xj*xj+yj*yj+zj*zj
4097           r0ij=r0_scp
4098           r0ijsq=r0ij*r0ij
4099           if (rij.lt.r0ijsq) then
4100             evdwij=0.25d0*(rij-r0ijsq)**2
4101             fac=rij-r0ijsq
4102           else
4103             evdwij=0.0d0
4104             fac=0.0d0
4105           endif
4106           evdw2=evdw2+evdwij
4107 C
4108 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4109 C
4110           ggg(1)=xj*fac
4111           ggg(2)=yj*fac
4112           ggg(3)=zj*fac
4113 cgrad          if (j.lt.i) then
4114 cd          write (iout,*) 'j<i'
4115 C Uncomment following three lines for SC-p interactions
4116 c           do k=1,3
4117 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4118 c           enddo
4119 cgrad          else
4120 cd          write (iout,*) 'j>i'
4121 cgrad            do k=1,3
4122 cgrad              ggg(k)=-ggg(k)
4123 C Uncomment following line for SC-p interactions
4124 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4125 cgrad            enddo
4126 cgrad          endif
4127 cgrad          do k=1,3
4128 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4129 cgrad          enddo
4130 cgrad          kstart=min0(i+1,j)
4131 cgrad          kend=max0(i-1,j-1)
4132 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4133 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4134 cgrad          do k=kstart,kend
4135 cgrad            do l=1,3
4136 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4137 cgrad            enddo
4138 cgrad          enddo
4139           do k=1,3
4140             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4141             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4142           enddo
4143         enddo
4144
4145         enddo ! iint
4146       enddo ! i
4147       return
4148       end
4149 C-----------------------------------------------------------------------------
4150       subroutine escp(evdw2,evdw2_14)
4151 C
4152 C This subroutine calculates the excluded-volume interaction energy between
4153 C peptide-group centers and side chains and its gradient in virtual-bond and
4154 C side-chain vectors.
4155 C
4156       implicit real*8 (a-h,o-z)
4157       include 'DIMENSIONS'
4158       include 'COMMON.GEO'
4159       include 'COMMON.VAR'
4160       include 'COMMON.LOCAL'
4161       include 'COMMON.CHAIN'
4162       include 'COMMON.DERIV'
4163       include 'COMMON.INTERACT'
4164       include 'COMMON.FFIELD'
4165       include 'COMMON.IOUNITS'
4166       include 'COMMON.CONTROL'
4167       dimension ggg(3)
4168       evdw2=0.0D0
4169       evdw2_14=0.0d0
4170 cd    print '(a)','Enter ESCP'
4171 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4172       do i=iatscp_s,iatscp_e
4173         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4174         iteli=itel(i)
4175         xi=0.5D0*(c(1,i)+c(1,i+1))
4176         yi=0.5D0*(c(2,i)+c(2,i+1))
4177         zi=0.5D0*(c(3,i)+c(3,i+1))
4178
4179         do iint=1,nscp_gr(i)
4180
4181         do j=iscpstart(i,iint),iscpend(i,iint)
4182           itypj=iabs(itype(j))
4183           if (itypj.eq.ntyp1) cycle
4184 C Uncomment following three lines for SC-p interactions
4185 c         xj=c(1,nres+j)-xi
4186 c         yj=c(2,nres+j)-yi
4187 c         zj=c(3,nres+j)-zi
4188 C Uncomment following three lines for Ca-p interactions
4189           xj=c(1,j)-xi
4190           yj=c(2,j)-yi
4191           zj=c(3,j)-zi
4192           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4193           fac=rrij**expon2
4194           e1=fac*fac*aad(itypj,iteli)
4195           e2=fac*bad(itypj,iteli)
4196           if (iabs(j-i) .le. 2) then
4197             e1=scal14*e1
4198             e2=scal14*e2
4199             evdw2_14=evdw2_14+e1+e2
4200           endif
4201           evdwij=e1+e2
4202           evdw2=evdw2+evdwij
4203           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4204      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4205      &       bad(itypj,iteli)
4206 C
4207 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4208 C
4209           fac=-(evdwij+e1)*rrij
4210           ggg(1)=xj*fac
4211           ggg(2)=yj*fac
4212           ggg(3)=zj*fac
4213 cgrad          if (j.lt.i) then
4214 cd          write (iout,*) 'j<i'
4215 C Uncomment following three lines for SC-p interactions
4216 c           do k=1,3
4217 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4218 c           enddo
4219 cgrad          else
4220 cd          write (iout,*) 'j>i'
4221 cgrad            do k=1,3
4222 cgrad              ggg(k)=-ggg(k)
4223 C Uncomment following line for SC-p interactions
4224 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4225 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4226 cgrad            enddo
4227 cgrad          endif
4228 cgrad          do k=1,3
4229 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4230 cgrad          enddo
4231 cgrad          kstart=min0(i+1,j)
4232 cgrad          kend=max0(i-1,j-1)
4233 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4234 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4235 cgrad          do k=kstart,kend
4236 cgrad            do l=1,3
4237 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4238 cgrad            enddo
4239 cgrad          enddo
4240           do k=1,3
4241             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4242             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4243           enddo
4244         enddo
4245
4246         enddo ! iint
4247       enddo ! i
4248       do i=1,nct
4249         do j=1,3
4250           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4251           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4252           gradx_scp(j,i)=expon*gradx_scp(j,i)
4253         enddo
4254       enddo
4255 C******************************************************************************
4256 C
4257 C                              N O T E !!!
4258 C
4259 C To save time the factor EXPON has been extracted from ALL components
4260 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4261 C use!
4262 C
4263 C******************************************************************************
4264       return
4265       end
4266 C--------------------------------------------------------------------------
4267       subroutine edis(ehpb)
4268 C
4269 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4270 C
4271       implicit real*8 (a-h,o-z)
4272       include 'DIMENSIONS'
4273       include 'COMMON.SBRIDGE'
4274       include 'COMMON.CHAIN'
4275       include 'COMMON.DERIV'
4276       include 'COMMON.VAR'
4277       include 'COMMON.INTERACT'
4278       include 'COMMON.IOUNITS'
4279       dimension ggg(3)
4280       ehpb=0.0D0
4281 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4282 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4283       if (link_end.eq.0) return
4284       do i=link_start,link_end
4285 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4286 C CA-CA distance used in regularization of structure.
4287         ii=ihpb(i)
4288         jj=jhpb(i)
4289 C iii and jjj point to the residues for which the distance is assigned.
4290         if (ii.gt.nres) then
4291           iii=ii-nres
4292           jjj=jj-nres
4293         else
4294           iii=ii
4295           jjj=jj
4296         endif
4297 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4298 c     &    dhpb(i),dhpb1(i),forcon(i)
4299 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4300 C    distance and angle dependent SS bond potential.
4301         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4302      & iabs(itype(jjj)).eq.1) then
4303 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4304 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4305         if (.not.dyn_ss .and. i.le.nss) then
4306 C 15/02/13 CC dynamic SSbond - additional check
4307           call ssbond_ene(iii,jjj,eij)
4308           ehpb=ehpb+2*eij
4309          endif
4310 cd          write (iout,*) "eij",eij
4311         else
4312 C Calculate the distance between the two points and its difference from the
4313 C target distance.
4314           dd=dist(ii,jj)
4315             rdis=dd-dhpb(i)
4316 C Get the force constant corresponding to this distance.
4317             waga=forcon(i)
4318 C Calculate the contribution to energy.
4319             ehpb=ehpb+waga*rdis*rdis
4320 C
4321 C Evaluate gradient.
4322 C
4323             fac=waga*rdis/dd
4324 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4325 cd   &   ' waga=',waga,' fac=',fac
4326             do j=1,3
4327               ggg(j)=fac*(c(j,jj)-c(j,ii))
4328             enddo
4329 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4330 C If this is a SC-SC distance, we need to calculate the contributions to the
4331 C Cartesian gradient in the SC vectors (ghpbx).
4332           if (iii.lt.ii) then
4333           do j=1,3
4334             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4335             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4336           enddo
4337           endif
4338 cgrad        do j=iii,jjj-1
4339 cgrad          do k=1,3
4340 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4341 cgrad          enddo
4342 cgrad        enddo
4343           do k=1,3
4344             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4345             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4346           enddo
4347         endif
4348       enddo
4349       ehpb=0.5D0*ehpb
4350       return
4351       end
4352 C--------------------------------------------------------------------------
4353       subroutine ssbond_ene(i,j,eij)
4354 C
4355 C Calculate the distance and angle dependent SS-bond potential energy
4356 C using a free-energy function derived based on RHF/6-31G** ab initio
4357 C calculations of diethyl disulfide.
4358 C
4359 C A. Liwo and U. Kozlowska, 11/24/03
4360 C
4361       implicit real*8 (a-h,o-z)
4362       include 'DIMENSIONS'
4363       include 'COMMON.SBRIDGE'
4364       include 'COMMON.CHAIN'
4365       include 'COMMON.DERIV'
4366       include 'COMMON.LOCAL'
4367       include 'COMMON.INTERACT'
4368       include 'COMMON.VAR'
4369       include 'COMMON.IOUNITS'
4370       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4371       itypi=iabs(itype(i))
4372       xi=c(1,nres+i)
4373       yi=c(2,nres+i)
4374       zi=c(3,nres+i)
4375       dxi=dc_norm(1,nres+i)
4376       dyi=dc_norm(2,nres+i)
4377       dzi=dc_norm(3,nres+i)
4378 c      dsci_inv=dsc_inv(itypi)
4379       dsci_inv=vbld_inv(nres+i)
4380       itypj=iabs(itype(j))
4381 c      dscj_inv=dsc_inv(itypj)
4382       dscj_inv=vbld_inv(nres+j)
4383       xj=c(1,nres+j)-xi
4384       yj=c(2,nres+j)-yi
4385       zj=c(3,nres+j)-zi
4386       dxj=dc_norm(1,nres+j)
4387       dyj=dc_norm(2,nres+j)
4388       dzj=dc_norm(3,nres+j)
4389       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4390       rij=dsqrt(rrij)
4391       erij(1)=xj*rij
4392       erij(2)=yj*rij
4393       erij(3)=zj*rij
4394       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4395       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4396       om12=dxi*dxj+dyi*dyj+dzi*dzj
4397       do k=1,3
4398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4400       enddo
4401       rij=1.0d0/rij
4402       deltad=rij-d0cm
4403       deltat1=1.0d0-om1
4404       deltat2=1.0d0+om2
4405       deltat12=om2-om1+2.0d0
4406       cosphi=om12-om1*om2
4407       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4408      &  +akct*deltad*deltat12
4409      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4410 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4411 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4412 c     &  " deltat12",deltat12," eij",eij
4413       ed=2*akcm*deltad+akct*deltat12
4414       pom1=akct*deltad
4415       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4416       eom1=-2*akth*deltat1-pom1-om2*pom2
4417       eom2= 2*akth*deltat2+pom1-om1*pom2
4418       eom12=pom2
4419       do k=1,3
4420         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4421         ghpbx(k,i)=ghpbx(k,i)-ggk
4422      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4423      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4424         ghpbx(k,j)=ghpbx(k,j)+ggk
4425      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4426      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4427         ghpbc(k,i)=ghpbc(k,i)-ggk
4428         ghpbc(k,j)=ghpbc(k,j)+ggk
4429       enddo
4430 C
4431 C Calculate the components of the gradient in DC and X
4432 C
4433 cgrad      do k=i,j-1
4434 cgrad        do l=1,3
4435 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4436 cgrad        enddo
4437 cgrad      enddo
4438       return
4439       end
4440 C--------------------------------------------------------------------------
4441       subroutine ebond(estr)
4442 c
4443 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4444 c
4445       implicit real*8 (a-h,o-z)
4446       include 'DIMENSIONS'
4447       include 'COMMON.LOCAL'
4448       include 'COMMON.GEO'
4449       include 'COMMON.INTERACT'
4450       include 'COMMON.DERIV'
4451       include 'COMMON.VAR'
4452       include 'COMMON.CHAIN'
4453       include 'COMMON.IOUNITS'
4454       include 'COMMON.NAMES'
4455       include 'COMMON.FFIELD'
4456       include 'COMMON.CONTROL'
4457       include 'COMMON.SETUP'
4458       double precision u(3),ud(3)
4459       estr=0.0d0
4460       estr1=0.0d0
4461       do i=ibondp_start,ibondp_end
4462         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4463           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4464           do j=1,3
4465           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4466      &      *dc(j,i-1)/vbld(i)
4467           enddo
4468           if (energy_dec) write(iout,*)
4469      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4470         else
4471         diff = vbld(i)-vbldp0
4472         if (energy_dec) write (iout,*)
4473      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4474         estr=estr+diff*diff
4475         do j=1,3
4476           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4477         enddo
4478 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4479         endif
4480       enddo
4481       estr=0.5d0*AKP*estr+estr1
4482 c
4483 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4484 c
4485       do i=ibond_start,ibond_end
4486         iti=iabs(itype(i))
4487         if (iti.ne.10 .and. iti.ne.ntyp1) then
4488           nbi=nbondterm(iti)
4489           if (nbi.eq.1) then
4490             diff=vbld(i+nres)-vbldsc0(1,iti)
4491             if (energy_dec) write (iout,*)
4492      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4493      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4494             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4495             do j=1,3
4496               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4497             enddo
4498           else
4499             do j=1,nbi
4500               diff=vbld(i+nres)-vbldsc0(j,iti)
4501               ud(j)=aksc(j,iti)*diff
4502               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4503             enddo
4504             uprod=u(1)
4505             do j=2,nbi
4506               uprod=uprod*u(j)
4507             enddo
4508             usum=0.0d0
4509             usumsqder=0.0d0
4510             do j=1,nbi
4511               uprod1=1.0d0
4512               uprod2=1.0d0
4513               do k=1,nbi
4514                 if (k.ne.j) then
4515                   uprod1=uprod1*u(k)
4516                   uprod2=uprod2*u(k)*u(k)
4517                 endif
4518               enddo
4519               usum=usum+uprod1
4520               usumsqder=usumsqder+ud(j)*uprod2
4521             enddo
4522             estr=estr+uprod/usum
4523             do j=1,3
4524              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4525             enddo
4526           endif
4527         endif
4528       enddo
4529       return
4530       end
4531 #ifdef CRYST_THETA
4532 C--------------------------------------------------------------------------
4533       subroutine ebend(etheta)
4534 C
4535 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4536 C angles gamma and its derivatives in consecutive thetas and gammas.
4537 C
4538       implicit real*8 (a-h,o-z)
4539       include 'DIMENSIONS'
4540       include 'COMMON.LOCAL'
4541       include 'COMMON.GEO'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.VAR'
4545       include 'COMMON.CHAIN'
4546       include 'COMMON.IOUNITS'
4547       include 'COMMON.NAMES'
4548       include 'COMMON.FFIELD'
4549       include 'COMMON.CONTROL'
4550       common /calcthet/ term1,term2,termm,diffak,ratak,
4551      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4552      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4553       double precision y(2),z(2)
4554       delta=0.02d0*pi
4555 c      time11=dexp(-2*time)
4556 c      time12=1.0d0
4557       etheta=0.0D0
4558 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4559       do i=ithet_start,ithet_end
4560         if (itype(i-1).eq.ntyp1) cycle
4561 C Zero the energy function and its derivative at 0 or pi.
4562         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4563         it=itype(i-1)
4564         ichir1=isign(1,itype(i-2))
4565         ichir2=isign(1,itype(i))
4566          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4567          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4568          if (itype(i-1).eq.10) then
4569           itype1=isign(10,itype(i-2))
4570           ichir11=isign(1,itype(i-2))
4571           ichir12=isign(1,itype(i-2))
4572           itype2=isign(10,itype(i))
4573           ichir21=isign(1,itype(i))
4574           ichir22=isign(1,itype(i))
4575          endif
4576
4577         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4578 #ifdef OSF
4579           phii=phi(i)
4580           if (phii.ne.phii) phii=150.0
4581 #else
4582           phii=phi(i)
4583 #endif
4584           y(1)=dcos(phii)
4585           y(2)=dsin(phii)
4586         else
4587           y(1)=0.0D0
4588           y(2)=0.0D0
4589         endif
4590         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4591 #ifdef OSF
4592           phii1=phi(i+1)
4593           if (phii1.ne.phii1) phii1=150.0
4594           phii1=pinorm(phii1)
4595           z(1)=cos(phii1)
4596 #else
4597           phii1=phi(i+1)
4598           z(1)=dcos(phii1)
4599 #endif
4600           z(2)=dsin(phii1)
4601         else
4602           z(1)=0.0D0
4603           z(2)=0.0D0
4604         endif
4605 C Calculate the "mean" value of theta from the part of the distribution
4606 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4607 C In following comments this theta will be referred to as t_c.
4608         thet_pred_mean=0.0d0
4609         do k=1,2
4610             athetk=athet(k,it,ichir1,ichir2)
4611             bthetk=bthet(k,it,ichir1,ichir2)
4612           if (it.eq.10) then
4613              athetk=athet(k,itype1,ichir11,ichir12)
4614              bthetk=bthet(k,itype2,ichir21,ichir22)
4615           endif
4616          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4617         enddo
4618         dthett=thet_pred_mean*ssd
4619         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4620 C Derivatives of the "mean" values in gamma1 and gamma2.
4621         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4622      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4623          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4624      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4625          if (it.eq.10) then
4626       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4627      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4628         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4629      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4630          endif
4631         if (theta(i).gt.pi-delta) then
4632           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4633      &         E_tc0)
4634           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4635           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4636           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4637      &        E_theta)
4638           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4639      &        E_tc)
4640         else if (theta(i).lt.delta) then
4641           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4642           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4643           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4644      &        E_theta)
4645           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4646           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4647      &        E_tc)
4648         else
4649           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4650      &        E_theta,E_tc)
4651         endif
4652         etheta=etheta+ethetai
4653         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4654      &      'ebend',i,ethetai
4655         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4656         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4657         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4658       enddo
4659 C Ufff.... We've done all this!!!
4660       return
4661       end
4662 C---------------------------------------------------------------------------
4663       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4664      &     E_tc)
4665       implicit real*8 (a-h,o-z)
4666       include 'DIMENSIONS'
4667       include 'COMMON.LOCAL'
4668       include 'COMMON.IOUNITS'
4669       common /calcthet/ term1,term2,termm,diffak,ratak,
4670      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4671      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4672 C Calculate the contributions to both Gaussian lobes.
4673 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4674 C The "polynomial part" of the "standard deviation" of this part of
4675 C the distribution.
4676         sig=polthet(3,it)
4677         do j=2,0,-1
4678           sig=sig*thet_pred_mean+polthet(j,it)
4679         enddo
4680 C Derivative of the "interior part" of the "standard deviation of the"
4681 C gamma-dependent Gaussian lobe in t_c.
4682         sigtc=3*polthet(3,it)
4683         do j=2,1,-1
4684           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4685         enddo
4686         sigtc=sig*sigtc
4687 C Set the parameters of both Gaussian lobes of the distribution.
4688 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4689         fac=sig*sig+sigc0(it)
4690         sigcsq=fac+fac
4691         sigc=1.0D0/sigcsq
4692 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4693         sigsqtc=-4.0D0*sigcsq*sigtc
4694 c       print *,i,sig,sigtc,sigsqtc
4695 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4696         sigtc=-sigtc/(fac*fac)
4697 C Following variable is sigma(t_c)**(-2)
4698         sigcsq=sigcsq*sigcsq
4699         sig0i=sig0(it)
4700         sig0inv=1.0D0/sig0i**2
4701         delthec=thetai-thet_pred_mean
4702         delthe0=thetai-theta0i
4703         term1=-0.5D0*sigcsq*delthec*delthec
4704         term2=-0.5D0*sig0inv*delthe0*delthe0
4705 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4706 C NaNs in taking the logarithm. We extract the largest exponent which is added
4707 C to the energy (this being the log of the distribution) at the end of energy
4708 C term evaluation for this virtual-bond angle.
4709         if (term1.gt.term2) then
4710           termm=term1
4711           term2=dexp(term2-termm)
4712           term1=1.0d0
4713         else
4714           termm=term2
4715           term1=dexp(term1-termm)
4716           term2=1.0d0
4717         endif
4718 C The ratio between the gamma-independent and gamma-dependent lobes of
4719 C the distribution is a Gaussian function of thet_pred_mean too.
4720         diffak=gthet(2,it)-thet_pred_mean
4721         ratak=diffak/gthet(3,it)**2
4722         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4723 C Let's differentiate it in thet_pred_mean NOW.
4724         aktc=ak*ratak
4725 C Now put together the distribution terms to make complete distribution.
4726         termexp=term1+ak*term2
4727         termpre=sigc+ak*sig0i
4728 C Contribution of the bending energy from this theta is just the -log of
4729 C the sum of the contributions from the two lobes and the pre-exponential
4730 C factor. Simple enough, isn't it?
4731         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4732 C NOW the derivatives!!!
4733 C 6/6/97 Take into account the deformation.
4734         E_theta=(delthec*sigcsq*term1
4735      &       +ak*delthe0*sig0inv*term2)/termexp
4736         E_tc=((sigtc+aktc*sig0i)/termpre
4737      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4738      &       aktc*term2)/termexp)
4739       return
4740       end
4741 c-----------------------------------------------------------------------------
4742       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4743       implicit real*8 (a-h,o-z)
4744       include 'DIMENSIONS'
4745       include 'COMMON.LOCAL'
4746       include 'COMMON.IOUNITS'
4747       common /calcthet/ term1,term2,termm,diffak,ratak,
4748      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4749      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4750       delthec=thetai-thet_pred_mean
4751       delthe0=thetai-theta0i
4752 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4753       t3 = thetai-thet_pred_mean
4754       t6 = t3**2
4755       t9 = term1
4756       t12 = t3*sigcsq
4757       t14 = t12+t6*sigsqtc
4758       t16 = 1.0d0
4759       t21 = thetai-theta0i
4760       t23 = t21**2
4761       t26 = term2
4762       t27 = t21*t26
4763       t32 = termexp
4764       t40 = t32**2
4765       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4766      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4767      & *(-t12*t9-ak*sig0inv*t27)
4768       return
4769       end
4770 #else
4771 C--------------------------------------------------------------------------
4772       subroutine ebend(etheta)
4773 C
4774 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4775 C angles gamma and its derivatives in consecutive thetas and gammas.
4776 C ab initio-derived potentials from
4777 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4778 C
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.LOCAL'
4782       include 'COMMON.GEO'
4783       include 'COMMON.INTERACT'
4784       include 'COMMON.DERIV'
4785       include 'COMMON.VAR'
4786       include 'COMMON.CHAIN'
4787       include 'COMMON.IOUNITS'
4788       include 'COMMON.NAMES'
4789       include 'COMMON.FFIELD'
4790       include 'COMMON.CONTROL'
4791       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4792      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4793      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4794      & sinph1ph2(maxdouble,maxdouble)
4795       logical lprn /.false./, lprn1 /.false./
4796       etheta=0.0D0
4797       do i=ithet_start,ithet_end
4798         if (itype(i-1).eq.ntyp1) cycle
4799         if (iabs(itype(i+1)).eq.20) iblock=2
4800         if (iabs(itype(i+1)).ne.20) iblock=1
4801         dethetai=0.0d0
4802         dephii=0.0d0
4803         dephii1=0.0d0
4804         theti2=0.5d0*theta(i)
4805         ityp2=ithetyp((itype(i-1)))
4806         do k=1,nntheterm
4807           coskt(k)=dcos(k*theti2)
4808           sinkt(k)=dsin(k*theti2)
4809         enddo
4810         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4811 #ifdef OSF
4812           phii=phi(i)
4813           if (phii.ne.phii) phii=150.0
4814 #else
4815           phii=phi(i)
4816 #endif
4817           ityp1=ithetyp((itype(i-2)))
4818 C propagation of chirality for glycine type
4819           do k=1,nsingle
4820             cosph1(k)=dcos(k*phii)
4821             sinph1(k)=dsin(k*phii)
4822           enddo
4823         else
4824           phii=0.0d0
4825           ityp1=nthetyp+1
4826           do k=1,nsingle
4827             cosph1(k)=0.0d0
4828             sinph1(k)=0.0d0
4829           enddo
4830         endif
4831         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4832 #ifdef OSF
4833           phii1=phi(i+1)
4834           if (phii1.ne.phii1) phii1=150.0
4835           phii1=pinorm(phii1)
4836 #else
4837           phii1=phi(i+1)
4838 #endif
4839           ityp3=ithetyp((itype(i)))
4840           do k=1,nsingle
4841             cosph2(k)=dcos(k*phii1)
4842             sinph2(k)=dsin(k*phii1)
4843           enddo
4844         else
4845           phii1=0.0d0
4846           ityp3=nthetyp+1
4847           do k=1,nsingle
4848             cosph2(k)=0.0d0
4849             sinph2(k)=0.0d0
4850           enddo
4851         endif
4852         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4853         do k=1,ndouble
4854           do l=1,k-1
4855             ccl=cosph1(l)*cosph2(k-l)
4856             ssl=sinph1(l)*sinph2(k-l)
4857             scl=sinph1(l)*cosph2(k-l)
4858             csl=cosph1(l)*sinph2(k-l)
4859             cosph1ph2(l,k)=ccl-ssl
4860             cosph1ph2(k,l)=ccl+ssl
4861             sinph1ph2(l,k)=scl+csl
4862             sinph1ph2(k,l)=scl-csl
4863           enddo
4864         enddo
4865         if (lprn) then
4866         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4867      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4868         write (iout,*) "coskt and sinkt"
4869         do k=1,nntheterm
4870           write (iout,*) k,coskt(k),sinkt(k)
4871         enddo
4872         endif
4873         do k=1,ntheterm
4874           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4875           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4876      &      *coskt(k)
4877           if (lprn)
4878      &    write (iout,*) "k",k,"
4879      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4880      &     " ethetai",ethetai
4881         enddo
4882         if (lprn) then
4883         write (iout,*) "cosph and sinph"
4884         do k=1,nsingle
4885           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4886         enddo
4887         write (iout,*) "cosph1ph2 and sinph2ph2"
4888         do k=2,ndouble
4889           do l=1,k-1
4890             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4891      &         sinph1ph2(l,k),sinph1ph2(k,l)
4892           enddo
4893         enddo
4894         write(iout,*) "ethetai",ethetai
4895         endif
4896         do m=1,ntheterm2
4897           do k=1,nsingle
4898             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4899      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4900      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4901      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4902             ethetai=ethetai+sinkt(m)*aux
4903             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4904             dephii=dephii+k*sinkt(m)*(
4905      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4906      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4907             dephii1=dephii1+k*sinkt(m)*(
4908      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4909      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4910             if (lprn)
4911      &      write (iout,*) "m",m," k",k," bbthet",
4912      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4913      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4914      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4915      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4916           enddo
4917         enddo
4918         if (lprn)
4919      &  write(iout,*) "ethetai",ethetai
4920         do m=1,ntheterm3
4921           do k=2,ndouble
4922             do l=1,k-1
4923               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4924      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4925      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4926      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4927               ethetai=ethetai+sinkt(m)*aux
4928               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4929               dephii=dephii+l*sinkt(m)*(
4930      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4931      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4932      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4933      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4934               dephii1=dephii1+(k-l)*sinkt(m)*(
4935      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4936      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4937      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4938      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4939               if (lprn) then
4940               write (iout,*) "m",m," k",k," l",l," ffthet",
4941      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4942      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4943      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4944      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4945      &            " ethetai",ethetai
4946               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4947      &            cosph1ph2(k,l)*sinkt(m),
4948      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4949               endif
4950             enddo
4951           enddo
4952         enddo
4953 10      continue
4954 c        lprn1=.true.
4955         if (lprn1)
4956      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4957      &   i,theta(i)*rad2deg,phii*rad2deg,
4958      &   phii1*rad2deg,ethetai
4959 c        lprn1=.false.
4960         etheta=etheta+ethetai
4961         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4962         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4963         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4964       enddo
4965       return
4966       end
4967 #endif
4968 #ifdef CRYST_SC
4969 c-----------------------------------------------------------------------------
4970       subroutine esc(escloc)
4971 C Calculate the local energy of a side chain and its derivatives in the
4972 C corresponding virtual-bond valence angles THETA and the spherical angles
4973 C ALPHA and OMEGA.
4974       implicit real*8 (a-h,o-z)
4975       include 'DIMENSIONS'
4976       include 'COMMON.GEO'
4977       include 'COMMON.LOCAL'
4978       include 'COMMON.VAR'
4979       include 'COMMON.INTERACT'
4980       include 'COMMON.DERIV'
4981       include 'COMMON.CHAIN'
4982       include 'COMMON.IOUNITS'
4983       include 'COMMON.NAMES'
4984       include 'COMMON.FFIELD'
4985       include 'COMMON.CONTROL'
4986       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4987      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4988       common /sccalc/ time11,time12,time112,theti,it,nlobit
4989       delta=0.02d0*pi
4990       escloc=0.0D0
4991 c     write (iout,'(a)') 'ESC'
4992       do i=loc_start,loc_end
4993         it=itype(i)
4994         if (it.eq.ntyp1) cycle
4995         if (it.eq.10) goto 1
4996         nlobit=nlob(iabs(it))
4997 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4998 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4999         theti=theta(i+1)-pipol
5000         x(1)=dtan(theti)
5001         x(2)=alph(i)
5002         x(3)=omeg(i)
5003
5004         if (x(2).gt.pi-delta) then
5005           xtemp(1)=x(1)
5006           xtemp(2)=pi-delta
5007           xtemp(3)=x(3)
5008           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5009           xtemp(2)=pi
5010           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5011           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5012      &        escloci,dersc(2))
5013           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5014      &        ddersc0(1),dersc(1))
5015           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5016      &        ddersc0(3),dersc(3))
5017           xtemp(2)=pi-delta
5018           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5019           xtemp(2)=pi
5020           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5021           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5022      &            dersc0(2),esclocbi,dersc02)
5023           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5024      &            dersc12,dersc01)
5025           call splinthet(x(2),0.5d0*delta,ss,ssd)
5026           dersc0(1)=dersc01
5027           dersc0(2)=dersc02
5028           dersc0(3)=0.0d0
5029           do k=1,3
5030             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5031           enddo
5032           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5033 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5034 c    &             esclocbi,ss,ssd
5035           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5036 c         escloci=esclocbi
5037 c         write (iout,*) escloci
5038         else if (x(2).lt.delta) then
5039           xtemp(1)=x(1)
5040           xtemp(2)=delta
5041           xtemp(3)=x(3)
5042           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5043           xtemp(2)=0.0d0
5044           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5045           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5046      &        escloci,dersc(2))
5047           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5048      &        ddersc0(1),dersc(1))
5049           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5050      &        ddersc0(3),dersc(3))
5051           xtemp(2)=delta
5052           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5053           xtemp(2)=0.0d0
5054           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5055           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5056      &            dersc0(2),esclocbi,dersc02)
5057           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5058      &            dersc12,dersc01)
5059           dersc0(1)=dersc01
5060           dersc0(2)=dersc02
5061           dersc0(3)=0.0d0
5062           call splinthet(x(2),0.5d0*delta,ss,ssd)
5063           do k=1,3
5064             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5065           enddo
5066           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5067 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5068 c    &             esclocbi,ss,ssd
5069           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5070 c         write (iout,*) escloci
5071         else
5072           call enesc(x,escloci,dersc,ddummy,.false.)
5073         endif
5074
5075         escloc=escloc+escloci
5076         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5077      &     'escloc',i,escloci
5078 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5079
5080         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5081      &   wscloc*dersc(1)
5082         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5083         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5084     1   continue
5085       enddo
5086       return
5087       end
5088 C---------------------------------------------------------------------------
5089       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5090       implicit real*8 (a-h,o-z)
5091       include 'DIMENSIONS'
5092       include 'COMMON.GEO'
5093       include 'COMMON.LOCAL'
5094       include 'COMMON.IOUNITS'
5095       common /sccalc/ time11,time12,time112,theti,it,nlobit
5096       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5097       double precision contr(maxlob,-1:1)
5098       logical mixed
5099 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5100         escloc_i=0.0D0
5101         do j=1,3
5102           dersc(j)=0.0D0
5103           if (mixed) ddersc(j)=0.0d0
5104         enddo
5105         x3=x(3)
5106
5107 C Because of periodicity of the dependence of the SC energy in omega we have
5108 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5109 C To avoid underflows, first compute & store the exponents.
5110
5111         do iii=-1,1
5112
5113           x(3)=x3+iii*dwapi
5114
5115           do j=1,nlobit
5116             do k=1,3
5117               z(k)=x(k)-censc(k,j,it)
5118             enddo
5119             do k=1,3
5120               Axk=0.0D0
5121               do l=1,3
5122                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5123               enddo
5124               Ax(k,j,iii)=Axk
5125             enddo
5126             expfac=0.0D0
5127             do k=1,3
5128               expfac=expfac+Ax(k,j,iii)*z(k)
5129             enddo
5130             contr(j,iii)=expfac
5131           enddo ! j
5132
5133         enddo ! iii
5134
5135         x(3)=x3
5136 C As in the case of ebend, we want to avoid underflows in exponentiation and
5137 C subsequent NaNs and INFs in energy calculation.
5138 C Find the largest exponent
5139         emin=contr(1,-1)
5140         do iii=-1,1
5141           do j=1,nlobit
5142             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5143           enddo
5144         enddo
5145         emin=0.5D0*emin
5146 cd      print *,'it=',it,' emin=',emin
5147
5148 C Compute the contribution to SC energy and derivatives
5149         do iii=-1,1
5150
5151           do j=1,nlobit
5152 #ifdef OSF
5153             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5154             if(adexp.ne.adexp) adexp=1.0
5155             expfac=dexp(adexp)
5156 #else
5157             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5158 #endif
5159 cd          print *,'j=',j,' expfac=',expfac
5160             escloc_i=escloc_i+expfac
5161             do k=1,3
5162               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5163             enddo
5164             if (mixed) then
5165               do k=1,3,2
5166                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5167      &            +gaussc(k,2,j,it))*expfac
5168               enddo
5169             endif
5170           enddo
5171
5172         enddo ! iii
5173
5174         dersc(1)=dersc(1)/cos(theti)**2
5175         ddersc(1)=ddersc(1)/cos(theti)**2
5176         ddersc(3)=ddersc(3)
5177
5178         escloci=-(dlog(escloc_i)-emin)
5179         do j=1,3
5180           dersc(j)=dersc(j)/escloc_i
5181         enddo
5182         if (mixed) then
5183           do j=1,3,2
5184             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5185           enddo
5186         endif
5187       return
5188       end
5189 C------------------------------------------------------------------------------
5190       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5191       implicit real*8 (a-h,o-z)
5192       include 'DIMENSIONS'
5193       include 'COMMON.GEO'
5194       include 'COMMON.LOCAL'
5195       include 'COMMON.IOUNITS'
5196       common /sccalc/ time11,time12,time112,theti,it,nlobit
5197       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5198       double precision contr(maxlob)
5199       logical mixed
5200
5201       escloc_i=0.0D0
5202
5203       do j=1,3
5204         dersc(j)=0.0D0
5205       enddo
5206
5207       do j=1,nlobit
5208         do k=1,2
5209           z(k)=x(k)-censc(k,j,it)
5210         enddo
5211         z(3)=dwapi
5212         do k=1,3
5213           Axk=0.0D0
5214           do l=1,3
5215             Axk=Axk+gaussc(l,k,j,it)*z(l)
5216           enddo
5217           Ax(k,j)=Axk
5218         enddo
5219         expfac=0.0D0
5220         do k=1,3
5221           expfac=expfac+Ax(k,j)*z(k)
5222         enddo
5223         contr(j)=expfac
5224       enddo ! j
5225
5226 C As in the case of ebend, we want to avoid underflows in exponentiation and
5227 C subsequent NaNs and INFs in energy calculation.
5228 C Find the largest exponent
5229       emin=contr(1)
5230       do j=1,nlobit
5231         if (emin.gt.contr(j)) emin=contr(j)
5232       enddo
5233       emin=0.5D0*emin
5234
5235 C Compute the contribution to SC energy and derivatives
5236
5237       dersc12=0.0d0
5238       do j=1,nlobit
5239         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5240         escloc_i=escloc_i+expfac
5241         do k=1,2
5242           dersc(k)=dersc(k)+Ax(k,j)*expfac
5243         enddo
5244         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5245      &            +gaussc(1,2,j,it))*expfac
5246         dersc(3)=0.0d0
5247       enddo
5248
5249       dersc(1)=dersc(1)/cos(theti)**2
5250       dersc12=dersc12/cos(theti)**2
5251       escloci=-(dlog(escloc_i)-emin)
5252       do j=1,2
5253         dersc(j)=dersc(j)/escloc_i
5254       enddo
5255       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5256       return
5257       end
5258 #else
5259 c----------------------------------------------------------------------------------
5260       subroutine esc(escloc)
5261 C Calculate the local energy of a side chain and its derivatives in the
5262 C corresponding virtual-bond valence angles THETA and the spherical angles
5263 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5264 C added by Urszula Kozlowska. 07/11/2007
5265 C
5266       implicit real*8 (a-h,o-z)
5267       include 'DIMENSIONS'
5268       include 'COMMON.GEO'
5269       include 'COMMON.LOCAL'
5270       include 'COMMON.VAR'
5271       include 'COMMON.SCROT'
5272       include 'COMMON.INTERACT'
5273       include 'COMMON.DERIV'
5274       include 'COMMON.CHAIN'
5275       include 'COMMON.IOUNITS'
5276       include 'COMMON.NAMES'
5277       include 'COMMON.FFIELD'
5278       include 'COMMON.CONTROL'
5279       include 'COMMON.VECTORS'
5280       double precision x_prime(3),y_prime(3),z_prime(3)
5281      &    , sumene,dsc_i,dp2_i,x(65),
5282      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5283      &    de_dxx,de_dyy,de_dzz,de_dt
5284       double precision s1_t,s1_6_t,s2_t,s2_6_t
5285       double precision
5286      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5287      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5288      & dt_dCi(3),dt_dCi1(3)
5289       common /sccalc/ time11,time12,time112,theti,it,nlobit
5290       delta=0.02d0*pi
5291       escloc=0.0D0
5292       do i=loc_start,loc_end
5293         if (itype(i).eq.ntyp1) cycle
5294         costtab(i+1) =dcos(theta(i+1))
5295         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5296         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5297         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5298         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5299         cosfac=dsqrt(cosfac2)
5300         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5301         sinfac=dsqrt(sinfac2)
5302         it=iabs(itype(i))
5303         if (it.eq.10) goto 1
5304 c
5305 C  Compute the axes of tghe local cartesian coordinates system; store in
5306 c   x_prime, y_prime and z_prime
5307 c
5308         do j=1,3
5309           x_prime(j) = 0.00
5310           y_prime(j) = 0.00
5311           z_prime(j) = 0.00
5312         enddo
5313 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5314 C     &   dc_norm(3,i+nres)
5315         do j = 1,3
5316           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5317           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5318         enddo
5319         do j = 1,3
5320           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5321         enddo
5322 c       write (2,*) "i",i
5323 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5324 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5325 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5326 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5327 c      & " xy",scalar(x_prime(1),y_prime(1)),
5328 c      & " xz",scalar(x_prime(1),z_prime(1)),
5329 c      & " yy",scalar(y_prime(1),y_prime(1)),
5330 c      & " yz",scalar(y_prime(1),z_prime(1)),
5331 c      & " zz",scalar(z_prime(1),z_prime(1))
5332 c
5333 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5334 C to local coordinate system. Store in xx, yy, zz.
5335 c
5336         xx=0.0d0
5337         yy=0.0d0
5338         zz=0.0d0
5339         do j = 1,3
5340           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5341           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5342           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5343         enddo
5344
5345         xxtab(i)=xx
5346         yytab(i)=yy
5347         zztab(i)=zz
5348 C
5349 C Compute the energy of the ith side cbain
5350 C
5351 c        write (2,*) "xx",xx," yy",yy," zz",zz
5352         it=iabs(itype(i))
5353         do j = 1,65
5354           x(j) = sc_parmin(j,it)
5355         enddo
5356 #ifdef CHECK_COORD
5357 Cc diagnostics - remove later
5358         xx1 = dcos(alph(2))
5359         yy1 = dsin(alph(2))*dcos(omeg(2))
5360         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5361         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5362      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5363      &    xx1,yy1,zz1
5364 C,"  --- ", xx_w,yy_w,zz_w
5365 c end diagnostics
5366 #endif
5367         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5368      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5369      &   + x(10)*yy*zz
5370         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5371      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5372      & + x(20)*yy*zz
5373         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5374      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5375      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5376      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5377      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5378      &  +x(40)*xx*yy*zz
5379         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5380      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5381      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5382      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5383      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5384      &  +x(60)*xx*yy*zz
5385         dsc_i   = 0.743d0+x(61)
5386         dp2_i   = 1.9d0+x(62)
5387         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5388      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5389         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5390      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5391         s1=(1+x(63))/(0.1d0 + dscp1)
5392         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5393         s2=(1+x(65))/(0.1d0 + dscp2)
5394         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5395         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5396      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5397 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5398 c     &   sumene4,
5399 c     &   dscp1,dscp2,sumene
5400 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         escloc = escloc + sumene
5402 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5403 c     & ,zz,xx,yy
5404 c#define DEBUG
5405 #ifdef DEBUG
5406 C
5407 C This section to check the numerical derivatives of the energy of ith side
5408 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5409 C #define DEBUG in the code to turn it on.
5410 C
5411         write (2,*) "sumene               =",sumene
5412         aincr=1.0d-7
5413         xxsave=xx
5414         xx=xx+aincr
5415         write (2,*) xx,yy,zz
5416         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5417         de_dxx_num=(sumenep-sumene)/aincr
5418         xx=xxsave
5419         write (2,*) "xx+ sumene from enesc=",sumenep
5420         yysave=yy
5421         yy=yy+aincr
5422         write (2,*) xx,yy,zz
5423         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5424         de_dyy_num=(sumenep-sumene)/aincr
5425         yy=yysave
5426         write (2,*) "yy+ sumene from enesc=",sumenep
5427         zzsave=zz
5428         zz=zz+aincr
5429         write (2,*) xx,yy,zz
5430         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5431         de_dzz_num=(sumenep-sumene)/aincr
5432         zz=zzsave
5433         write (2,*) "zz+ sumene from enesc=",sumenep
5434         costsave=cost2tab(i+1)
5435         sintsave=sint2tab(i+1)
5436         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5437         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5438         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5439         de_dt_num=(sumenep-sumene)/aincr
5440         write (2,*) " t+ sumene from enesc=",sumenep
5441         cost2tab(i+1)=costsave
5442         sint2tab(i+1)=sintsave
5443 C End of diagnostics section.
5444 #endif
5445 C
5446 C Compute the gradient of esc
5447 C
5448 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5449         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5450         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5451         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5452         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5453         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5454         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5455         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5456         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5457         pom1=(sumene3*sint2tab(i+1)+sumene1)
5458      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5459         pom2=(sumene4*cost2tab(i+1)+sumene2)
5460      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5461         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5462         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5463      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5464      &  +x(40)*yy*zz
5465         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5466         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5467      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5468      &  +x(60)*yy*zz
5469         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5470      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5471      &        +(pom1+pom2)*pom_dx
5472 #ifdef DEBUG
5473         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5474 #endif
5475 C
5476         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5477         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5478      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5479      &  +x(40)*xx*zz
5480         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5481         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5482      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5483      &  +x(59)*zz**2 +x(60)*xx*zz
5484         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5485      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5486      &        +(pom1-pom2)*pom_dy
5487 #ifdef DEBUG
5488         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5489 #endif
5490 C
5491         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5492      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5493      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5494      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5495      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5496      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5497      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5498      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5499 #ifdef DEBUG
5500         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5501 #endif
5502 C
5503         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5504      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5505      &  +pom1*pom_dt1+pom2*pom_dt2
5506 #ifdef DEBUG
5507         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5508 #endif
5509 c#undef DEBUG
5510 c
5511 C
5512        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5513        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5514        cosfac2xx=cosfac2*xx
5515        sinfac2yy=sinfac2*yy
5516        do k = 1,3
5517          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5518      &      vbld_inv(i+1)
5519          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5520      &      vbld_inv(i)
5521          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5522          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5523 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5524 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5525 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5526 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5527          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5528          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5529          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5530          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5531          dZZ_Ci1(k)=0.0d0
5532          dZZ_Ci(k)=0.0d0
5533          do j=1,3
5534            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5535      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5536            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5537      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5538          enddo
5539
5540          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5541          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5542          dZZ_XYZ(k)=vbld_inv(i+nres)*
5543      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5544 c
5545          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5546          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5547        enddo
5548
5549        do k=1,3
5550          dXX_Ctab(k,i)=dXX_Ci(k)
5551          dXX_C1tab(k,i)=dXX_Ci1(k)
5552          dYY_Ctab(k,i)=dYY_Ci(k)
5553          dYY_C1tab(k,i)=dYY_Ci1(k)
5554          dZZ_Ctab(k,i)=dZZ_Ci(k)
5555          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5556          dXX_XYZtab(k,i)=dXX_XYZ(k)
5557          dYY_XYZtab(k,i)=dYY_XYZ(k)
5558          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5559        enddo
5560
5561        do k = 1,3
5562 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5563 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5564 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5565 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5566 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5567 c     &    dt_dci(k)
5568 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5569 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5570          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5571      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5572          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5573      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5574          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5575      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5576        enddo
5577 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5578 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5579
5580 C to check gradient call subroutine check_grad
5581
5582     1 continue
5583       enddo
5584       return
5585       end
5586 c------------------------------------------------------------------------------
5587       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5588       implicit none
5589       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5590      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5591       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5592      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5593      &   + x(10)*yy*zz
5594       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5595      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5596      & + x(20)*yy*zz
5597       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5598      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5599      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5600      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5601      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5602      &  +x(40)*xx*yy*zz
5603       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5604      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5605      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5606      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5607      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5608      &  +x(60)*xx*yy*zz
5609       dsc_i   = 0.743d0+x(61)
5610       dp2_i   = 1.9d0+x(62)
5611       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5612      &          *(xx*cost2+yy*sint2))
5613       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5614      &          *(xx*cost2-yy*sint2))
5615       s1=(1+x(63))/(0.1d0 + dscp1)
5616       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5617       s2=(1+x(65))/(0.1d0 + dscp2)
5618       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5619       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5620      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5621       enesc=sumene
5622       return
5623       end
5624 #endif
5625 c------------------------------------------------------------------------------
5626       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5627 C
5628 C This procedure calculates two-body contact function g(rij) and its derivative:
5629 C
5630 C           eps0ij                                     !       x < -1
5631 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5632 C            0                                         !       x > 1
5633 C
5634 C where x=(rij-r0ij)/delta
5635 C
5636 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5637 C
5638       implicit none
5639       double precision rij,r0ij,eps0ij,fcont,fprimcont
5640       double precision x,x2,x4,delta
5641 c     delta=0.02D0*r0ij
5642 c      delta=0.2D0*r0ij
5643       x=(rij-r0ij)/delta
5644       if (x.lt.-1.0D0) then
5645         fcont=eps0ij
5646         fprimcont=0.0D0
5647       else if (x.le.1.0D0) then
5648         x2=x*x
5649         x4=x2*x2
5650         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5651         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5652       else
5653         fcont=0.0D0
5654         fprimcont=0.0D0
5655       endif
5656       return
5657       end
5658 c------------------------------------------------------------------------------
5659       subroutine splinthet(theti,delta,ss,ssder)
5660       implicit real*8 (a-h,o-z)
5661       include 'DIMENSIONS'
5662       include 'COMMON.VAR'
5663       include 'COMMON.GEO'
5664       thetup=pi-delta
5665       thetlow=delta
5666       if (theti.gt.pipol) then
5667         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5668       else
5669         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5670         ssder=-ssder
5671       endif
5672       return
5673       end
5674 c------------------------------------------------------------------------------
5675       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5676       implicit none
5677       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5678       double precision ksi,ksi2,ksi3,a1,a2,a3
5679       a1=fprim0*delta/(f1-f0)
5680       a2=3.0d0-2.0d0*a1
5681       a3=a1-2.0d0
5682       ksi=(x-x0)/delta
5683       ksi2=ksi*ksi
5684       ksi3=ksi2*ksi
5685       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5686       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5687       return
5688       end
5689 c------------------------------------------------------------------------------
5690       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5691       implicit none
5692       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5693       double precision ksi,ksi2,ksi3,a1,a2,a3
5694       ksi=(x-x0)/delta
5695       ksi2=ksi*ksi
5696       ksi3=ksi2*ksi
5697       a1=fprim0x*delta
5698       a2=3*(f1x-f0x)-2*fprim0x*delta
5699       a3=fprim0x*delta-2*(f1x-f0x)
5700       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5701       return
5702       end
5703 C-----------------------------------------------------------------------------
5704 #ifdef CRYST_TOR
5705 C-----------------------------------------------------------------------------
5706       subroutine etor(etors,edihcnstr)
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.TORCNSTR'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c      lprn=.true.
5725       etors=0.0D0
5726       do i=iphi_start,iphi_end
5727       etors_ii=0.0D0
5728         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5729      &      .or. itype(i).eq.ntyp1) cycle
5730         itori=itortyp(itype(i-2))
5731         itori1=itortyp(itype(i-1))
5732         phii=phi(i)
5733         gloci=0.0D0
5734 C Proline-Proline pair is a special case...
5735         if (itori.eq.3 .and. itori1.eq.3) then
5736           if (phii.gt.-dwapi3) then
5737             cosphi=dcos(3*phii)
5738             fac=1.0D0/(1.0D0-cosphi)
5739             etorsi=v1(1,3,3)*fac
5740             etorsi=etorsi+etorsi
5741             etors=etors+etorsi-v1(1,3,3)
5742             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5743             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5744           endif
5745           do j=1,3
5746             v1ij=v1(j+1,itori,itori1)
5747             v2ij=v2(j+1,itori,itori1)
5748             cosphi=dcos(j*phii)
5749             sinphi=dsin(j*phii)
5750             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5751             if (energy_dec) etors_ii=etors_ii+
5752      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5753             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5754           enddo
5755         else
5756           do j=1,nterm_old
5757             v1ij=v1(j,itori,itori1)
5758             v2ij=v2(j,itori,itori1)
5759             cosphi=dcos(j*phii)
5760             sinphi=dsin(j*phii)
5761             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5762             if (energy_dec) etors_ii=etors_ii+
5763      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5764             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5765           enddo
5766         endif
5767         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5768              'etor',i,etors_ii
5769         if (lprn)
5770      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5771      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5772      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5773         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5774 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5775       enddo
5776 ! 6/20/98 - dihedral angle constraints
5777       edihcnstr=0.0d0
5778       do i=1,ndih_constr
5779         itori=idih_constr(i)
5780         phii=phi(itori)
5781         difi=phii-phi0(i)
5782         if (difi.gt.drange(i)) then
5783           difi=difi-drange(i)
5784           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5785           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5786         else if (difi.lt.-drange(i)) then
5787           difi=difi+drange(i)
5788           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5789           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5790         endif
5791 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5792 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5793       enddo
5794 !      write (iout,*) 'edihcnstr',edihcnstr
5795       return
5796       end
5797 c------------------------------------------------------------------------------
5798       subroutine etor_d(etors_d)
5799       etors_d=0.0d0
5800       return
5801       end
5802 c----------------------------------------------------------------------------
5803 #else
5804       subroutine etor(etors,edihcnstr)
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.VAR'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.TORSION'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.CHAIN'
5814       include 'COMMON.NAMES'
5815       include 'COMMON.IOUNITS'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.TORCNSTR'
5818       include 'COMMON.CONTROL'
5819       logical lprn
5820 C Set lprn=.true. for debugging
5821       lprn=.false.
5822 c     lprn=.true.
5823       etors=0.0D0
5824       do i=iphi_start,iphi_end
5825         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5826      &       .or. itype(i).eq.ntyp1) cycle
5827         etors_ii=0.0D0
5828          if (iabs(itype(i)).eq.20) then
5829          iblock=2
5830          else
5831          iblock=1
5832          endif
5833         itori=itortyp(itype(i-2))
5834         itori1=itortyp(itype(i-1))
5835         phii=phi(i)
5836         gloci=0.0D0
5837 C Regular cosine and sine terms
5838         do j=1,nterm(itori,itori1,iblock)
5839           v1ij=v1(j,itori,itori1,iblock)
5840           v2ij=v2(j,itori,itori1,iblock)
5841           cosphi=dcos(j*phii)
5842           sinphi=dsin(j*phii)
5843           etors=etors+v1ij*cosphi+v2ij*sinphi
5844           if (energy_dec) etors_ii=etors_ii+
5845      &                v1ij*cosphi+v2ij*sinphi
5846           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5847         enddo
5848 C Lorentz terms
5849 C                         v1
5850 C  E = SUM ----------------------------------- - v1
5851 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5852 C
5853         cosphi=dcos(0.5d0*phii)
5854         sinphi=dsin(0.5d0*phii)
5855         do j=1,nlor(itori,itori1,iblock)
5856           vl1ij=vlor1(j,itori,itori1)
5857           vl2ij=vlor2(j,itori,itori1)
5858           vl3ij=vlor3(j,itori,itori1)
5859           pom=vl2ij*cosphi+vl3ij*sinphi
5860           pom1=1.0d0/(pom*pom+1.0d0)
5861           etors=etors+vl1ij*pom1
5862           if (energy_dec) etors_ii=etors_ii+
5863      &                vl1ij*pom1
5864           pom=-pom*pom1*pom1
5865           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5866         enddo
5867 C Subtract the constant term
5868         etors=etors-v0(itori,itori1,iblock)
5869           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5870      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5871         if (lprn)
5872      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5873      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5874      &  (v1(j,itori,itori1,iblock),j=1,6),
5875      &  (v2(j,itori,itori1,iblock),j=1,6)
5876         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5877 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5878       enddo
5879 ! 6/20/98 - dihedral angle constraints
5880       edihcnstr=0.0d0
5881 c      do i=1,ndih_constr
5882       do i=idihconstr_start,idihconstr_end
5883         itori=idih_constr(i)
5884         phii=phi(itori)
5885         difi=pinorm(phii-phi0(i))
5886         if (difi.gt.drange(i)) then
5887           difi=difi-drange(i)
5888           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5889           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5890         else if (difi.lt.-drange(i)) then
5891           difi=difi+drange(i)
5892           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5893           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5894         else
5895           difi=0.0
5896         endif
5897 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5898 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5899 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5900       enddo
5901 cd       write (iout,*) 'edihcnstr',edihcnstr
5902       return
5903       end
5904 c----------------------------------------------------------------------------
5905       subroutine etor_d(etors_d)
5906 C 6/23/01 Compute double torsional energy
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.VAR'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.TORSION'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.NAMES'
5917       include 'COMMON.IOUNITS'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.TORCNSTR'
5920       logical lprn
5921 C Set lprn=.true. for debugging
5922       lprn=.false.
5923 c     lprn=.true.
5924       etors_d=0.0D0
5925 c      write(iout,*) "a tu??"
5926       do i=iphid_start,iphid_end
5927         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5928      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5929         itori=itortyp(itype(i-2))
5930         itori1=itortyp(itype(i-1))
5931         itori2=itortyp(itype(i))
5932         phii=phi(i)
5933         phii1=phi(i+1)
5934         gloci1=0.0D0
5935         gloci2=0.0D0
5936         iblock=1
5937         if (iabs(itype(i+1)).eq.20) iblock=2
5938
5939 C Regular cosine and sine terms
5940         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5941           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5942           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5943           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5944           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5945           cosphi1=dcos(j*phii)
5946           sinphi1=dsin(j*phii)
5947           cosphi2=dcos(j*phii1)
5948           sinphi2=dsin(j*phii1)
5949           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5950      &     v2cij*cosphi2+v2sij*sinphi2
5951           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5952           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5953         enddo
5954         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5955           do l=1,k-1
5956             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5957             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5958             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5959             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5960             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5961             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5962             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5963             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5964             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5965      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5966             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5967      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5968             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5969      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5970           enddo
5971         enddo
5972         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5973         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5974       enddo
5975       return
5976       end
5977 #endif
5978 c------------------------------------------------------------------------------
5979       subroutine eback_sc_corr(esccor)
5980 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5981 c        conformational states; temporarily implemented as differences
5982 c        between UNRES torsional potentials (dependent on three types of
5983 c        residues) and the torsional potentials dependent on all 20 types
5984 c        of residues computed from AM1  energy surfaces of terminally-blocked
5985 c        amino-acid residues.
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'COMMON.VAR'
5989       include 'COMMON.GEO'
5990       include 'COMMON.LOCAL'
5991       include 'COMMON.TORSION'
5992       include 'COMMON.SCCOR'
5993       include 'COMMON.INTERACT'
5994       include 'COMMON.DERIV'
5995       include 'COMMON.CHAIN'
5996       include 'COMMON.NAMES'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.FFIELD'
5999       include 'COMMON.CONTROL'
6000       logical lprn
6001 C Set lprn=.true. for debugging
6002       lprn=.false.
6003 c      lprn=.true.
6004 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6005       esccor=0.0D0
6006       do i=itau_start,itau_end
6007         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6008         esccor_ii=0.0D0
6009         isccori=isccortyp(itype(i-2))
6010         isccori1=isccortyp(itype(i-1))
6011 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6012         phii=phi(i)
6013         do intertyp=1,3 !intertyp
6014 cc Added 09 May 2012 (Adasko)
6015 cc  Intertyp means interaction type of backbone mainchain correlation:
6016 c   1 = SC...Ca...Ca...Ca
6017 c   2 = Ca...Ca...Ca...SC
6018 c   3 = SC...Ca...Ca...SCi
6019         gloci=0.0D0
6020         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6021      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6022      &      (itype(i-1).eq.ntyp1)))
6023      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6024      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6025      &     .or.(itype(i).eq.ntyp1)))
6026      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6027      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6028      &      (itype(i-3).eq.ntyp1)))) cycle
6029         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6030         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6031      & cycle
6032        do j=1,nterm_sccor(isccori,isccori1)
6033           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6034           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6035           cosphi=dcos(j*tauangle(intertyp,i))
6036           sinphi=dsin(j*tauangle(intertyp,i))
6037           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6038           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6039         enddo
6040 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6041         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6042         if (lprn)
6043      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6044      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6045      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6046      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6047         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6048        enddo !intertyp
6049       enddo
6050
6051       return
6052       end
6053 c----------------------------------------------------------------------------
6054       subroutine multibody(ecorr)
6055 C This subroutine calculates multi-body contributions to energy following
6056 C the idea of Skolnick et al. If side chains I and J make a contact and
6057 C at the same time side chains I+1 and J+1 make a contact, an extra
6058 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6059       implicit real*8 (a-h,o-z)
6060       include 'DIMENSIONS'
6061       include 'COMMON.IOUNITS'
6062       include 'COMMON.DERIV'
6063       include 'COMMON.INTERACT'
6064       include 'COMMON.CONTACTS'
6065       double precision gx(3),gx1(3)
6066       logical lprn
6067
6068 C Set lprn=.true. for debugging
6069       lprn=.false.
6070
6071       if (lprn) then
6072         write (iout,'(a)') 'Contact function values:'
6073         do i=nnt,nct-2
6074           write (iout,'(i2,20(1x,i2,f10.5))')
6075      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6076         enddo
6077       endif
6078       ecorr=0.0D0
6079       do i=nnt,nct
6080         do j=1,3
6081           gradcorr(j,i)=0.0D0
6082           gradxorr(j,i)=0.0D0
6083         enddo
6084       enddo
6085       do i=nnt,nct-2
6086
6087         DO ISHIFT = 3,4
6088
6089         i1=i+ishift
6090         num_conti=num_cont(i)
6091         num_conti1=num_cont(i1)
6092         do jj=1,num_conti
6093           j=jcont(jj,i)
6094           do kk=1,num_conti1
6095             j1=jcont(kk,i1)
6096             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6097 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6098 cd   &                   ' ishift=',ishift
6099 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6100 C The system gains extra energy.
6101               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6102             endif   ! j1==j+-ishift
6103           enddo     ! kk
6104         enddo       ! jj
6105
6106         ENDDO ! ISHIFT
6107
6108       enddo         ! i
6109       return
6110       end
6111 c------------------------------------------------------------------------------
6112       double precision function esccorr(i,j,k,l,jj,kk)
6113       implicit real*8 (a-h,o-z)
6114       include 'DIMENSIONS'
6115       include 'COMMON.IOUNITS'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       double precision gx(3),gx1(3)
6120       logical lprn
6121       lprn=.false.
6122       eij=facont(jj,i)
6123       ekl=facont(kk,k)
6124 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6125 C Calculate the multi-body contribution to energy.
6126 C Calculate multi-body contributions to the gradient.
6127 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6128 cd   & k,l,(gacont(m,kk,k),m=1,3)
6129       do m=1,3
6130         gx(m) =ekl*gacont(m,jj,i)
6131         gx1(m)=eij*gacont(m,kk,k)
6132         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6133         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6134         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6135         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6136       enddo
6137       do m=i,j-1
6138         do ll=1,3
6139           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6140         enddo
6141       enddo
6142       do m=k,l-1
6143         do ll=1,3
6144           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6145         enddo
6146       enddo
6147       esccorr=-eij*ekl
6148       return
6149       end
6150 c------------------------------------------------------------------------------
6151       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6152 C This subroutine calculates multi-body contributions to hydrogen-bonding
6153       implicit real*8 (a-h,o-z)
6154       include 'DIMENSIONS'
6155       include 'COMMON.IOUNITS'
6156 #ifdef MPI
6157       include "mpif.h"
6158       parameter (max_cont=maxconts)
6159       parameter (max_dim=26)
6160       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6161       double precision zapas(max_dim,maxconts,max_fg_procs),
6162      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6163       common /przechowalnia/ zapas
6164       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6165      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6166 #endif
6167       include 'COMMON.SETUP'
6168       include 'COMMON.FFIELD'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.INTERACT'
6171       include 'COMMON.CONTACTS'
6172       include 'COMMON.CONTROL'
6173       include 'COMMON.LOCAL'
6174       double precision gx(3),gx1(3),time00
6175       logical lprn,ldone
6176
6177 C Set lprn=.true. for debugging
6178       lprn=.false.
6179 #ifdef MPI
6180       n_corr=0
6181       n_corr1=0
6182       if (nfgtasks.le.1) goto 30
6183       if (lprn) then
6184         write (iout,'(a)') 'Contact function values before RECEIVE:'
6185         do i=nnt,nct-2
6186           write (iout,'(2i3,50(1x,i2,f5.2))')
6187      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6188      &    j=1,num_cont_hb(i))
6189         enddo
6190       endif
6191       call flush(iout)
6192       do i=1,ntask_cont_from
6193         ncont_recv(i)=0
6194       enddo
6195       do i=1,ntask_cont_to
6196         ncont_sent(i)=0
6197       enddo
6198 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6199 c     & ntask_cont_to
6200 C Make the list of contacts to send to send to other procesors
6201 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6202 c      call flush(iout)
6203       do i=iturn3_start,iturn3_end
6204 c        write (iout,*) "make contact list turn3",i," num_cont",
6205 c     &    num_cont_hb(i)
6206         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6207       enddo
6208       do i=iturn4_start,iturn4_end
6209 c        write (iout,*) "make contact list turn4",i," num_cont",
6210 c     &   num_cont_hb(i)
6211         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6212       enddo
6213       do ii=1,nat_sent
6214         i=iat_sent(ii)
6215 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6216 c     &    num_cont_hb(i)
6217         do j=1,num_cont_hb(i)
6218         do k=1,4
6219           jjc=jcont_hb(j,i)
6220           iproc=iint_sent_local(k,jjc,ii)
6221 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6222           if (iproc.gt.0) then
6223             ncont_sent(iproc)=ncont_sent(iproc)+1
6224             nn=ncont_sent(iproc)
6225             zapas(1,nn,iproc)=i
6226             zapas(2,nn,iproc)=jjc
6227             zapas(3,nn,iproc)=facont_hb(j,i)
6228             zapas(4,nn,iproc)=ees0p(j,i)
6229             zapas(5,nn,iproc)=ees0m(j,i)
6230             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6231             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6232             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6233             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6234             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6235             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6236             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6237             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6238             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6239             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6240             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6241             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6242             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6243             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6244             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6245             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6246             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6247             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6248             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6249             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6250             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6251           endif
6252         enddo
6253         enddo
6254       enddo
6255       if (lprn) then
6256       write (iout,*)
6257      &  "Numbers of contacts to be sent to other processors",
6258      &  (ncont_sent(i),i=1,ntask_cont_to)
6259       write (iout,*) "Contacts sent"
6260       do ii=1,ntask_cont_to
6261         nn=ncont_sent(ii)
6262         iproc=itask_cont_to(ii)
6263         write (iout,*) nn," contacts to processor",iproc,
6264      &   " of CONT_TO_COMM group"
6265         do i=1,nn
6266           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6267         enddo
6268       enddo
6269       call flush(iout)
6270       endif
6271       CorrelType=477
6272       CorrelID=fg_rank+1
6273       CorrelType1=478
6274       CorrelID1=nfgtasks+fg_rank+1
6275       ireq=0
6276 C Receive the numbers of needed contacts from other processors
6277       do ii=1,ntask_cont_from
6278         iproc=itask_cont_from(ii)
6279         ireq=ireq+1
6280         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6281      &    FG_COMM,req(ireq),IERR)
6282       enddo
6283 c      write (iout,*) "IRECV ended"
6284 c      call flush(iout)
6285 C Send the number of contacts needed by other processors
6286       do ii=1,ntask_cont_to
6287         iproc=itask_cont_to(ii)
6288         ireq=ireq+1
6289         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6290      &    FG_COMM,req(ireq),IERR)
6291       enddo
6292 c      write (iout,*) "ISEND ended"
6293 c      write (iout,*) "number of requests (nn)",ireq
6294       call flush(iout)
6295       if (ireq.gt.0)
6296      &  call MPI_Waitall(ireq,req,status_array,ierr)
6297 c      write (iout,*)
6298 c     &  "Numbers of contacts to be received from other processors",
6299 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6300 c      call flush(iout)
6301 C Receive contacts
6302       ireq=0
6303       do ii=1,ntask_cont_from
6304         iproc=itask_cont_from(ii)
6305         nn=ncont_recv(ii)
6306 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6307 c     &   " of CONT_TO_COMM group"
6308         call flush(iout)
6309         if (nn.gt.0) then
6310           ireq=ireq+1
6311           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6312      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6313 c          write (iout,*) "ireq,req",ireq,req(ireq)
6314         endif
6315       enddo
6316 C Send the contacts to processors that need them
6317       do ii=1,ntask_cont_to
6318         iproc=itask_cont_to(ii)
6319         nn=ncont_sent(ii)
6320 c        write (iout,*) nn," contacts to processor",iproc,
6321 c     &   " of CONT_TO_COMM group"
6322         if (nn.gt.0) then
6323           ireq=ireq+1
6324           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6325      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6326 c          write (iout,*) "ireq,req",ireq,req(ireq)
6327 c          do i=1,nn
6328 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6329 c          enddo
6330         endif
6331       enddo
6332 c      write (iout,*) "number of requests (contacts)",ireq
6333 c      write (iout,*) "req",(req(i),i=1,4)
6334 c      call flush(iout)
6335       if (ireq.gt.0)
6336      & call MPI_Waitall(ireq,req,status_array,ierr)
6337       do iii=1,ntask_cont_from
6338         iproc=itask_cont_from(iii)
6339         nn=ncont_recv(iii)
6340         if (lprn) then
6341         write (iout,*) "Received",nn," contacts from processor",iproc,
6342      &   " of CONT_FROM_COMM group"
6343         call flush(iout)
6344         do i=1,nn
6345           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6346         enddo
6347         call flush(iout)
6348         endif
6349         do i=1,nn
6350           ii=zapas_recv(1,i,iii)
6351 c Flag the received contacts to prevent double-counting
6352           jj=-zapas_recv(2,i,iii)
6353 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6354 c          call flush(iout)
6355           nnn=num_cont_hb(ii)+1
6356           num_cont_hb(ii)=nnn
6357           jcont_hb(nnn,ii)=jj
6358           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6359           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6360           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6361           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6362           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6363           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6364           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6365           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6366           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6367           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6368           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6369           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6370           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6371           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6372           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6373           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6374           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6375           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6376           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6377           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6378           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6379           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6380           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6381           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6382         enddo
6383       enddo
6384       call flush(iout)
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values after receive:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i3,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392         call flush(iout)
6393       endif
6394    30 continue
6395 #endif
6396       if (lprn) then
6397         write (iout,'(a)') 'Contact function values:'
6398         do i=nnt,nct-2
6399           write (iout,'(2i3,50(1x,i3,f5.2))')
6400      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6401      &    j=1,num_cont_hb(i))
6402         enddo
6403       endif
6404       ecorr=0.0D0
6405 C Remove the loop below after debugging !!!
6406       do i=nnt,nct
6407         do j=1,3
6408           gradcorr(j,i)=0.0D0
6409           gradxorr(j,i)=0.0D0
6410         enddo
6411       enddo
6412 C Calculate the local-electrostatic correlation terms
6413       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6414         i1=i+1
6415         num_conti=num_cont_hb(i)
6416         num_conti1=num_cont_hb(i+1)
6417         do jj=1,num_conti
6418           j=jcont_hb(jj,i)
6419           jp=iabs(j)
6420           do kk=1,num_conti1
6421             j1=jcont_hb(kk,i1)
6422             jp1=iabs(j1)
6423 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6424 c     &         ' jj=',jj,' kk=',kk
6425             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6426      &          .or. j.lt.0 .and. j1.gt.0) .and.
6427      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6428 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6429 C The system gains extra energy.
6430               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6431               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6432      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6433               n_corr=n_corr+1
6434             else if (j1.eq.j) then
6435 C Contacts I-J and I-(J+1) occur simultaneously.
6436 C The system loses extra energy.
6437 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6438             endif
6439           enddo ! kk
6440           do kk=1,num_conti
6441             j1=jcont_hb(kk,i)
6442 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6443 c    &         ' jj=',jj,' kk=',kk
6444             if (j1.eq.j+1) then
6445 C Contacts I-J and (I+1)-J occur simultaneously.
6446 C The system loses extra energy.
6447 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6448             endif ! j1==j+1
6449           enddo ! kk
6450         enddo ! jj
6451       enddo ! i
6452       return
6453       end
6454 c------------------------------------------------------------------------------
6455       subroutine add_hb_contact(ii,jj,itask)
6456       implicit real*8 (a-h,o-z)
6457       include "DIMENSIONS"
6458       include "COMMON.IOUNITS"
6459       integer max_cont
6460       integer max_dim
6461       parameter (max_cont=maxconts)
6462       parameter (max_dim=26)
6463       include "COMMON.CONTACTS"
6464       double precision zapas(max_dim,maxconts,max_fg_procs),
6465      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6466       common /przechowalnia/ zapas
6467       integer i,j,ii,jj,iproc,itask(4),nn
6468 c      write (iout,*) "itask",itask
6469       do i=1,2
6470         iproc=itask(i)
6471         if (iproc.gt.0) then
6472           do j=1,num_cont_hb(ii)
6473             jjc=jcont_hb(j,ii)
6474 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6475             if (jjc.eq.jj) then
6476               ncont_sent(iproc)=ncont_sent(iproc)+1
6477               nn=ncont_sent(iproc)
6478               zapas(1,nn,iproc)=ii
6479               zapas(2,nn,iproc)=jjc
6480               zapas(3,nn,iproc)=facont_hb(j,ii)
6481               zapas(4,nn,iproc)=ees0p(j,ii)
6482               zapas(5,nn,iproc)=ees0m(j,ii)
6483               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6484               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6485               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6486               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6487               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6488               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6489               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6490               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6491               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6492               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6493               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6494               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6495               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6496               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6497               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6498               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6499               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6500               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6501               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6502               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6503               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6504               exit
6505             endif
6506           enddo
6507         endif
6508       enddo
6509       return
6510       end
6511 c------------------------------------------------------------------------------
6512       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6513      &  n_corr1)
6514 C This subroutine calculates multi-body contributions to hydrogen-bonding
6515       implicit real*8 (a-h,o-z)
6516       include 'DIMENSIONS'
6517       include 'COMMON.IOUNITS'
6518 #ifdef MPI
6519       include "mpif.h"
6520       parameter (max_cont=maxconts)
6521       parameter (max_dim=70)
6522       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6523       double precision zapas(max_dim,maxconts,max_fg_procs),
6524      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6525       common /przechowalnia/ zapas
6526       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6527      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6528 #endif
6529       include 'COMMON.SETUP'
6530       include 'COMMON.FFIELD'
6531       include 'COMMON.DERIV'
6532       include 'COMMON.LOCAL'
6533       include 'COMMON.INTERACT'
6534       include 'COMMON.CONTACTS'
6535       include 'COMMON.CHAIN'
6536       include 'COMMON.CONTROL'
6537       double precision gx(3),gx1(3)
6538       integer num_cont_hb_old(maxres)
6539       logical lprn,ldone
6540       double precision eello4,eello5,eelo6,eello_turn6
6541       external eello4,eello5,eello6,eello_turn6
6542 C Set lprn=.true. for debugging
6543       lprn=.false.
6544       eturn6=0.0d0
6545 #ifdef MPI
6546       do i=1,nres
6547         num_cont_hb_old(i)=num_cont_hb(i)
6548       enddo
6549       n_corr=0
6550       n_corr1=0
6551       if (nfgtasks.le.1) goto 30
6552       if (lprn) then
6553         write (iout,'(a)') 'Contact function values before RECEIVE:'
6554         do i=nnt,nct-2
6555           write (iout,'(2i3,50(1x,i2,f5.2))')
6556      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6557      &    j=1,num_cont_hb(i))
6558         enddo
6559       endif
6560       call flush(iout)
6561       do i=1,ntask_cont_from
6562         ncont_recv(i)=0
6563       enddo
6564       do i=1,ntask_cont_to
6565         ncont_sent(i)=0
6566       enddo
6567 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6568 c     & ntask_cont_to
6569 C Make the list of contacts to send to send to other procesors
6570       do i=iturn3_start,iturn3_end
6571 c        write (iout,*) "make contact list turn3",i," num_cont",
6572 c     &    num_cont_hb(i)
6573         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6574       enddo
6575       do i=iturn4_start,iturn4_end
6576 c        write (iout,*) "make contact list turn4",i," num_cont",
6577 c     &   num_cont_hb(i)
6578         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6579       enddo
6580       do ii=1,nat_sent
6581         i=iat_sent(ii)
6582 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6583 c     &    num_cont_hb(i)
6584         do j=1,num_cont_hb(i)
6585         do k=1,4
6586           jjc=jcont_hb(j,i)
6587           iproc=iint_sent_local(k,jjc,ii)
6588 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6589           if (iproc.ne.0) then
6590             ncont_sent(iproc)=ncont_sent(iproc)+1
6591             nn=ncont_sent(iproc)
6592             zapas(1,nn,iproc)=i
6593             zapas(2,nn,iproc)=jjc
6594             zapas(3,nn,iproc)=d_cont(j,i)
6595             ind=3
6596             do kk=1,3
6597               ind=ind+1
6598               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6599             enddo
6600             do kk=1,2
6601               do ll=1,2
6602                 ind=ind+1
6603                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6604               enddo
6605             enddo
6606             do jj=1,5
6607               do kk=1,3
6608                 do ll=1,2
6609                   do mm=1,2
6610                     ind=ind+1
6611                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6612                   enddo
6613                 enddo
6614               enddo
6615             enddo
6616           endif
6617         enddo
6618         enddo
6619       enddo
6620       if (lprn) then
6621       write (iout,*)
6622      &  "Numbers of contacts to be sent to other processors",
6623      &  (ncont_sent(i),i=1,ntask_cont_to)
6624       write (iout,*) "Contacts sent"
6625       do ii=1,ntask_cont_to
6626         nn=ncont_sent(ii)
6627         iproc=itask_cont_to(ii)
6628         write (iout,*) nn," contacts to processor",iproc,
6629      &   " of CONT_TO_COMM group"
6630         do i=1,nn
6631           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6632         enddo
6633       enddo
6634       call flush(iout)
6635       endif
6636       CorrelType=477
6637       CorrelID=fg_rank+1
6638       CorrelType1=478
6639       CorrelID1=nfgtasks+fg_rank+1
6640       ireq=0
6641 C Receive the numbers of needed contacts from other processors
6642       do ii=1,ntask_cont_from
6643         iproc=itask_cont_from(ii)
6644         ireq=ireq+1
6645         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6646      &    FG_COMM,req(ireq),IERR)
6647       enddo
6648 c      write (iout,*) "IRECV ended"
6649 c      call flush(iout)
6650 C Send the number of contacts needed by other processors
6651       do ii=1,ntask_cont_to
6652         iproc=itask_cont_to(ii)
6653         ireq=ireq+1
6654         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6655      &    FG_COMM,req(ireq),IERR)
6656       enddo
6657 c      write (iout,*) "ISEND ended"
6658 c      write (iout,*) "number of requests (nn)",ireq
6659       call flush(iout)
6660       if (ireq.gt.0)
6661      &  call MPI_Waitall(ireq,req,status_array,ierr)
6662 c      write (iout,*)
6663 c     &  "Numbers of contacts to be received from other processors",
6664 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6665 c      call flush(iout)
6666 C Receive contacts
6667       ireq=0
6668       do ii=1,ntask_cont_from
6669         iproc=itask_cont_from(ii)
6670         nn=ncont_recv(ii)
6671 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6672 c     &   " of CONT_TO_COMM group"
6673         call flush(iout)
6674         if (nn.gt.0) then
6675           ireq=ireq+1
6676           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6677      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6678 c          write (iout,*) "ireq,req",ireq,req(ireq)
6679         endif
6680       enddo
6681 C Send the contacts to processors that need them
6682       do ii=1,ntask_cont_to
6683         iproc=itask_cont_to(ii)
6684         nn=ncont_sent(ii)
6685 c        write (iout,*) nn," contacts to processor",iproc,
6686 c     &   " of CONT_TO_COMM group"
6687         if (nn.gt.0) then
6688           ireq=ireq+1
6689           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6690      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6691 c          write (iout,*) "ireq,req",ireq,req(ireq)
6692 c          do i=1,nn
6693 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6694 c          enddo
6695         endif
6696       enddo
6697 c      write (iout,*) "number of requests (contacts)",ireq
6698 c      write (iout,*) "req",(req(i),i=1,4)
6699 c      call flush(iout)
6700       if (ireq.gt.0)
6701      & call MPI_Waitall(ireq,req,status_array,ierr)
6702       do iii=1,ntask_cont_from
6703         iproc=itask_cont_from(iii)
6704         nn=ncont_recv(iii)
6705         if (lprn) then
6706         write (iout,*) "Received",nn," contacts from processor",iproc,
6707      &   " of CONT_FROM_COMM group"
6708         call flush(iout)
6709         do i=1,nn
6710           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6711         enddo
6712         call flush(iout)
6713         endif
6714         do i=1,nn
6715           ii=zapas_recv(1,i,iii)
6716 c Flag the received contacts to prevent double-counting
6717           jj=-zapas_recv(2,i,iii)
6718 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6719 c          call flush(iout)
6720           nnn=num_cont_hb(ii)+1
6721           num_cont_hb(ii)=nnn
6722           jcont_hb(nnn,ii)=jj
6723           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6724           ind=3
6725           do kk=1,3
6726             ind=ind+1
6727             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6728           enddo
6729           do kk=1,2
6730             do ll=1,2
6731               ind=ind+1
6732               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6733             enddo
6734           enddo
6735           do jj=1,5
6736             do kk=1,3
6737               do ll=1,2
6738                 do mm=1,2
6739                   ind=ind+1
6740                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6741                 enddo
6742               enddo
6743             enddo
6744           enddo
6745         enddo
6746       enddo
6747       call flush(iout)
6748       if (lprn) then
6749         write (iout,'(a)') 'Contact function values after receive:'
6750         do i=nnt,nct-2
6751           write (iout,'(2i3,50(1x,i3,5f6.3))')
6752      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6753      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6754         enddo
6755         call flush(iout)
6756       endif
6757    30 continue
6758 #endif
6759       if (lprn) then
6760         write (iout,'(a)') 'Contact function values:'
6761         do i=nnt,nct-2
6762           write (iout,'(2i3,50(1x,i2,5f6.3))')
6763      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6764      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6765         enddo
6766       endif
6767       ecorr=0.0D0
6768       ecorr5=0.0d0
6769       ecorr6=0.0d0
6770 C Remove the loop below after debugging !!!
6771       do i=nnt,nct
6772         do j=1,3
6773           gradcorr(j,i)=0.0D0
6774           gradxorr(j,i)=0.0D0
6775         enddo
6776       enddo
6777 C Calculate the dipole-dipole interaction energies
6778       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6779       do i=iatel_s,iatel_e+1
6780         num_conti=num_cont_hb(i)
6781         do jj=1,num_conti
6782           j=jcont_hb(jj,i)
6783 #ifdef MOMENT
6784           call dipole(i,j,jj)
6785 #endif
6786         enddo
6787       enddo
6788       endif
6789 C Calculate the local-electrostatic correlation terms
6790 c                write (iout,*) "gradcorr5 in eello5 before loop"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6796 c        write (iout,*) "corr loop i",i
6797         i1=i+1
6798         num_conti=num_cont_hb(i)
6799         num_conti1=num_cont_hb(i+1)
6800         do jj=1,num_conti
6801           j=jcont_hb(jj,i)
6802           jp=iabs(j)
6803           do kk=1,num_conti1
6804             j1=jcont_hb(kk,i1)
6805             jp1=iabs(j1)
6806 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6807 c     &         ' jj=',jj,' kk=',kk
6808 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6809             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6810      &          .or. j.lt.0 .and. j1.gt.0) .and.
6811      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6812 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6813 C The system gains extra energy.
6814               n_corr=n_corr+1
6815               sqd1=dsqrt(d_cont(jj,i))
6816               sqd2=dsqrt(d_cont(kk,i1))
6817               sred_geom = sqd1*sqd2
6818               IF (sred_geom.lt.cutoff_corr) THEN
6819                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6820      &            ekont,fprimcont)
6821 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6822 cd     &         ' jj=',jj,' kk=',kk
6823                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6824                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6825                 do l=1,3
6826                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6827                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6828                 enddo
6829                 n_corr1=n_corr1+1
6830 cd               write (iout,*) 'sred_geom=',sred_geom,
6831 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6832 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6833 cd               write (iout,*) "g_contij",g_contij
6834 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6835 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6836                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6837                 if (wcorr4.gt.0.0d0)
6838      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6839                   if (energy_dec.and.wcorr4.gt.0.0d0)
6840      1                 write (iout,'(a6,4i5,0pf7.3)')
6841      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6842 c                write (iout,*) "gradcorr5 before eello5"
6843 c                do iii=1,nres
6844 c                  write (iout,'(i5,3f10.5)')
6845 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6846 c                enddo
6847                 if (wcorr5.gt.0.0d0)
6848      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6849 c                write (iout,*) "gradcorr5 after eello5"
6850 c                do iii=1,nres
6851 c                  write (iout,'(i5,3f10.5)')
6852 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6853 c                enddo
6854                   if (energy_dec.and.wcorr5.gt.0.0d0)
6855      1                 write (iout,'(a6,4i5,0pf7.3)')
6856      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6857 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6858 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6859                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6860      &               .or. wturn6.eq.0.0d0))then
6861 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6862                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6863                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6864      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6865 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6866 cd     &            'ecorr6=',ecorr6
6867 cd                write (iout,'(4e15.5)') sred_geom,
6868 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6869 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6870 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6871                 else if (wturn6.gt.0.0d0
6872      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6873 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6874                   eturn6=eturn6+eello_turn6(i,jj,kk)
6875                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6876      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6877 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6878                 endif
6879               ENDIF
6880 1111          continue
6881             endif
6882           enddo ! kk
6883         enddo ! jj
6884       enddo ! i
6885       do i=1,nres
6886         num_cont_hb(i)=num_cont_hb_old(i)
6887       enddo
6888 c                write (iout,*) "gradcorr5 in eello5"
6889 c                do iii=1,nres
6890 c                  write (iout,'(i5,3f10.5)')
6891 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6892 c                enddo
6893       return
6894       end
6895 c------------------------------------------------------------------------------
6896       subroutine add_hb_contact_eello(ii,jj,itask)
6897       implicit real*8 (a-h,o-z)
6898       include "DIMENSIONS"
6899       include "COMMON.IOUNITS"
6900       integer max_cont
6901       integer max_dim
6902       parameter (max_cont=maxconts)
6903       parameter (max_dim=70)
6904       include "COMMON.CONTACTS"
6905       double precision zapas(max_dim,maxconts,max_fg_procs),
6906      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6907       common /przechowalnia/ zapas
6908       integer i,j,ii,jj,iproc,itask(4),nn
6909 c      write (iout,*) "itask",itask
6910       do i=1,2
6911         iproc=itask(i)
6912         if (iproc.gt.0) then
6913           do j=1,num_cont_hb(ii)
6914             jjc=jcont_hb(j,ii)
6915 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6916             if (jjc.eq.jj) then
6917               ncont_sent(iproc)=ncont_sent(iproc)+1
6918               nn=ncont_sent(iproc)
6919               zapas(1,nn,iproc)=ii
6920               zapas(2,nn,iproc)=jjc
6921               zapas(3,nn,iproc)=d_cont(j,ii)
6922               ind=3
6923               do kk=1,3
6924                 ind=ind+1
6925                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6926               enddo
6927               do kk=1,2
6928                 do ll=1,2
6929                   ind=ind+1
6930                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6931                 enddo
6932               enddo
6933               do jj=1,5
6934                 do kk=1,3
6935                   do ll=1,2
6936                     do mm=1,2
6937                       ind=ind+1
6938                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6939                     enddo
6940                   enddo
6941                 enddo
6942               enddo
6943               exit
6944             endif
6945           enddo
6946         endif
6947       enddo
6948       return
6949       end
6950 c------------------------------------------------------------------------------
6951       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6952       implicit real*8 (a-h,o-z)
6953       include 'DIMENSIONS'
6954       include 'COMMON.IOUNITS'
6955       include 'COMMON.DERIV'
6956       include 'COMMON.INTERACT'
6957       include 'COMMON.CONTACTS'
6958       double precision gx(3),gx1(3)
6959       logical lprn
6960       lprn=.false.
6961       eij=facont_hb(jj,i)
6962       ekl=facont_hb(kk,k)
6963       ees0pij=ees0p(jj,i)
6964       ees0pkl=ees0p(kk,k)
6965       ees0mij=ees0m(jj,i)
6966       ees0mkl=ees0m(kk,k)
6967       ekont=eij*ekl
6968       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6969 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6970 C Following 4 lines for diagnostics.
6971 cd    ees0pkl=0.0D0
6972 cd    ees0pij=1.0D0
6973 cd    ees0mkl=0.0D0
6974 cd    ees0mij=1.0D0
6975 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6976 c     & 'Contacts ',i,j,
6977 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6978 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6979 c     & 'gradcorr_long'
6980 C Calculate the multi-body contribution to energy.
6981 c      ecorr=ecorr+ekont*ees
6982 C Calculate multi-body contributions to the gradient.
6983       coeffpees0pij=coeffp*ees0pij
6984       coeffmees0mij=coeffm*ees0mij
6985       coeffpees0pkl=coeffp*ees0pkl
6986       coeffmees0mkl=coeffm*ees0mkl
6987       do ll=1,3
6988 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6989         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6990      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6991      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6992         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6993      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6994      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6995 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6996         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6997      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6998      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6999         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7000      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7001      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7002         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7003      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7004      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7005         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7006         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7007         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7008      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7009      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7010         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7011         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7012 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7013       enddo
7014 c      write (iout,*)
7015 cgrad      do m=i+1,j-1
7016 cgrad        do ll=1,3
7017 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7018 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7019 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7020 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7021 cgrad        enddo
7022 cgrad      enddo
7023 cgrad      do m=k+1,l-1
7024 cgrad        do ll=1,3
7025 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7026 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7027 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7028 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7029 cgrad        enddo
7030 cgrad      enddo
7031 c      write (iout,*) "ehbcorr",ekont*ees
7032       ehbcorr=ekont*ees
7033       return
7034       end
7035 #ifdef MOMENT
7036 C---------------------------------------------------------------------------
7037       subroutine dipole(i,j,jj)
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.CHAIN'
7042       include 'COMMON.FFIELD'
7043       include 'COMMON.DERIV'
7044       include 'COMMON.INTERACT'
7045       include 'COMMON.CONTACTS'
7046       include 'COMMON.TORSION'
7047       include 'COMMON.VAR'
7048       include 'COMMON.GEO'
7049       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7050      &  auxmat(2,2)
7051       iti1 = itortyp(itype(i+1))
7052       if (j.lt.nres-1) then
7053         itj1 = itortyp(itype(j+1))
7054       else
7055         itj1=ntortyp+1
7056       endif
7057       do iii=1,2
7058         dipi(iii,1)=Ub2(iii,i)
7059         dipderi(iii)=Ub2der(iii,i)
7060         dipi(iii,2)=b1(iii,i+1)
7061         dipj(iii,1)=Ub2(iii,j)
7062         dipderj(iii)=Ub2der(iii,j)
7063         dipj(iii,2)=b1(iii,j+1)
7064       enddo
7065       kkk=0
7066       do iii=1,2
7067         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7068         do jjj=1,2
7069           kkk=kkk+1
7070           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7071         enddo
7072       enddo
7073       do kkk=1,5
7074         do lll=1,3
7075           mmm=0
7076           do iii=1,2
7077             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7078      &        auxvec(1))
7079             do jjj=1,2
7080               mmm=mmm+1
7081               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7082             enddo
7083           enddo
7084         enddo
7085       enddo
7086       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7087       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7088       do iii=1,2
7089         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7090       enddo
7091       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7092       do iii=1,2
7093         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7094       enddo
7095       return
7096       end
7097 #endif
7098 C---------------------------------------------------------------------------
7099       subroutine calc_eello(i,j,k,l,jj,kk)
7100 C
7101 C This subroutine computes matrices and vectors needed to calculate
7102 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7103 C
7104       implicit real*8 (a-h,o-z)
7105       include 'DIMENSIONS'
7106       include 'COMMON.IOUNITS'
7107       include 'COMMON.CHAIN'
7108       include 'COMMON.DERIV'
7109       include 'COMMON.INTERACT'
7110       include 'COMMON.CONTACTS'
7111       include 'COMMON.TORSION'
7112       include 'COMMON.VAR'
7113       include 'COMMON.GEO'
7114       include 'COMMON.FFIELD'
7115       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7116      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7117       logical lprn
7118       common /kutas/ lprn
7119 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7120 cd     & ' jj=',jj,' kk=',kk
7121 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7122 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7123 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7124       do iii=1,2
7125         do jjj=1,2
7126           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7127           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7128         enddo
7129       enddo
7130       call transpose2(aa1(1,1),aa1t(1,1))
7131       call transpose2(aa2(1,1),aa2t(1,1))
7132       do kkk=1,5
7133         do lll=1,3
7134           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7135      &      aa1tder(1,1,lll,kkk))
7136           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7137      &      aa2tder(1,1,lll,kkk))
7138         enddo
7139       enddo
7140       if (l.eq.j+1) then
7141 C parallel orientation of the two CA-CA-CA frames.
7142         if (i.gt.1) then
7143           iti=itortyp(itype(i))
7144         else
7145           iti=ntortyp+1
7146         endif
7147         itk1=itortyp(itype(k+1))
7148         itj=itortyp(itype(j))
7149         if (l.lt.nres-1) then
7150           itl1=itortyp(itype(l+1))
7151         else
7152           itl1=ntortyp+1
7153         endif
7154 C A1 kernel(j+1) A2T
7155 cd        do iii=1,2
7156 cd          write (iout,'(3f10.5,5x,3f10.5)')
7157 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7158 cd        enddo
7159         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7160      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7161      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7162 C Following matrices are needed only for 6-th order cumulants
7163         IF (wcorr6.gt.0.0d0) THEN
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7165      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7166      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7167         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7168      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7169      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7170      &   ADtEAderx(1,1,1,1,1,1))
7171         lprn=.false.
7172         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7173      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7174      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7175      &   ADtEA1derx(1,1,1,1,1,1))
7176         ENDIF
7177 C End 6-th order cumulants
7178 cd        lprn=.false.
7179 cd        if (lprn) then
7180 cd        write (2,*) 'In calc_eello6'
7181 cd        do iii=1,2
7182 cd          write (2,*) 'iii=',iii
7183 cd          do kkk=1,5
7184 cd            write (2,*) 'kkk=',kkk
7185 cd            do jjj=1,2
7186 cd              write (2,'(3(2f10.5),5x)')
7187 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7188 cd            enddo
7189 cd          enddo
7190 cd        enddo
7191 cd        endif
7192         call transpose2(EUgder(1,1,k),auxmat(1,1))
7193         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7194         call transpose2(EUg(1,1,k),auxmat(1,1))
7195         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7196         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7197         do iii=1,2
7198           do kkk=1,5
7199             do lll=1,3
7200               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7201      &          EAEAderx(1,1,lll,kkk,iii,1))
7202             enddo
7203           enddo
7204         enddo
7205 C A1T kernel(i+1) A2
7206         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7207      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7208      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7209 C Following matrices are needed only for 6-th order cumulants
7210         IF (wcorr6.gt.0.0d0) THEN
7211         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7212      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7213      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7214         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7215      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7216      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7217      &   ADtEAderx(1,1,1,1,1,2))
7218         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7219      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7220      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7221      &   ADtEA1derx(1,1,1,1,1,2))
7222         ENDIF
7223 C End 6-th order cumulants
7224         call transpose2(EUgder(1,1,l),auxmat(1,1))
7225         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7226         call transpose2(EUg(1,1,l),auxmat(1,1))
7227         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7228         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7229         do iii=1,2
7230           do kkk=1,5
7231             do lll=1,3
7232               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7233      &          EAEAderx(1,1,lll,kkk,iii,2))
7234             enddo
7235           enddo
7236         enddo
7237 C AEAb1 and AEAb2
7238 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7239 C They are needed only when the fifth- or the sixth-order cumulants are
7240 C indluded.
7241         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7242         call transpose2(AEA(1,1,1),auxmat(1,1))
7243         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7244         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7245         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7246         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7247         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7248         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7249         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7250         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7251         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7252         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7253         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7254         call transpose2(AEA(1,1,2),auxmat(1,1))
7255         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7256         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7257         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7258         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7259         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7260         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7261         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7262         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7263         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7264         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7265         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7266 C Calculate the Cartesian derivatives of the vectors.
7267         do iii=1,2
7268           do kkk=1,5
7269             do lll=1,3
7270               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7271               call matvec2(auxmat(1,1),b1(1,i),
7272      &          AEAb1derx(1,lll,kkk,iii,1,1))
7273               call matvec2(auxmat(1,1),Ub2(1,i),
7274      &          AEAb2derx(1,lll,kkk,iii,1,1))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7276      &          AEAb1derx(1,lll,kkk,iii,2,1))
7277               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7278      &          AEAb2derx(1,lll,kkk,iii,2,1))
7279               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7280               call matvec2(auxmat(1,1),b1(1,j),
7281      &          AEAb1derx(1,lll,kkk,iii,1,2))
7282               call matvec2(auxmat(1,1),Ub2(1,j),
7283      &          AEAb2derx(1,lll,kkk,iii,1,2))
7284               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7285      &          AEAb1derx(1,lll,kkk,iii,2,2))
7286               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7287      &          AEAb2derx(1,lll,kkk,iii,2,2))
7288             enddo
7289           enddo
7290         enddo
7291         ENDIF
7292 C End vectors
7293       else
7294 C Antiparallel orientation of the two CA-CA-CA frames.
7295         if (i.gt.1) then
7296           iti=itortyp(itype(i))
7297         else
7298           iti=ntortyp+1
7299         endif
7300         itk1=itortyp(itype(k+1))
7301         itl=itortyp(itype(l))
7302         itj=itortyp(itype(j))
7303         if (j.lt.nres-1) then
7304           itj1=itortyp(itype(j+1))
7305         else
7306           itj1=ntortyp+1
7307         endif
7308 C A2 kernel(j-1)T A1T
7309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7310      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7311      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7312 C Following matrices are needed only for 6-th order cumulants
7313         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7314      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7315         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7316      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7317      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7318         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7319      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7320      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7321      &   ADtEAderx(1,1,1,1,1,1))
7322         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7323      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7324      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7325      &   ADtEA1derx(1,1,1,1,1,1))
7326         ENDIF
7327 C End 6-th order cumulants
7328         call transpose2(EUgder(1,1,k),auxmat(1,1))
7329         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7330         call transpose2(EUg(1,1,k),auxmat(1,1))
7331         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7332         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7333         do iii=1,2
7334           do kkk=1,5
7335             do lll=1,3
7336               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7337      &          EAEAderx(1,1,lll,kkk,iii,1))
7338             enddo
7339           enddo
7340         enddo
7341 C A2T kernel(i+1)T A1
7342         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7343      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7344      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7345 C Following matrices are needed only for 6-th order cumulants
7346         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7347      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7348         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7349      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7350      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7351         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7352      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7353      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7354      &   ADtEAderx(1,1,1,1,1,2))
7355         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7356      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7357      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7358      &   ADtEA1derx(1,1,1,1,1,2))
7359         ENDIF
7360 C End 6-th order cumulants
7361         call transpose2(EUgder(1,1,j),auxmat(1,1))
7362         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7363         call transpose2(EUg(1,1,j),auxmat(1,1))
7364         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7365         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7366         do iii=1,2
7367           do kkk=1,5
7368             do lll=1,3
7369               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7370      &          EAEAderx(1,1,lll,kkk,iii,2))
7371             enddo
7372           enddo
7373         enddo
7374 C AEAb1 and AEAb2
7375 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7376 C They are needed only when the fifth- or the sixth-order cumulants are
7377 C indluded.
7378         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7379      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7380         call transpose2(AEA(1,1,1),auxmat(1,1))
7381         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7382         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7383         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7384         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7385         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7386         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7387         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7388         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7389         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7390         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7391         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7392         call transpose2(AEA(1,1,2),auxmat(1,1))
7393         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7394         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7395         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7396         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7397         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7398         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7399         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7400         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7401         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7402         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7403         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7404 C Calculate the Cartesian derivatives of the vectors.
7405         do iii=1,2
7406           do kkk=1,5
7407             do lll=1,3
7408               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7409               call matvec2(auxmat(1,1),b1(1,i),
7410      &          AEAb1derx(1,lll,kkk,iii,1,1))
7411               call matvec2(auxmat(1,1),Ub2(1,i),
7412      &          AEAb2derx(1,lll,kkk,iii,1,1))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7414      &          AEAb1derx(1,lll,kkk,iii,2,1))
7415               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7416      &          AEAb2derx(1,lll,kkk,iii,2,1))
7417               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7418               call matvec2(auxmat(1,1),b1(1,l),
7419      &          AEAb1derx(1,lll,kkk,iii,1,2))
7420               call matvec2(auxmat(1,1),Ub2(1,l),
7421      &          AEAb2derx(1,lll,kkk,iii,1,2))
7422               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7423      &          AEAb1derx(1,lll,kkk,iii,2,2))
7424               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7425      &          AEAb2derx(1,lll,kkk,iii,2,2))
7426             enddo
7427           enddo
7428         enddo
7429         ENDIF
7430 C End vectors
7431       endif
7432       return
7433       end
7434 C---------------------------------------------------------------------------
7435       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7436      &  KK,KKderg,AKA,AKAderg,AKAderx)
7437       implicit none
7438       integer nderg
7439       logical transp
7440       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7441      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7442      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7443       integer iii,kkk,lll
7444       integer jjj,mmm
7445       logical lprn
7446       common /kutas/ lprn
7447       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7448       do iii=1,nderg
7449         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7450      &    AKAderg(1,1,iii))
7451       enddo
7452 cd      if (lprn) write (2,*) 'In kernel'
7453       do kkk=1,5
7454 cd        if (lprn) write (2,*) 'kkk=',kkk
7455         do lll=1,3
7456           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7457      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7458 cd          if (lprn) then
7459 cd            write (2,*) 'lll=',lll
7460 cd            write (2,*) 'iii=1'
7461 cd            do jjj=1,2
7462 cd              write (2,'(3(2f10.5),5x)')
7463 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7464 cd            enddo
7465 cd          endif
7466           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7467      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7468 cd          if (lprn) then
7469 cd            write (2,*) 'lll=',lll
7470 cd            write (2,*) 'iii=2'
7471 cd            do jjj=1,2
7472 cd              write (2,'(3(2f10.5),5x)')
7473 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7474 cd            enddo
7475 cd          endif
7476         enddo
7477       enddo
7478       return
7479       end
7480 C---------------------------------------------------------------------------
7481       double precision function eello4(i,j,k,l,jj,kk)
7482       implicit real*8 (a-h,o-z)
7483       include 'DIMENSIONS'
7484       include 'COMMON.IOUNITS'
7485       include 'COMMON.CHAIN'
7486       include 'COMMON.DERIV'
7487       include 'COMMON.INTERACT'
7488       include 'COMMON.CONTACTS'
7489       include 'COMMON.TORSION'
7490       include 'COMMON.VAR'
7491       include 'COMMON.GEO'
7492       double precision pizda(2,2),ggg1(3),ggg2(3)
7493 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7494 cd        eello4=0.0d0
7495 cd        return
7496 cd      endif
7497 cd      print *,'eello4:',i,j,k,l,jj,kk
7498 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7499 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7500 cold      eij=facont_hb(jj,i)
7501 cold      ekl=facont_hb(kk,k)
7502 cold      ekont=eij*ekl
7503       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7504 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7505       gcorr_loc(k-1)=gcorr_loc(k-1)
7506      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7507       if (l.eq.j+1) then
7508         gcorr_loc(l-1)=gcorr_loc(l-1)
7509      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7510       else
7511         gcorr_loc(j-1)=gcorr_loc(j-1)
7512      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7513       endif
7514       do iii=1,2
7515         do kkk=1,5
7516           do lll=1,3
7517             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7518      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7519 cd            derx(lll,kkk,iii)=0.0d0
7520           enddo
7521         enddo
7522       enddo
7523 cd      gcorr_loc(l-1)=0.0d0
7524 cd      gcorr_loc(j-1)=0.0d0
7525 cd      gcorr_loc(k-1)=0.0d0
7526 cd      eel4=1.0d0
7527 cd      write (iout,*)'Contacts have occurred for peptide groups',
7528 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7529 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7530       if (j.lt.nres-1) then
7531         j1=j+1
7532         j2=j-1
7533       else
7534         j1=j-1
7535         j2=j-2
7536       endif
7537       if (l.lt.nres-1) then
7538         l1=l+1
7539         l2=l-1
7540       else
7541         l1=l-1
7542         l2=l-2
7543       endif
7544       do ll=1,3
7545 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7546 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7547         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7548         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7549 cgrad        ghalf=0.5d0*ggg1(ll)
7550         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7551         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7552         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7553         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7554         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7555         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7556 cgrad        ghalf=0.5d0*ggg2(ll)
7557         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7558         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7559         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7560         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7561         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7562         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7563       enddo
7564 cgrad      do m=i+1,j-1
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cgrad      do m=k+1,l-1
7570 cgrad        do ll=1,3
7571 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7572 cgrad        enddo
7573 cgrad      enddo
7574 cgrad      do m=i+2,j2
7575 cgrad        do ll=1,3
7576 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7577 cgrad        enddo
7578 cgrad      enddo
7579 cgrad      do m=k+2,l2
7580 cgrad        do ll=1,3
7581 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7582 cgrad        enddo
7583 cgrad      enddo
7584 cd      do iii=1,nres-3
7585 cd        write (2,*) iii,gcorr_loc(iii)
7586 cd      enddo
7587       eello4=ekont*eel4
7588 cd      write (2,*) 'ekont',ekont
7589 cd      write (iout,*) 'eello4',ekont*eel4
7590       return
7591       end
7592 C---------------------------------------------------------------------------
7593       double precision function eello5(i,j,k,l,jj,kk)
7594       implicit real*8 (a-h,o-z)
7595       include 'DIMENSIONS'
7596       include 'COMMON.IOUNITS'
7597       include 'COMMON.CHAIN'
7598       include 'COMMON.DERIV'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.CONTACTS'
7601       include 'COMMON.TORSION'
7602       include 'COMMON.VAR'
7603       include 'COMMON.GEO'
7604       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7605       double precision ggg1(3),ggg2(3)
7606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7607 C                                                                              C
7608 C                            Parallel chains                                   C
7609 C                                                                              C
7610 C          o             o                   o             o                   C
7611 C         /l\           / \             \   / \           / \   /              C
7612 C        /   \         /   \             \ /   \         /   \ /               C
7613 C       j| o |l1       | o |              o| o |         | o |o                C
7614 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7615 C      \i/   \         /   \ /             /   \         /   \                 C
7616 C       o    k1             o                                                  C
7617 C         (I)          (II)                (III)          (IV)                 C
7618 C                                                                              C
7619 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7620 C                                                                              C
7621 C                            Antiparallel chains                               C
7622 C                                                                              C
7623 C          o             o                   o             o                   C
7624 C         /j\           / \             \   / \           / \   /              C
7625 C        /   \         /   \             \ /   \         /   \ /               C
7626 C      j1| o |l        | o |              o| o |         | o |o                C
7627 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7628 C      \i/   \         /   \ /             /   \         /   \                 C
7629 C       o     k1            o                                                  C
7630 C         (I)          (II)                (III)          (IV)                 C
7631 C                                                                              C
7632 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7633 C                                                                              C
7634 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7635 C                                                                              C
7636 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7637 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7638 cd        eello5=0.0d0
7639 cd        return
7640 cd      endif
7641 cd      write (iout,*)
7642 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7643 cd     &   ' and',k,l
7644       itk=itortyp(itype(k))
7645       itl=itortyp(itype(l))
7646       itj=itortyp(itype(j))
7647       eello5_1=0.0d0
7648       eello5_2=0.0d0
7649       eello5_3=0.0d0
7650       eello5_4=0.0d0
7651 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7652 cd     &   eel5_3_num,eel5_4_num)
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656             derx(lll,kkk,iii)=0.0d0
7657           enddo
7658         enddo
7659       enddo
7660 cd      eij=facont_hb(jj,i)
7661 cd      ekl=facont_hb(kk,k)
7662 cd      ekont=eij*ekl
7663 cd      write (iout,*)'Contacts have occurred for peptide groups',
7664 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7665 cd      goto 1111
7666 C Contribution from the graph I.
7667 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7668 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7669       call transpose2(EUg(1,1,k),auxmat(1,1))
7670       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7671       vv(1)=pizda(1,1)-pizda(2,2)
7672       vv(2)=pizda(1,2)+pizda(2,1)
7673       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7674      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7675 C Explicit gradient in virtual-dihedral angles.
7676       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7677      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7678      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7679       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7680       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7681       vv(1)=pizda(1,1)-pizda(2,2)
7682       vv(2)=pizda(1,2)+pizda(2,1)
7683       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7684      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7685      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7686       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7687       vv(1)=pizda(1,1)-pizda(2,2)
7688       vv(2)=pizda(1,2)+pizda(2,1)
7689       if (l.eq.j+1) then
7690         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7691      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7692      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7693       else
7694         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7695      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7696      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7697       endif
7698 C Cartesian gradient
7699       do iii=1,2
7700         do kkk=1,5
7701           do lll=1,3
7702             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7703      &        pizda(1,1))
7704             vv(1)=pizda(1,1)-pizda(2,2)
7705             vv(2)=pizda(1,2)+pizda(2,1)
7706             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7707      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7708      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7709           enddo
7710         enddo
7711       enddo
7712 c      goto 1112
7713 c1111  continue
7714 C Contribution from graph II
7715       call transpose2(EE(1,1,itk),auxmat(1,1))
7716       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7717       vv(1)=pizda(1,1)+pizda(2,2)
7718       vv(2)=pizda(2,1)-pizda(1,2)
7719       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7720      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7721 C Explicit gradient in virtual-dihedral angles.
7722       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7723      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7724       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7725       vv(1)=pizda(1,1)+pizda(2,2)
7726       vv(2)=pizda(2,1)-pizda(1,2)
7727       if (l.eq.j+1) then
7728         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7729      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7730      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7731       else
7732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7733      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7734      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7735       endif
7736 C Cartesian gradient
7737       do iii=1,2
7738         do kkk=1,5
7739           do lll=1,3
7740             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7741      &        pizda(1,1))
7742             vv(1)=pizda(1,1)+pizda(2,2)
7743             vv(2)=pizda(2,1)-pizda(1,2)
7744             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7745      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7746      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7747           enddo
7748         enddo
7749       enddo
7750 cd      goto 1112
7751 cd1111  continue
7752       if (l.eq.j+1) then
7753 cd        goto 1110
7754 C Parallel orientation
7755 C Contribution from graph III
7756         call transpose2(EUg(1,1,l),auxmat(1,1))
7757         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7758         vv(1)=pizda(1,1)-pizda(2,2)
7759         vv(2)=pizda(1,2)+pizda(2,1)
7760         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7762 C Explicit gradient in virtual-dihedral angles.
7763         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7764      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7765      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7766         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7767         vv(1)=pizda(1,1)-pizda(2,2)
7768         vv(2)=pizda(1,2)+pizda(2,1)
7769         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7770      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7771      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7772         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7773         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7774         vv(1)=pizda(1,1)-pizda(2,2)
7775         vv(2)=pizda(1,2)+pizda(2,1)
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7778      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7779 C Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7784      &          pizda(1,1))
7785               vv(1)=pizda(1,1)-pizda(2,2)
7786               vv(2)=pizda(1,2)+pizda(2,1)
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7788      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7789      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7790             enddo
7791           enddo
7792         enddo
7793 cd        goto 1112
7794 C Contribution from graph IV
7795 cd1110    continue
7796         call transpose2(EE(1,1,itl),auxmat(1,1))
7797         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7798         vv(1)=pizda(1,1)+pizda(2,2)
7799         vv(2)=pizda(2,1)-pizda(1,2)
7800         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7801      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7802 C Explicit gradient in virtual-dihedral angles.
7803         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7804      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7805         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7806         vv(1)=pizda(1,1)+pizda(2,2)
7807         vv(2)=pizda(2,1)-pizda(1,2)
7808         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7809      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7810      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7811 C Cartesian gradient
7812         do iii=1,2
7813           do kkk=1,5
7814             do lll=1,3
7815               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7816      &          pizda(1,1))
7817               vv(1)=pizda(1,1)+pizda(2,2)
7818               vv(2)=pizda(2,1)-pizda(1,2)
7819               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7820      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7821      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7822             enddo
7823           enddo
7824         enddo
7825       else
7826 C Antiparallel orientation
7827 C Contribution from graph III
7828 c        goto 1110
7829         call transpose2(EUg(1,1,j),auxmat(1,1))
7830         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7831         vv(1)=pizda(1,1)-pizda(2,2)
7832         vv(2)=pizda(1,2)+pizda(2,1)
7833         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7834      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7835 C Explicit gradient in virtual-dihedral angles.
7836         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7837      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7838      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7839         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7840         vv(1)=pizda(1,1)-pizda(2,2)
7841         vv(2)=pizda(1,2)+pizda(2,1)
7842         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7843      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7844      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7845         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7846         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7847         vv(1)=pizda(1,1)-pizda(2,2)
7848         vv(2)=pizda(1,2)+pizda(2,1)
7849         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7850      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7851      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7852 C Cartesian gradient
7853         do iii=1,2
7854           do kkk=1,5
7855             do lll=1,3
7856               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7857      &          pizda(1,1))
7858               vv(1)=pizda(1,1)-pizda(2,2)
7859               vv(2)=pizda(1,2)+pizda(2,1)
7860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7861      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7862      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7863             enddo
7864           enddo
7865         enddo
7866 cd        goto 1112
7867 C Contribution from graph IV
7868 1110    continue
7869         call transpose2(EE(1,1,itj),auxmat(1,1))
7870         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7871         vv(1)=pizda(1,1)+pizda(2,2)
7872         vv(2)=pizda(2,1)-pizda(1,2)
7873         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7874      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7875 C Explicit gradient in virtual-dihedral angles.
7876         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7877      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7878         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7879         vv(1)=pizda(1,1)+pizda(2,2)
7880         vv(2)=pizda(2,1)-pizda(1,2)
7881         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7882      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7883      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7884 C Cartesian gradient
7885         do iii=1,2
7886           do kkk=1,5
7887             do lll=1,3
7888               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7889      &          pizda(1,1))
7890               vv(1)=pizda(1,1)+pizda(2,2)
7891               vv(2)=pizda(2,1)-pizda(1,2)
7892               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7893      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7894      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7895             enddo
7896           enddo
7897         enddo
7898       endif
7899 1112  continue
7900       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7901 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7902 cd        write (2,*) 'ijkl',i,j,k,l
7903 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7904 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7905 cd      endif
7906 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7907 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7908 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7909 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7910       if (j.lt.nres-1) then
7911         j1=j+1
7912         j2=j-1
7913       else
7914         j1=j-1
7915         j2=j-2
7916       endif
7917       if (l.lt.nres-1) then
7918         l1=l+1
7919         l2=l-1
7920       else
7921         l1=l-1
7922         l2=l-2
7923       endif
7924 cd      eij=1.0d0
7925 cd      ekl=1.0d0
7926 cd      ekont=1.0d0
7927 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7928 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7929 C        summed up outside the subrouine as for the other subroutines
7930 C        handling long-range interactions. The old code is commented out
7931 C        with "cgrad" to keep track of changes.
7932       do ll=1,3
7933 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7934 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7935         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7936         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7937 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7938 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7939 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7940 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7941 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7942 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7943 c     &   gradcorr5ij,
7944 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7945 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7946 cgrad        ghalf=0.5d0*ggg1(ll)
7947 cd        ghalf=0.0d0
7948         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7949         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7950         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7951         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7952         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7953         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7954 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7955 cgrad        ghalf=0.5d0*ggg2(ll)
7956 cd        ghalf=0.0d0
7957         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7958         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7959         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7960         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7961         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7962         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7963       enddo
7964 cd      goto 1112
7965 cgrad      do m=i+1,j-1
7966 cgrad        do ll=1,3
7967 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7968 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7969 cgrad        enddo
7970 cgrad      enddo
7971 cgrad      do m=k+1,l-1
7972 cgrad        do ll=1,3
7973 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7974 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7975 cgrad        enddo
7976 cgrad      enddo
7977 c1112  continue
7978 cgrad      do m=i+2,j2
7979 cgrad        do ll=1,3
7980 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7981 cgrad        enddo
7982 cgrad      enddo
7983 cgrad      do m=k+2,l2
7984 cgrad        do ll=1,3
7985 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cd      do iii=1,nres-3
7989 cd        write (2,*) iii,g_corr5_loc(iii)
7990 cd      enddo
7991       eello5=ekont*eel5
7992 cd      write (2,*) 'ekont',ekont
7993 cd      write (iout,*) 'eello5',ekont*eel5
7994       return
7995       end
7996 c--------------------------------------------------------------------------
7997       double precision function eello6(i,j,k,l,jj,kk)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       include 'COMMON.IOUNITS'
8001       include 'COMMON.CHAIN'
8002       include 'COMMON.DERIV'
8003       include 'COMMON.INTERACT'
8004       include 'COMMON.CONTACTS'
8005       include 'COMMON.TORSION'
8006       include 'COMMON.VAR'
8007       include 'COMMON.GEO'
8008       include 'COMMON.FFIELD'
8009       double precision ggg1(3),ggg2(3)
8010 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8011 cd        eello6=0.0d0
8012 cd        return
8013 cd      endif
8014 cd      write (iout,*)
8015 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8016 cd     &   ' and',k,l
8017       eello6_1=0.0d0
8018       eello6_2=0.0d0
8019       eello6_3=0.0d0
8020       eello6_4=0.0d0
8021       eello6_5=0.0d0
8022       eello6_6=0.0d0
8023 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8024 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8025       do iii=1,2
8026         do kkk=1,5
8027           do lll=1,3
8028             derx(lll,kkk,iii)=0.0d0
8029           enddo
8030         enddo
8031       enddo
8032 cd      eij=facont_hb(jj,i)
8033 cd      ekl=facont_hb(kk,k)
8034 cd      ekont=eij*ekl
8035 cd      eij=1.0d0
8036 cd      ekl=1.0d0
8037 cd      ekont=1.0d0
8038       if (l.eq.j+1) then
8039         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8040         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8041         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8042         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8043         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8044         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8045       else
8046         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8047         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8048         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8049         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8050         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8051           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8052         else
8053           eello6_5=0.0d0
8054         endif
8055         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8056       endif
8057 C If turn contributions are considered, they will be handled separately.
8058       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8059 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8060 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8061 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8062 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8063 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8064 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8065 cd      goto 1112
8066       if (j.lt.nres-1) then
8067         j1=j+1
8068         j2=j-1
8069       else
8070         j1=j-1
8071         j2=j-2
8072       endif
8073       if (l.lt.nres-1) then
8074         l1=l+1
8075         l2=l-1
8076       else
8077         l1=l-1
8078         l2=l-2
8079       endif
8080       do ll=1,3
8081 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8082 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8083 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8084 cgrad        ghalf=0.5d0*ggg1(ll)
8085 cd        ghalf=0.0d0
8086         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8087         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8088         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8089         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8090         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8091         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8092         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8093         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8094 cgrad        ghalf=0.5d0*ggg2(ll)
8095 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8096 cd        ghalf=0.0d0
8097         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8098         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8099         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8100         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8101         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8102         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8103       enddo
8104 cd      goto 1112
8105 cgrad      do m=i+1,j-1
8106 cgrad        do ll=1,3
8107 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8108 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8109 cgrad        enddo
8110 cgrad      enddo
8111 cgrad      do m=k+1,l-1
8112 cgrad        do ll=1,3
8113 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8114 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8115 cgrad        enddo
8116 cgrad      enddo
8117 cgrad1112  continue
8118 cgrad      do m=i+2,j2
8119 cgrad        do ll=1,3
8120 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8121 cgrad        enddo
8122 cgrad      enddo
8123 cgrad      do m=k+2,l2
8124 cgrad        do ll=1,3
8125 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8126 cgrad        enddo
8127 cgrad      enddo
8128 cd      do iii=1,nres-3
8129 cd        write (2,*) iii,g_corr6_loc(iii)
8130 cd      enddo
8131       eello6=ekont*eel6
8132 cd      write (2,*) 'ekont',ekont
8133 cd      write (iout,*) 'eello6',ekont*eel6
8134       return
8135       end
8136 c--------------------------------------------------------------------------
8137       double precision function eello6_graph1(i,j,k,l,imat,swap)
8138       implicit real*8 (a-h,o-z)
8139       include 'DIMENSIONS'
8140       include 'COMMON.IOUNITS'
8141       include 'COMMON.CHAIN'
8142       include 'COMMON.DERIV'
8143       include 'COMMON.INTERACT'
8144       include 'COMMON.CONTACTS'
8145       include 'COMMON.TORSION'
8146       include 'COMMON.VAR'
8147       include 'COMMON.GEO'
8148       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8149       logical swap
8150       logical lprn
8151       common /kutas/ lprn
8152 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8153 C                                                                              C
8154 C      Parallel       Antiparallel                                             C
8155 C                                                                              C
8156 C          o             o                                                     C
8157 C         /l\           /j\                                                    C
8158 C        /   \         /   \                                                   C
8159 C       /| o |         | o |\                                                  C
8160 C     \ j|/k\|  /   \  |/k\|l /                                                C
8161 C      \ /   \ /     \ /   \ /                                                 C
8162 C       o     o       o     o                                                  C
8163 C       i             i                                                        C
8164 C                                                                              C
8165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8166       itk=itortyp(itype(k))
8167       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8168       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8169       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8170       call transpose2(EUgC(1,1,k),auxmat(1,1))
8171       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8172       vv1(1)=pizda1(1,1)-pizda1(2,2)
8173       vv1(2)=pizda1(1,2)+pizda1(2,1)
8174       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8175       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8176       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8177       s5=scalar2(vv(1),Dtobr2(1,i))
8178 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8179       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8180       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8181      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8182      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8183      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8184      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8185      & +scalar2(vv(1),Dtobr2der(1,i)))
8186       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8187       vv1(1)=pizda1(1,1)-pizda1(2,2)
8188       vv1(2)=pizda1(1,2)+pizda1(2,1)
8189       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8190       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8191       if (l.eq.j+1) then
8192         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8193      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8194      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8195      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8196      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8197       else
8198         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8199      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8200      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8201      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8202      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8203       endif
8204       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8205       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8206       vv1(1)=pizda1(1,1)-pizda1(2,2)
8207       vv1(2)=pizda1(1,2)+pizda1(2,1)
8208       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8209      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8210      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8211      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8212       do iii=1,2
8213         if (swap) then
8214           ind=3-iii
8215         else
8216           ind=iii
8217         endif
8218         do kkk=1,5
8219           do lll=1,3
8220             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8221             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8222             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8223             call transpose2(EUgC(1,1,k),auxmat(1,1))
8224             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8225      &        pizda1(1,1))
8226             vv1(1)=pizda1(1,1)-pizda1(2,2)
8227             vv1(2)=pizda1(1,2)+pizda1(2,1)
8228             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8229             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8230      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8231             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8232      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8233             s5=scalar2(vv(1),Dtobr2(1,i))
8234             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8235           enddo
8236         enddo
8237       enddo
8238       return
8239       end
8240 c----------------------------------------------------------------------------
8241       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8242       implicit real*8 (a-h,o-z)
8243       include 'DIMENSIONS'
8244       include 'COMMON.IOUNITS'
8245       include 'COMMON.CHAIN'
8246       include 'COMMON.DERIV'
8247       include 'COMMON.INTERACT'
8248       include 'COMMON.CONTACTS'
8249       include 'COMMON.TORSION'
8250       include 'COMMON.VAR'
8251       include 'COMMON.GEO'
8252       logical swap
8253       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8254      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8255       logical lprn
8256       common /kutas/ lprn
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 C                                                                              C
8259 C      Parallel       Antiparallel                                             C
8260 C                                                                              C
8261 C          o             o                                                     C
8262 C     \   /l\           /j\   /                                                C
8263 C      \ /   \         /   \ /                                                 C
8264 C       o| o |         | o |o                                                  C
8265 C     \ j|/k\|      \  |/k\|l                                                  C
8266 C      \ /   \       \ /   \                                                   C
8267 C       o             o                                                        C
8268 C       i             i                                                        C
8269 C                                                                              C
8270 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8271 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8272 C AL 7/4/01 s1 would occur in the sixth-order moment,
8273 C           but not in a cluster cumulant
8274 #ifdef MOMENT
8275       s1=dip(1,jj,i)*dip(1,kk,k)
8276 #endif
8277       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8278       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8279       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8280       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8281       call transpose2(EUg(1,1,k),auxmat(1,1))
8282       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)-pizda(2,2)
8284       vv(2)=pizda(1,2)+pizda(2,1)
8285       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8286 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8287 #ifdef MOMENT
8288       eello6_graph2=-(s1+s2+s3+s4)
8289 #else
8290       eello6_graph2=-(s2+s3+s4)
8291 #endif
8292 c      eello6_graph2=-s3
8293 C Derivatives in gamma(i-1)
8294       if (i.gt.1) then
8295 #ifdef MOMENT
8296         s1=dipderg(1,jj,i)*dip(1,kk,k)
8297 #endif
8298         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8299         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8300         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8301         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8302 #ifdef MOMENT
8303         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8304 #else
8305         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8306 #endif
8307 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8308       endif
8309 C Derivatives in gamma(k-1)
8310 #ifdef MOMENT
8311       s1=dip(1,jj,i)*dipderg(1,kk,k)
8312 #endif
8313       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8314       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8316       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8317       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8318       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8319       vv(1)=pizda(1,1)-pizda(2,2)
8320       vv(2)=pizda(1,2)+pizda(2,1)
8321       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8322 #ifdef MOMENT
8323       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8324 #else
8325       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8326 #endif
8327 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8328 C Derivatives in gamma(j-1) or gamma(l-1)
8329       if (j.gt.1) then
8330 #ifdef MOMENT
8331         s1=dipderg(3,jj,i)*dip(1,kk,k)
8332 #endif
8333         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8334         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8335         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8336         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8337         vv(1)=pizda(1,1)-pizda(2,2)
8338         vv(2)=pizda(1,2)+pizda(2,1)
8339         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8340 #ifdef MOMENT
8341         if (swap) then
8342           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8343         else
8344           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8345         endif
8346 #endif
8347         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8348 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8349       endif
8350 C Derivatives in gamma(l-1) or gamma(j-1)
8351       if (l.gt.1) then
8352 #ifdef MOMENT
8353         s1=dip(1,jj,i)*dipderg(3,kk,k)
8354 #endif
8355         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8356         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8357         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8358         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8359         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8363 #ifdef MOMENT
8364         if (swap) then
8365           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8366         else
8367           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8368         endif
8369 #endif
8370         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8371 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8372       endif
8373 C Cartesian derivatives.
8374       if (lprn) then
8375         write (2,*) 'In eello6_graph2'
8376         do iii=1,2
8377           write (2,*) 'iii=',iii
8378           do kkk=1,5
8379             write (2,*) 'kkk=',kkk
8380             do jjj=1,2
8381               write (2,'(3(2f10.5),5x)')
8382      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8383             enddo
8384           enddo
8385         enddo
8386       endif
8387       do iii=1,2
8388         do kkk=1,5
8389           do lll=1,3
8390 #ifdef MOMENT
8391             if (iii.eq.1) then
8392               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8393             else
8394               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8395             endif
8396 #endif
8397             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8398      &        auxvec(1))
8399             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8400             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8401      &        auxvec(1))
8402             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8403             call transpose2(EUg(1,1,k),auxmat(1,1))
8404             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8405      &        pizda(1,1))
8406             vv(1)=pizda(1,1)-pizda(2,2)
8407             vv(2)=pizda(1,2)+pizda(2,1)
8408             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8409 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8410 #ifdef MOMENT
8411             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8412 #else
8413             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8414 #endif
8415             if (swap) then
8416               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8417             else
8418               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8419             endif
8420           enddo
8421         enddo
8422       enddo
8423       return
8424       end
8425 c----------------------------------------------------------------------------
8426       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8427       implicit real*8 (a-h,o-z)
8428       include 'DIMENSIONS'
8429       include 'COMMON.IOUNITS'
8430       include 'COMMON.CHAIN'
8431       include 'COMMON.DERIV'
8432       include 'COMMON.INTERACT'
8433       include 'COMMON.CONTACTS'
8434       include 'COMMON.TORSION'
8435       include 'COMMON.VAR'
8436       include 'COMMON.GEO'
8437       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8438       logical swap
8439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8440 C                                                                              C
8441 C      Parallel       Antiparallel                                             C
8442 C                                                                              C
8443 C          o             o                                                     C
8444 C         /l\   /   \   /j\                                                    C
8445 C        /   \ /     \ /   \                                                   C
8446 C       /| o |o       o| o |\                                                  C
8447 C       j|/k\|  /      |/k\|l /                                                C
8448 C        /   \ /       /   \ /                                                 C
8449 C       /     o       /     o                                                  C
8450 C       i             i                                                        C
8451 C                                                                              C
8452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8453 C
8454 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8455 C           energy moment and not to the cluster cumulant.
8456       iti=itortyp(itype(i))
8457       if (j.lt.nres-1) then
8458         itj1=itortyp(itype(j+1))
8459       else
8460         itj1=ntortyp+1
8461       endif
8462       itk=itortyp(itype(k))
8463       itk1=itortyp(itype(k+1))
8464       if (l.lt.nres-1) then
8465         itl1=itortyp(itype(l+1))
8466       else
8467         itl1=ntortyp+1
8468       endif
8469 #ifdef MOMENT
8470       s1=dip(4,jj,i)*dip(4,kk,k)
8471 #endif
8472       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8473       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8474       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8475       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8476       call transpose2(EE(1,1,itk),auxmat(1,1))
8477       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8478       vv(1)=pizda(1,1)+pizda(2,2)
8479       vv(2)=pizda(2,1)-pizda(1,2)
8480       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8481 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8482 cd     & "sum",-(s2+s3+s4)
8483 #ifdef MOMENT
8484       eello6_graph3=-(s1+s2+s3+s4)
8485 #else
8486       eello6_graph3=-(s2+s3+s4)
8487 #endif
8488 c      eello6_graph3=-s4
8489 C Derivatives in gamma(k-1)
8490       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8491       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8492       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8493       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8494 C Derivatives in gamma(l-1)
8495       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8496       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8497       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8498       vv(1)=pizda(1,1)+pizda(2,2)
8499       vv(2)=pizda(2,1)-pizda(1,2)
8500       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8501       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8502 C Cartesian derivatives.
8503       do iii=1,2
8504         do kkk=1,5
8505           do lll=1,3
8506 #ifdef MOMENT
8507             if (iii.eq.1) then
8508               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8509             else
8510               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8511             endif
8512 #endif
8513             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8514      &        auxvec(1))
8515             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8516             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8517      &        auxvec(1))
8518             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8519             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8520      &        pizda(1,1))
8521             vv(1)=pizda(1,1)+pizda(2,2)
8522             vv(2)=pizda(2,1)-pizda(1,2)
8523             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8524 #ifdef MOMENT
8525             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8526 #else
8527             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8528 #endif
8529             if (swap) then
8530               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8531             else
8532               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8533             endif
8534 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8535           enddo
8536         enddo
8537       enddo
8538       return
8539       end
8540 c----------------------------------------------------------------------------
8541       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8542       implicit real*8 (a-h,o-z)
8543       include 'DIMENSIONS'
8544       include 'COMMON.IOUNITS'
8545       include 'COMMON.CHAIN'
8546       include 'COMMON.DERIV'
8547       include 'COMMON.INTERACT'
8548       include 'COMMON.CONTACTS'
8549       include 'COMMON.TORSION'
8550       include 'COMMON.VAR'
8551       include 'COMMON.GEO'
8552       include 'COMMON.FFIELD'
8553       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8554      & auxvec1(2),auxmat1(2,2)
8555       logical swap
8556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8557 C                                                                              C
8558 C      Parallel       Antiparallel                                             C
8559 C                                                                              C
8560 C          o             o                                                     C
8561 C         /l\   /   \   /j\                                                    C
8562 C        /   \ /     \ /   \                                                   C
8563 C       /| o |o       o| o |\                                                  C
8564 C     \ j|/k\|      \  |/k\|l                                                  C
8565 C      \ /   \       \ /   \                                                   C
8566 C       o     \       o     \                                                  C
8567 C       i             i                                                        C
8568 C                                                                              C
8569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8570 C
8571 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8572 C           energy moment and not to the cluster cumulant.
8573 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8574       iti=itortyp(itype(i))
8575       itj=itortyp(itype(j))
8576       if (j.lt.nres-1) then
8577         itj1=itortyp(itype(j+1))
8578       else
8579         itj1=ntortyp+1
8580       endif
8581       itk=itortyp(itype(k))
8582       if (k.lt.nres-1) then
8583         itk1=itortyp(itype(k+1))
8584       else
8585         itk1=ntortyp+1
8586       endif
8587       itl=itortyp(itype(l))
8588       if (l.lt.nres-1) then
8589         itl1=itortyp(itype(l+1))
8590       else
8591         itl1=ntortyp+1
8592       endif
8593 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8594 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8595 cd     & ' itl',itl,' itl1',itl1
8596 #ifdef MOMENT
8597       if (imat.eq.1) then
8598         s1=dip(3,jj,i)*dip(3,kk,k)
8599       else
8600         s1=dip(2,jj,j)*dip(2,kk,l)
8601       endif
8602 #endif
8603       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8604       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8605       if (j.eq.l+1) then
8606         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8607         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8608       else
8609         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8610         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8611       endif
8612       call transpose2(EUg(1,1,k),auxmat(1,1))
8613       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8614       vv(1)=pizda(1,1)-pizda(2,2)
8615       vv(2)=pizda(2,1)+pizda(1,2)
8616       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8617 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8618 #ifdef MOMENT
8619       eello6_graph4=-(s1+s2+s3+s4)
8620 #else
8621       eello6_graph4=-(s2+s3+s4)
8622 #endif
8623 C Derivatives in gamma(i-1)
8624       if (i.gt.1) then
8625 #ifdef MOMENT
8626         if (imat.eq.1) then
8627           s1=dipderg(2,jj,i)*dip(3,kk,k)
8628         else
8629           s1=dipderg(4,jj,j)*dip(2,kk,l)
8630         endif
8631 #endif
8632         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8633         if (j.eq.l+1) then
8634           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8635           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8636         else
8637           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8638           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8639         endif
8640         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8641         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8642 cd          write (2,*) 'turn6 derivatives'
8643 #ifdef MOMENT
8644           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8647 #endif
8648         else
8649 #ifdef MOMENT
8650           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8651 #else
8652           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8653 #endif
8654         endif
8655       endif
8656 C Derivatives in gamma(k-1)
8657 #ifdef MOMENT
8658       if (imat.eq.1) then
8659         s1=dip(3,jj,i)*dipderg(2,kk,k)
8660       else
8661         s1=dip(2,jj,j)*dipderg(4,kk,l)
8662       endif
8663 #endif
8664       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8665       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8666       if (j.eq.l+1) then
8667         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8668         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8669       else
8670         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8671         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8672       endif
8673       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8674       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8675       vv(1)=pizda(1,1)-pizda(2,2)
8676       vv(2)=pizda(2,1)+pizda(1,2)
8677       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8678       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8679 #ifdef MOMENT
8680         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8681 #else
8682         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8683 #endif
8684       else
8685 #ifdef MOMENT
8686         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8687 #else
8688         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8689 #endif
8690       endif
8691 C Derivatives in gamma(j-1) or gamma(l-1)
8692       if (l.eq.j+1 .and. l.gt.1) then
8693         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8694         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8695         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8696         vv(1)=pizda(1,1)-pizda(2,2)
8697         vv(2)=pizda(2,1)+pizda(1,2)
8698         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8699         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8700       else if (j.gt.1) then
8701         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8702         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8703         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8704         vv(1)=pizda(1,1)-pizda(2,2)
8705         vv(2)=pizda(2,1)+pizda(1,2)
8706         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8707         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8708           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8709         else
8710           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8711         endif
8712       endif
8713 C Cartesian derivatives.
8714       do iii=1,2
8715         do kkk=1,5
8716           do lll=1,3
8717 #ifdef MOMENT
8718             if (iii.eq.1) then
8719               if (imat.eq.1) then
8720                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8721               else
8722                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8723               endif
8724             else
8725               if (imat.eq.1) then
8726                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8727               else
8728                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8729               endif
8730             endif
8731 #endif
8732             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8733      &        auxvec(1))
8734             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8735             if (j.eq.l+1) then
8736               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8737      &          b1(1,j+1),auxvec(1))
8738               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8739             else
8740               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8741      &          b1(1,l+1),auxvec(1))
8742               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8743             endif
8744             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8745      &        pizda(1,1))
8746             vv(1)=pizda(1,1)-pizda(2,2)
8747             vv(2)=pizda(2,1)+pizda(1,2)
8748             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8749             if (swap) then
8750               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8751 #ifdef MOMENT
8752                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8753      &             -(s1+s2+s4)
8754 #else
8755                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8756      &             -(s2+s4)
8757 #endif
8758                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8759               else
8760 #ifdef MOMENT
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8762 #else
8763                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8764 #endif
8765                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8766               endif
8767             else
8768 #ifdef MOMENT
8769               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8770 #else
8771               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8772 #endif
8773               if (l.eq.j+1) then
8774                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8775               else
8776                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8777               endif
8778             endif
8779           enddo
8780         enddo
8781       enddo
8782       return
8783       end
8784 c----------------------------------------------------------------------------
8785       double precision function eello_turn6(i,jj,kk)
8786       implicit real*8 (a-h,o-z)
8787       include 'DIMENSIONS'
8788       include 'COMMON.IOUNITS'
8789       include 'COMMON.CHAIN'
8790       include 'COMMON.DERIV'
8791       include 'COMMON.INTERACT'
8792       include 'COMMON.CONTACTS'
8793       include 'COMMON.TORSION'
8794       include 'COMMON.VAR'
8795       include 'COMMON.GEO'
8796       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8797      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8798      &  ggg1(3),ggg2(3)
8799       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8800      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8801 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8802 C           the respective energy moment and not to the cluster cumulant.
8803       s1=0.0d0
8804       s8=0.0d0
8805       s13=0.0d0
8806 c
8807       eello_turn6=0.0d0
8808       j=i+4
8809       k=i+1
8810       l=i+3
8811       iti=itortyp(itype(i))
8812       itk=itortyp(itype(k))
8813       itk1=itortyp(itype(k+1))
8814       itl=itortyp(itype(l))
8815       itj=itortyp(itype(j))
8816 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8817 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8818 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8819 cd        eello6=0.0d0
8820 cd        return
8821 cd      endif
8822 cd      write (iout,*)
8823 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8824 cd     &   ' and',k,l
8825 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8826       do iii=1,2
8827         do kkk=1,5
8828           do lll=1,3
8829             derx_turn(lll,kkk,iii)=0.0d0
8830           enddo
8831         enddo
8832       enddo
8833 cd      eij=1.0d0
8834 cd      ekl=1.0d0
8835 cd      ekont=1.0d0
8836       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8837 cd      eello6_5=0.0d0
8838 cd      write (2,*) 'eello6_5',eello6_5
8839 #ifdef MOMENT
8840       call transpose2(AEA(1,1,1),auxmat(1,1))
8841       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8842       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8843       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8844 #endif
8845       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8846       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8847       s2 = scalar2(b1(1,k),vtemp1(1))
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,2),atemp(1,1))
8850       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8851       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8852       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8853 #endif
8854       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8855       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8856       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8857 #ifdef MOMENT
8858       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8859       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8860       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8861       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8862       ss13 = scalar2(b1(1,k),vtemp4(1))
8863       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8864 #endif
8865 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8866 c      s1=0.0d0
8867 c      s2=0.0d0
8868 c      s8=0.0d0
8869 c      s12=0.0d0
8870 c      s13=0.0d0
8871       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8872 C Derivatives in gamma(i+2)
8873       s1d =0.0d0
8874       s8d =0.0d0
8875 #ifdef MOMENT
8876       call transpose2(AEA(1,1,1),auxmatd(1,1))
8877       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8878       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8879       call transpose2(AEAderg(1,1,2),atempd(1,1))
8880       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8881       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8882 #endif
8883       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8884       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8885       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8886 c      s1d=0.0d0
8887 c      s2d=0.0d0
8888 c      s8d=0.0d0
8889 c      s12d=0.0d0
8890 c      s13d=0.0d0
8891       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8892 C Derivatives in gamma(i+3)
8893 #ifdef MOMENT
8894       call transpose2(AEA(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8897       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8898 #endif
8899       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8900       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8901       s2d = scalar2(b1(1,k),vtemp1d(1))
8902 #ifdef MOMENT
8903       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8904       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8905 #endif
8906       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8907 #ifdef MOMENT
8908       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8909       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8910       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8911 #endif
8912 c      s1d=0.0d0
8913 c      s2d=0.0d0
8914 c      s8d=0.0d0
8915 c      s12d=0.0d0
8916 c      s13d=0.0d0
8917 #ifdef MOMENT
8918       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8919      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8920 #else
8921       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8922      &               -0.5d0*ekont*(s2d+s12d)
8923 #endif
8924 C Derivatives in gamma(i+4)
8925       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8926       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8927       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8928 #ifdef MOMENT
8929       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8930       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8931       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8932 #endif
8933 c      s1d=0.0d0
8934 c      s2d=0.0d0
8935 c      s8d=0.0d0
8936 C      s12d=0.0d0
8937 c      s13d=0.0d0
8938 #ifdef MOMENT
8939       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8940 #else
8941       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8942 #endif
8943 C Derivatives in gamma(i+5)
8944 #ifdef MOMENT
8945       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8946       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8947       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8948 #endif
8949       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8950       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8951       s2d = scalar2(b1(1,k),vtemp1d(1))
8952 #ifdef MOMENT
8953       call transpose2(AEA(1,1,2),atempd(1,1))
8954       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8955       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8956 #endif
8957       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8958       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8959 #ifdef MOMENT
8960       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8961       ss13d = scalar2(b1(1,k),vtemp4d(1))
8962       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8963 #endif
8964 c      s1d=0.0d0
8965 c      s2d=0.0d0
8966 c      s8d=0.0d0
8967 c      s12d=0.0d0
8968 c      s13d=0.0d0
8969 #ifdef MOMENT
8970       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8971      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8972 #else
8973       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8974      &               -0.5d0*ekont*(s2d+s12d)
8975 #endif
8976 C Cartesian derivatives
8977       do iii=1,2
8978         do kkk=1,5
8979           do lll=1,3
8980 #ifdef MOMENT
8981             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8982             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8983             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8984 #endif
8985             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8986             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8987      &          vtemp1d(1))
8988             s2d = scalar2(b1(1,k),vtemp1d(1))
8989 #ifdef MOMENT
8990             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8991             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8992             s8d = -(atempd(1,1)+atempd(2,2))*
8993      &           scalar2(cc(1,1,itl),vtemp2(1))
8994 #endif
8995             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8996      &           auxmatd(1,1))
8997             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8998             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8999 c      s1d=0.0d0
9000 c      s2d=0.0d0
9001 c      s8d=0.0d0
9002 c      s12d=0.0d0
9003 c      s13d=0.0d0
9004 #ifdef MOMENT
9005             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9006      &        - 0.5d0*(s1d+s2d)
9007 #else
9008             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9009      &        - 0.5d0*s2d
9010 #endif
9011 #ifdef MOMENT
9012             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9013      &        - 0.5d0*(s8d+s12d)
9014 #else
9015             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9016      &        - 0.5d0*s12d
9017 #endif
9018           enddo
9019         enddo
9020       enddo
9021 #ifdef MOMENT
9022       do kkk=1,5
9023         do lll=1,3
9024           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9025      &      achuj_tempd(1,1))
9026           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9027           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9028           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9029           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9030           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9031      &      vtemp4d(1))
9032           ss13d = scalar2(b1(1,k),vtemp4d(1))
9033           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9034           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9035         enddo
9036       enddo
9037 #endif
9038 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9039 cd     &  16*eel_turn6_num
9040 cd      goto 1112
9041       if (j.lt.nres-1) then
9042         j1=j+1
9043         j2=j-1
9044       else
9045         j1=j-1
9046         j2=j-2
9047       endif
9048       if (l.lt.nres-1) then
9049         l1=l+1
9050         l2=l-1
9051       else
9052         l1=l-1
9053         l2=l-2
9054       endif
9055       do ll=1,3
9056 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9057 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9058 cgrad        ghalf=0.5d0*ggg1(ll)
9059 cd        ghalf=0.0d0
9060         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9061         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9062         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9063      &    +ekont*derx_turn(ll,2,1)
9064         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9065         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9066      &    +ekont*derx_turn(ll,4,1)
9067         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9068         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9069         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9070 cgrad        ghalf=0.5d0*ggg2(ll)
9071 cd        ghalf=0.0d0
9072         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9073      &    +ekont*derx_turn(ll,2,2)
9074         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9075         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9076      &    +ekont*derx_turn(ll,4,2)
9077         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9078         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9079         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9080       enddo
9081 cd      goto 1112
9082 cgrad      do m=i+1,j-1
9083 cgrad        do ll=1,3
9084 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9085 cgrad        enddo
9086 cgrad      enddo
9087 cgrad      do m=k+1,l-1
9088 cgrad        do ll=1,3
9089 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9090 cgrad        enddo
9091 cgrad      enddo
9092 cgrad1112  continue
9093 cgrad      do m=i+2,j2
9094 cgrad        do ll=1,3
9095 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9096 cgrad        enddo
9097 cgrad      enddo
9098 cgrad      do m=k+2,l2
9099 cgrad        do ll=1,3
9100 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9101 cgrad        enddo
9102 cgrad      enddo
9103 cd      do iii=1,nres-3
9104 cd        write (2,*) iii,g_corr6_loc(iii)
9105 cd      enddo
9106       eello_turn6=ekont*eel_turn6
9107 cd      write (2,*) 'ekont',ekont
9108 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9109       return
9110       end
9111
9112 C-----------------------------------------------------------------------------
9113       double precision function scalar(u,v)
9114 !DIR$ INLINEALWAYS scalar
9115 #ifndef OSF
9116 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9117 #endif
9118       implicit none
9119       double precision u(3),v(3)
9120 cd      double precision sc
9121 cd      integer i
9122 cd      sc=0.0d0
9123 cd      do i=1,3
9124 cd        sc=sc+u(i)*v(i)
9125 cd      enddo
9126 cd      scalar=sc
9127
9128       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9129       return
9130       end
9131 crc-------------------------------------------------
9132       SUBROUTINE MATVEC2(A1,V1,V2)
9133 !DIR$ INLINEALWAYS MATVEC2
9134 #ifndef OSF
9135 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9136 #endif
9137       implicit real*8 (a-h,o-z)
9138       include 'DIMENSIONS'
9139       DIMENSION A1(2,2),V1(2),V2(2)
9140 c      DO 1 I=1,2
9141 c        VI=0.0
9142 c        DO 3 K=1,2
9143 c    3     VI=VI+A1(I,K)*V1(K)
9144 c        Vaux(I)=VI
9145 c    1 CONTINUE
9146
9147       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9148       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9149
9150       v2(1)=vaux1
9151       v2(2)=vaux2
9152       END
9153 C---------------------------------------
9154       SUBROUTINE MATMAT2(A1,A2,A3)
9155 #ifndef OSF
9156 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9157 #endif
9158       implicit real*8 (a-h,o-z)
9159       include 'DIMENSIONS'
9160       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9161 c      DIMENSION AI3(2,2)
9162 c        DO  J=1,2
9163 c          A3IJ=0.0
9164 c          DO K=1,2
9165 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9166 c          enddo
9167 c          A3(I,J)=A3IJ
9168 c       enddo
9169 c      enddo
9170
9171       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9172       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9173       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9174       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9175
9176       A3(1,1)=AI3_11
9177       A3(2,1)=AI3_21
9178       A3(1,2)=AI3_12
9179       A3(2,2)=AI3_22
9180       END
9181
9182 c-------------------------------------------------------------------------
9183       double precision function scalar2(u,v)
9184 !DIR$ INLINEALWAYS scalar2
9185       implicit none
9186       double precision u(2),v(2)
9187       double precision sc
9188       integer i
9189       scalar2=u(1)*v(1)+u(2)*v(2)
9190       return
9191       end
9192
9193 C-----------------------------------------------------------------------------
9194
9195       subroutine transpose2(a,at)
9196 !DIR$ INLINEALWAYS transpose2
9197 #ifndef OSF
9198 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9199 #endif
9200       implicit none
9201       double precision a(2,2),at(2,2)
9202       at(1,1)=a(1,1)
9203       at(1,2)=a(2,1)
9204       at(2,1)=a(1,2)
9205       at(2,2)=a(2,2)
9206       return
9207       end
9208 c--------------------------------------------------------------------------
9209       subroutine transpose(n,a,at)
9210       implicit none
9211       integer n,i,j
9212       double precision a(n,n),at(n,n)
9213       do i=1,n
9214         do j=1,n
9215           at(j,i)=a(i,j)
9216         enddo
9217       enddo
9218       return
9219       end
9220 C---------------------------------------------------------------------------
9221       subroutine prodmat3(a1,a2,kk,transp,prod)
9222 !DIR$ INLINEALWAYS prodmat3
9223 #ifndef OSF
9224 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9225 #endif
9226       implicit none
9227       integer i,j
9228       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9229       logical transp
9230 crc      double precision auxmat(2,2),prod_(2,2)
9231
9232       if (transp) then
9233 crc        call transpose2(kk(1,1),auxmat(1,1))
9234 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9235 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9236
9237            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9238      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9239            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9240      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9241            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9242      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9243            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9244      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9245
9246       else
9247 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9248 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9249
9250            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9251      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9252            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9253      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9254            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9255      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9256            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9257      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9258
9259       endif
9260 c      call transpose2(a2(1,1),a2t(1,1))
9261
9262 crc      print *,transp
9263 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9264 crc      print *,((prod(i,j),i=1,2),j=1,2)
9265
9266       return
9267       end
9268