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       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 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 c#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 c#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 c#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 c#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 #ifdef PARMAT
2270       do i=ivec_start+2,ivec_end+2
2271 #else
2272       do i=3,nres+1
2273 #endif
2274         if (i .lt. nres+1) then
2275           sin1=dsin(phi(i))
2276           cos1=dcos(phi(i))
2277           sintab(i-2)=sin1
2278           costab(i-2)=cos1
2279           obrot(1,i-2)=cos1
2280           obrot(2,i-2)=sin1
2281           sin2=dsin(2*phi(i))
2282           cos2=dcos(2*phi(i))
2283           sintab2(i-2)=sin2
2284           costab2(i-2)=cos2
2285           obrot2(1,i-2)=cos2
2286           obrot2(2,i-2)=sin2
2287           Ug(1,1,i-2)=-cos1
2288           Ug(1,2,i-2)=-sin1
2289           Ug(2,1,i-2)=-sin1
2290           Ug(2,2,i-2)= cos1
2291           Ug2(1,1,i-2)=-cos2
2292           Ug2(1,2,i-2)=-sin2
2293           Ug2(2,1,i-2)=-sin2
2294           Ug2(2,2,i-2)= cos2
2295         else
2296           costab(i-2)=1.0d0
2297           sintab(i-2)=0.0d0
2298           obrot(1,i-2)=1.0d0
2299           obrot(2,i-2)=0.0d0
2300           obrot2(1,i-2)=0.0d0
2301           obrot2(2,i-2)=0.0d0
2302           Ug(1,1,i-2)=1.0d0
2303           Ug(1,2,i-2)=0.0d0
2304           Ug(2,1,i-2)=0.0d0
2305           Ug(2,2,i-2)=1.0d0
2306           Ug2(1,1,i-2)=0.0d0
2307           Ug2(1,2,i-2)=0.0d0
2308           Ug2(2,1,i-2)=0.0d0
2309           Ug2(2,2,i-2)=0.0d0
2310         endif
2311         if (i .gt. 3 .and. i .lt. nres+1) then
2312           obrot_der(1,i-2)=-sin1
2313           obrot_der(2,i-2)= cos1
2314           Ugder(1,1,i-2)= sin1
2315           Ugder(1,2,i-2)=-cos1
2316           Ugder(2,1,i-2)=-cos1
2317           Ugder(2,2,i-2)=-sin1
2318           dwacos2=cos2+cos2
2319           dwasin2=sin2+sin2
2320           obrot2_der(1,i-2)=-dwasin2
2321           obrot2_der(2,i-2)= dwacos2
2322           Ug2der(1,1,i-2)= dwasin2
2323           Ug2der(1,2,i-2)=-dwacos2
2324           Ug2der(2,1,i-2)=-dwacos2
2325           Ug2der(2,2,i-2)=-dwasin2
2326         else
2327           obrot_der(1,i-2)=0.0d0
2328           obrot_der(2,i-2)=0.0d0
2329           Ugder(1,1,i-2)=0.0d0
2330           Ugder(1,2,i-2)=0.0d0
2331           Ugder(2,1,i-2)=0.0d0
2332           Ugder(2,2,i-2)=0.0d0
2333           obrot2_der(1,i-2)=0.0d0
2334           obrot2_der(2,i-2)=0.0d0
2335           Ug2der(1,1,i-2)=0.0d0
2336           Ug2der(1,2,i-2)=0.0d0
2337           Ug2der(2,1,i-2)=0.0d0
2338           Ug2der(2,2,i-2)=0.0d0
2339         endif
2340 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2341         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2342           iti = itortyp(itype(i-2))
2343         else
2344           iti=ntortyp+1
2345         endif
2346 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2347         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2348           iti1 = itortyp(itype(i-1))
2349         else
2350           iti1=ntortyp+1
2351         endif
2352 cd        write (iout,*) '*******i',i,' iti1',iti
2353 cd        write (iout,*) 'b1',b1(:,iti)
2354 cd        write (iout,*) 'b2',b2(:,iti)
2355 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2356 c        if (i .gt. iatel_s+2) then
2357         if (i .gt. nnt+2) then
2358           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2359           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2360           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2361      &    then
2362           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2363           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2364           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2365           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2366           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2367           endif
2368         else
2369           do k=1,2
2370             Ub2(k,i-2)=0.0d0
2371             Ctobr(k,i-2)=0.0d0
2372             Dtobr2(k,i-2)=0.0d0
2373             do l=1,2
2374               EUg(l,k,i-2)=0.0d0
2375               CUg(l,k,i-2)=0.0d0
2376               DUg(l,k,i-2)=0.0d0
2377               DtUg2(l,k,i-2)=0.0d0
2378             enddo
2379           enddo
2380         endif
2381         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2382         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2383         do k=1,2
2384           muder(k,i-2)=Ub2der(k,i-2)
2385         enddo
2386 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2387         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2388           if (itype(i-1).le.ntyp) then
2389             iti1 = itortyp(itype(i-1))
2390           else
2391             iti1=ntortyp+1
2392           endif
2393         else
2394           iti1=ntortyp+1
2395         endif
2396         do k=1,2
2397           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2398         enddo
2399 cd        write (iout,*) 'mu ',mu(:,i-2)
2400 cd        write (iout,*) 'mu1',mu1(:,i-2)
2401 cd        write (iout,*) 'mu2',mu2(:,i-2)
2402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2403      &  then
2404         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2405         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2406         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2407         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2408         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2409 C Vectors and matrices dependent on a single virtual-bond dihedral.
2410         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2411         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2412         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2413         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2414         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2415         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2416         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2417         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2418         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2419         endif
2420       enddo
2421 C Matrices dependent on two consecutive virtual-bond dihedrals.
2422 C The order of matrices is from left to right.
2423       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2424      &then
2425 c      do i=max0(ivec_start,2),ivec_end
2426       do i=2,nres-1
2427         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2428         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2429         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2430         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2431         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2432         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2433         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2434         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2435       enddo
2436       endif
2437 #if defined(MPI) && defined(PARMAT)
2438 #ifdef DEBUG
2439 c      if (fg_rank.eq.0) then
2440         write (iout,*) "Arrays UG and UGDER before GATHER"
2441         do i=1,nres-1
2442           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2443      &     ((ug(l,k,i),l=1,2),k=1,2),
2444      &     ((ugder(l,k,i),l=1,2),k=1,2)
2445         enddo
2446         write (iout,*) "Arrays UG2 and UG2DER"
2447         do i=1,nres-1
2448           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2449      &     ((ug2(l,k,i),l=1,2),k=1,2),
2450      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2451         enddo
2452         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2453         do i=1,nres-1
2454           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2455      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2456      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2457         enddo
2458         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2459         do i=1,nres-1
2460           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2461      &     costab(i),sintab(i),costab2(i),sintab2(i)
2462         enddo
2463         write (iout,*) "Array MUDER"
2464         do i=1,nres-1
2465           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2466         enddo
2467 c      endif
2468 #endif
2469       if (nfgtasks.gt.1) then
2470         time00=MPI_Wtime()
2471 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2472 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2473 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2474 #ifdef MATGATHER
2475         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2476      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2477      &   FG_COMM1,IERR)
2478         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2494      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2495      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2496         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2497      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2498      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2499         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2500      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2501      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2502         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2503      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2504      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2505         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2506      &  then
2507         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2523      &   ivec_count(fg_rank1),
2524      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2525      &   FG_COMM1,IERR)
2526         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2527      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2530      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2531      &   FG_COMM1,IERR)
2532         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2533      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2537      &   FG_COMM1,IERR)
2538         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2548      &   ivec_count(fg_rank1),
2549      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2553      &   FG_COMM1,IERR)
2554        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2559      &   FG_COMM1,IERR)
2560        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2564      &   ivec_count(fg_rank1),
2565      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2568      &   ivec_count(fg_rank1),
2569      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2572      &   ivec_count(fg_rank1),
2573      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2574      &   MPI_MAT2,FG_COMM1,IERR)
2575         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2576      &   ivec_count(fg_rank1),
2577      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2578      &   MPI_MAT2,FG_COMM1,IERR)
2579         endif
2580 #else
2581 c Passes matrix info through the ring
2582       isend=fg_rank1
2583       irecv=fg_rank1-1
2584       if (irecv.lt.0) irecv=nfgtasks1-1
2585       iprev=irecv
2586       inext=fg_rank1+1
2587       if (inext.ge.nfgtasks1) inext=0
2588       do i=1,nfgtasks1-1
2589 c        write (iout,*) "isend",isend," irecv",irecv
2590 c        call flush(iout)
2591         lensend=lentyp(isend)
2592         lenrecv=lentyp(irecv)
2593 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2594 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2595 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2596 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2597 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2598 c        write (iout,*) "Gather ROTAT1"
2599 c        call flush(iout)
2600 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2601 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2602 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2603 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2604 c        write (iout,*) "Gather ROTAT2"
2605 c        call flush(iout)
2606         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2607      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2608      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2609      &   iprev,4400+irecv,FG_COMM,status,IERR)
2610 c        write (iout,*) "Gather ROTAT_OLD"
2611 c        call flush(iout)
2612         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2613      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2614      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2615      &   iprev,5500+irecv,FG_COMM,status,IERR)
2616 c        write (iout,*) "Gather PRECOMP11"
2617 c        call flush(iout)
2618         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2619      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2620      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2621      &   iprev,6600+irecv,FG_COMM,status,IERR)
2622 c        write (iout,*) "Gather PRECOMP12"
2623 c        call flush(iout)
2624         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2625      &  then
2626         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2627      &   MPI_ROTAT2(lensend),inext,7700+isend,
2628      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2629      &   iprev,7700+irecv,FG_COMM,status,IERR)
2630 c        write (iout,*) "Gather PRECOMP21"
2631 c        call flush(iout)
2632         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2633      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2634      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2635      &   iprev,8800+irecv,FG_COMM,status,IERR)
2636 c        write (iout,*) "Gather PRECOMP22"
2637 c        call flush(iout)
2638         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2639      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2640      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2641      &   MPI_PRECOMP23(lenrecv),
2642      &   iprev,9900+irecv,FG_COMM,status,IERR)
2643 c        write (iout,*) "Gather PRECOMP23"
2644 c        call flush(iout)
2645         endif
2646         isend=irecv
2647         irecv=irecv-1
2648         if (irecv.lt.0) irecv=nfgtasks1-1
2649       enddo
2650 #endif
2651         time_gather=time_gather+MPI_Wtime()-time00
2652       endif
2653 #ifdef DEBUG
2654 c      if (fg_rank.eq.0) then
2655         write (iout,*) "Arrays UG and UGDER"
2656         do i=1,nres-1
2657           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2658      &     ((ug(l,k,i),l=1,2),k=1,2),
2659      &     ((ugder(l,k,i),l=1,2),k=1,2)
2660         enddo
2661         write (iout,*) "Arrays UG2 and UG2DER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug2(l,k,i),l=1,2),k=1,2),
2665      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2671      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     costab(i),sintab(i),costab2(i),sintab2(i)
2677         enddo
2678         write (iout,*) "Array MUDER"
2679         do i=1,nres-1
2680           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2681         enddo
2682 c      endif
2683 #endif
2684 #endif
2685 cd      do i=1,nres
2686 cd        iti = itortyp(itype(i))
2687 cd        write (iout,*) i
2688 cd        do j=1,2
2689 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2690 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2691 cd        enddo
2692 cd      enddo
2693       return
2694       end
2695 C--------------------------------------------------------------------------
2696       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2697 C
2698 C This subroutine calculates the average interaction energy and its gradient
2699 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2700 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2701 C The potential depends both on the distance of peptide-group centers and on
2702 C the orientation of the CA-CA virtual bonds.
2703 C
2704       implicit real*8 (a-h,o-z)
2705 #ifdef MPI
2706       include 'mpif.h'
2707 #endif
2708       include 'DIMENSIONS'
2709       include 'COMMON.CONTROL'
2710       include 'COMMON.SETUP'
2711       include 'COMMON.IOUNITS'
2712       include 'COMMON.GEO'
2713       include 'COMMON.VAR'
2714       include 'COMMON.LOCAL'
2715       include 'COMMON.CHAIN'
2716       include 'COMMON.DERIV'
2717       include 'COMMON.INTERACT'
2718       include 'COMMON.CONTACTS'
2719       include 'COMMON.TORSION'
2720       include 'COMMON.VECTORS'
2721       include 'COMMON.FFIELD'
2722       include 'COMMON.TIME1'
2723       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2724      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2725       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2726      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2727       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2728      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2729      &    num_conti,j1,j2
2730 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2731 #ifdef MOMENT
2732       double precision scal_el /1.0d0/
2733 #else
2734       double precision scal_el /0.5d0/
2735 #endif
2736 C 12/13/98
2737 C 13-go grudnia roku pamietnego...
2738       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2739      &                   0.0d0,1.0d0,0.0d0,
2740      &                   0.0d0,0.0d0,1.0d0/
2741 cd      write(iout,*) 'In EELEC'
2742 cd      do i=1,nloctyp
2743 cd        write(iout,*) 'Type',i
2744 cd        write(iout,*) 'B1',B1(:,i)
2745 cd        write(iout,*) 'B2',B2(:,i)
2746 cd        write(iout,*) 'CC',CC(:,:,i)
2747 cd        write(iout,*) 'DD',DD(:,:,i)
2748 cd        write(iout,*) 'EE',EE(:,:,i)
2749 cd      enddo
2750 cd      call check_vecgrad
2751 cd      stop
2752       if (icheckgrad.eq.1) then
2753         do i=1,nres-1
2754           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2755           do k=1,3
2756             dc_norm(k,i)=dc(k,i)*fac
2757           enddo
2758 c          write (iout,*) 'i',i,' fac',fac
2759         enddo
2760       endif
2761       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2762      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2763      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2764 c        call vec_and_deriv
2765 #ifdef TIMING
2766         time01=MPI_Wtime()
2767 #endif
2768         call set_matrices
2769 #ifdef TIMING
2770         time_mat=time_mat+MPI_Wtime()-time01
2771 #endif
2772       endif
2773 cd      do i=1,nres-1
2774 cd        write (iout,*) 'i=',i
2775 cd        do k=1,3
2776 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 cd        enddo
2778 cd        do k=1,3
2779 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 cd        enddo
2782 cd      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789       ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 cd      print '(a)','Enter EELEC'
2794 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795       do i=1,nres
2796         gel_loc_loc(i)=0.0d0
2797         gcorr_loc(i)=0.0d0
2798       enddo
2799 c
2800 c
2801 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2802 C
2803 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2804 C
2805       do i=iturn3_start,iturn3_end
2806         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2807      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2808         dxi=dc(1,i)
2809         dyi=dc(2,i)
2810         dzi=dc(3,i)
2811         dx_normi=dc_norm(1,i)
2812         dy_normi=dc_norm(2,i)
2813         dz_normi=dc_norm(3,i)
2814         xmedi=c(1,i)+0.5d0*dxi
2815         ymedi=c(2,i)+0.5d0*dyi
2816         zmedi=c(3,i)+0.5d0*dzi
2817         num_conti=0
2818         call eelecij(i,i+2,ees,evdw1,eel_loc)
2819         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2820         num_cont_hb(i)=num_conti
2821       enddo
2822       do i=iturn4_start,iturn4_end
2823         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2824      &    .or. itype(i+3).eq.ntyp1
2825      &    .or. itype(i+4).eq.ntyp1) cycle
2826         dxi=dc(1,i)
2827         dyi=dc(2,i)
2828         dzi=dc(3,i)
2829         dx_normi=dc_norm(1,i)
2830         dy_normi=dc_norm(2,i)
2831         dz_normi=dc_norm(3,i)
2832         xmedi=c(1,i)+0.5d0*dxi
2833         ymedi=c(2,i)+0.5d0*dyi
2834         zmedi=c(3,i)+0.5d0*dzi
2835         num_conti=num_cont_hb(i)
2836         call eelecij(i,i+3,ees,evdw1,eel_loc)
2837         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2838      &   call eturn4(i,eello_turn4)
2839         num_cont_hb(i)=num_conti
2840       enddo   ! i
2841 c
2842 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2843 c
2844       do i=iatel_s,iatel_e
2845         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2846         dxi=dc(1,i)
2847         dyi=dc(2,i)
2848         dzi=dc(3,i)
2849         dx_normi=dc_norm(1,i)
2850         dy_normi=dc_norm(2,i)
2851         dz_normi=dc_norm(3,i)
2852         xmedi=c(1,i)+0.5d0*dxi
2853         ymedi=c(2,i)+0.5d0*dyi
2854         zmedi=c(3,i)+0.5d0*dzi
2855 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2856         num_conti=num_cont_hb(i)
2857         do j=ielstart(i),ielend(i)
2858 c          write (iout,*) i,j,itype(i),itype(j)
2859           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2860           call eelecij(i,j,ees,evdw1,eel_loc)
2861         enddo ! j
2862         num_cont_hb(i)=num_conti
2863       enddo   ! i
2864 c      write (iout,*) "Number of loop steps in EELEC:",ind
2865 cd      do i=1,nres
2866 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2867 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2868 cd      enddo
2869 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2870 ccc      eel_loc=eel_loc+eello_turn3
2871 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2872       return
2873       end
2874 C-------------------------------------------------------------------------------
2875       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2876       implicit real*8 (a-h,o-z)
2877       include 'DIMENSIONS'
2878 #ifdef MPI
2879       include "mpif.h"
2880 #endif
2881       include 'COMMON.CONTROL'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890       include 'COMMON.TORSION'
2891       include 'COMMON.VECTORS'
2892       include 'COMMON.FFIELD'
2893       include 'COMMON.TIME1'
2894       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2895      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2896       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2897      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2898       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2899      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2900      &    num_conti,j1,j2
2901 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2902 #ifdef MOMENT
2903       double precision scal_el /1.0d0/
2904 #else
2905       double precision scal_el /0.5d0/
2906 #endif
2907 C 12/13/98
2908 C 13-go grudnia roku pamietnego...
2909       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2910      &                   0.0d0,1.0d0,0.0d0,
2911      &                   0.0d0,0.0d0,1.0d0/
2912 c          time00=MPI_Wtime()
2913 cd      write (iout,*) "eelecij",i,j
2914 c          ind=ind+1
2915           iteli=itel(i)
2916           itelj=itel(j)
2917           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2918           aaa=app(iteli,itelj)
2919           bbb=bpp(iteli,itelj)
2920           ael6i=ael6(iteli,itelj)
2921           ael3i=ael3(iteli,itelj)
2922           dxj=dc(1,j)
2923           dyj=dc(2,j)
2924           dzj=dc(3,j)
2925           dx_normj=dc_norm(1,j)
2926           dy_normj=dc_norm(2,j)
2927           dz_normj=dc_norm(3,j)
2928           xj=c(1,j)+0.5D0*dxj-xmedi
2929           yj=c(2,j)+0.5D0*dyj-ymedi
2930           zj=c(3,j)+0.5D0*dzj-zmedi
2931           rij=xj*xj+yj*yj+zj*zj
2932           rrmij=1.0D0/rij
2933           rij=dsqrt(rij)
2934           rmij=1.0D0/rij
2935           r3ij=rrmij*rmij
2936           r6ij=r3ij*r3ij
2937           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2938           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2939           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2940           fac=cosa-3.0D0*cosb*cosg
2941           ev1=aaa*r6ij*r6ij
2942 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2943           if (j.eq.i+2) ev1=scal_el*ev1
2944           ev2=bbb*r6ij
2945           fac3=ael6i*r6ij
2946           fac4=ael3i*r3ij
2947           evdwij=ev1+ev2
2948           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2949           el2=fac4*fac
2950           eesij=el1+el2
2951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2953           ees=ees+eesij
2954           evdw1=evdw1+evdwij
2955 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2956 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2957 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2958 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2959
2960           if (energy_dec) then
2961               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2962      &'evdw1',i,j,evdwij
2963      &,iteli,itelj,aaa,evdw1
2964               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2965           endif
2966
2967 C
2968 C Calculate contributions to the Cartesian gradient.
2969 C
2970 #ifdef SPLITELE
2971           facvdw=-6*rrmij*(ev1+evdwij)
2972           facel=-3*rrmij*(el1+eesij)
2973           fac1=fac
2974           erij(1)=xj*rmij
2975           erij(2)=yj*rmij
2976           erij(3)=zj*rmij
2977 *
2978 * Radial derivatives. First process both termini of the fragment (i,j)
2979 *
2980           ggg(1)=facel*xj
2981           ggg(2)=facel*yj
2982           ggg(3)=facel*zj
2983 c          do k=1,3
2984 c            ghalf=0.5D0*ggg(k)
2985 c            gelc(k,i)=gelc(k,i)+ghalf
2986 c            gelc(k,j)=gelc(k,j)+ghalf
2987 c          enddo
2988 c 9/28/08 AL Gradient compotents will be summed only at the end
2989           do k=1,3
2990             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2991             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2992           enddo
2993 *
2994 * Loop over residues i+1 thru j-1.
2995 *
2996 cgrad          do k=i+1,j-1
2997 cgrad            do l=1,3
2998 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2999 cgrad            enddo
3000 cgrad          enddo
3001           ggg(1)=facvdw*xj
3002           ggg(2)=facvdw*yj
3003           ggg(3)=facvdw*zj
3004 c          do k=1,3
3005 c            ghalf=0.5D0*ggg(k)
3006 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3007 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3008 c          enddo
3009 c 9/28/08 AL Gradient compotents will be summed only at the end
3010           do k=1,3
3011             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3012             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3013           enddo
3014 *
3015 * Loop over residues i+1 thru j-1.
3016 *
3017 cgrad          do k=i+1,j-1
3018 cgrad            do l=1,3
3019 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3020 cgrad            enddo
3021 cgrad          enddo
3022 #else
3023           facvdw=ev1+evdwij
3024           facel=el1+eesij
3025           fac1=fac
3026           fac=-3*rrmij*(facvdw+facvdw+facel)
3027           erij(1)=xj*rmij
3028           erij(2)=yj*rmij
3029           erij(3)=zj*rmij
3030 *
3031 * Radial derivatives. First process both termini of the fragment (i,j)
3032 *
3033           ggg(1)=fac*xj
3034           ggg(2)=fac*yj
3035           ggg(3)=fac*zj
3036 c          do k=1,3
3037 c            ghalf=0.5D0*ggg(k)
3038 c            gelc(k,i)=gelc(k,i)+ghalf
3039 c            gelc(k,j)=gelc(k,j)+ghalf
3040 c          enddo
3041 c 9/28/08 AL Gradient compotents will be summed only at the end
3042           do k=1,3
3043             gelc_long(k,j)=gelc(k,j)+ggg(k)
3044             gelc_long(k,i)=gelc(k,i)-ggg(k)
3045           enddo
3046 *
3047 * Loop over residues i+1 thru j-1.
3048 *
3049 cgrad          do k=i+1,j-1
3050 cgrad            do l=1,3
3051 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3052 cgrad            enddo
3053 cgrad          enddo
3054 c 9/28/08 AL Gradient compotents will be summed only at the end
3055           ggg(1)=facvdw*xj
3056           ggg(2)=facvdw*yj
3057           ggg(3)=facvdw*zj
3058           do k=1,3
3059             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3060             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3061           enddo
3062 #endif
3063 *
3064 * Angular part
3065 *
3066           ecosa=2.0D0*fac3*fac1+fac4
3067           fac4=-3.0D0*fac4
3068           fac3=-6.0D0*fac3
3069           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3070           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3071           do k=1,3
3072             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3073             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3074           enddo
3075 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3076 cd   &          (dcosg(k),k=1,3)
3077           do k=1,3
3078             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3079           enddo
3080 c          do k=1,3
3081 c            ghalf=0.5D0*ggg(k)
3082 c            gelc(k,i)=gelc(k,i)+ghalf
3083 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3084 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3085 c            gelc(k,j)=gelc(k,j)+ghalf
3086 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3087 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3088 c          enddo
3089 cgrad          do k=i+1,j-1
3090 cgrad            do l=1,3
3091 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3092 cgrad            enddo
3093 cgrad          enddo
3094           do k=1,3
3095             gelc(k,i)=gelc(k,i)
3096      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3097      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3098             gelc(k,j)=gelc(k,j)
3099      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3100      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3101             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3102             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3103           enddo
3104           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3105      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3106      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3107 C
3108 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3109 C   energy of a peptide unit is assumed in the form of a second-order
3110 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3111 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3112 C   are computed for EVERY pair of non-contiguous peptide groups.
3113 C
3114           if (j.lt.nres-1) then
3115             j1=j+1
3116             j2=j-1
3117           else
3118             j1=j-1
3119             j2=j-2
3120           endif
3121           kkk=0
3122           do k=1,2
3123             do l=1,2
3124               kkk=kkk+1
3125               muij(kkk)=mu(k,i)*mu(l,j)
3126             enddo
3127           enddo
3128 cd         write (iout,*) 'EELEC: i',i,' j',j
3129 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3130 cd          write(iout,*) 'muij',muij
3131           ury=scalar(uy(1,i),erij)
3132           urz=scalar(uz(1,i),erij)
3133           vry=scalar(uy(1,j),erij)
3134           vrz=scalar(uz(1,j),erij)
3135           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3136           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3137           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3138           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3139           fac=dsqrt(-ael6i)*r3ij
3140           a22=a22*fac
3141           a23=a23*fac
3142           a32=a32*fac
3143           a33=a33*fac
3144 cd          write (iout,'(4i5,4f10.5)')
3145 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3146 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3147 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3148 cd     &      uy(:,j),uz(:,j)
3149 cd          write (iout,'(4f10.5)')
3150 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3151 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3152 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3153 cd           write (iout,'(9f10.5/)')
3154 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3155 C Derivatives of the elements of A in virtual-bond vectors
3156           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3157           do k=1,3
3158             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3159             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3160             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3161             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3162             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3163             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3164             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3165             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3166             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3167             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3168             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3169             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3170           enddo
3171 C Compute radial contributions to the gradient
3172           facr=-3.0d0*rrmij
3173           a22der=a22*facr
3174           a23der=a23*facr
3175           a32der=a32*facr
3176           a33der=a33*facr
3177           agg(1,1)=a22der*xj
3178           agg(2,1)=a22der*yj
3179           agg(3,1)=a22der*zj
3180           agg(1,2)=a23der*xj
3181           agg(2,2)=a23der*yj
3182           agg(3,2)=a23der*zj
3183           agg(1,3)=a32der*xj
3184           agg(2,3)=a32der*yj
3185           agg(3,3)=a32der*zj
3186           agg(1,4)=a33der*xj
3187           agg(2,4)=a33der*yj
3188           agg(3,4)=a33der*zj
3189 C Add the contributions coming from er
3190           fac3=-3.0d0*fac
3191           do k=1,3
3192             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3193             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3194             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3195             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3196           enddo
3197           do k=1,3
3198 C Derivatives in DC(i)
3199 cgrad            ghalf1=0.5d0*agg(k,1)
3200 cgrad            ghalf2=0.5d0*agg(k,2)
3201 cgrad            ghalf3=0.5d0*agg(k,3)
3202 cgrad            ghalf4=0.5d0*agg(k,4)
3203             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3204      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3205             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3206      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3207             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3208      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3209             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3210      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3211 C Derivatives in DC(i+1)
3212             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3213      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3214             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3215      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3216             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3217      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3218             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3219      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3220 C Derivatives in DC(j)
3221             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3222      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3223             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3224      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3225             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3226      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3227             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3228      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3229 C Derivatives in DC(j+1) or DC(nres-1)
3230             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3231      &      -3.0d0*vryg(k,3)*ury)
3232             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3233      &      -3.0d0*vrzg(k,3)*ury)
3234             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3235      &      -3.0d0*vryg(k,3)*urz)
3236             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3237      &      -3.0d0*vrzg(k,3)*urz)
3238 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3239 cgrad              do l=1,4
3240 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3241 cgrad              enddo
3242 cgrad            endif
3243           enddo
3244           acipa(1,1)=a22
3245           acipa(1,2)=a23
3246           acipa(2,1)=a32
3247           acipa(2,2)=a33
3248           a22=-a22
3249           a23=-a23
3250           do l=1,2
3251             do k=1,3
3252               agg(k,l)=-agg(k,l)
3253               aggi(k,l)=-aggi(k,l)
3254               aggi1(k,l)=-aggi1(k,l)
3255               aggj(k,l)=-aggj(k,l)
3256               aggj1(k,l)=-aggj1(k,l)
3257             enddo
3258           enddo
3259           if (j.lt.nres-1) then
3260             a22=-a22
3261             a32=-a32
3262             do l=1,3,2
3263               do k=1,3
3264                 agg(k,l)=-agg(k,l)
3265                 aggi(k,l)=-aggi(k,l)
3266                 aggi1(k,l)=-aggi1(k,l)
3267                 aggj(k,l)=-aggj(k,l)
3268                 aggj1(k,l)=-aggj1(k,l)
3269               enddo
3270             enddo
3271           else
3272             a22=-a22
3273             a23=-a23
3274             a32=-a32
3275             a33=-a33
3276             do l=1,4
3277               do k=1,3
3278                 agg(k,l)=-agg(k,l)
3279                 aggi(k,l)=-aggi(k,l)
3280                 aggi1(k,l)=-aggi1(k,l)
3281                 aggj(k,l)=-aggj(k,l)
3282                 aggj1(k,l)=-aggj1(k,l)
3283               enddo
3284             enddo
3285           endif
3286           ENDIF ! WCORR
3287           IF (wel_loc.gt.0.0d0) THEN
3288 C Contribution to the local-electrostatic energy coming from the i-j pair
3289           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3290      &     +a33*muij(4)
3291 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3292
3293           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3294      &            'eelloc',i,j,eel_loc_ij
3295 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3296
3297           eel_loc=eel_loc+eel_loc_ij
3298 C Partial derivatives in virtual-bond dihedral angles gamma
3299           if (i.gt.1)
3300      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3301      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3302      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3303           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3304      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3305      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3306 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3307           do l=1,3
3308             ggg(l)=agg(l,1)*muij(1)+
3309      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3310             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3311             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3312 cgrad            ghalf=0.5d0*ggg(l)
3313 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3314 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3315           enddo
3316 cgrad          do k=i+1,j2
3317 cgrad            do l=1,3
3318 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3319 cgrad            enddo
3320 cgrad          enddo
3321 C Remaining derivatives of eello
3322           do l=1,3
3323             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3324      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3325             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3326      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3327             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3328      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3329             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3330      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3331           enddo
3332           ENDIF
3333 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3334 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3335           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3336      &       .and. num_conti.le.maxconts) then
3337 c            write (iout,*) i,j," entered corr"
3338 C
3339 C Calculate the contact function. The ith column of the array JCONT will
3340 C contain the numbers of atoms that make contacts with the atom I (of numbers
3341 C greater than I). The arrays FACONT and GACONT will contain the values of
3342 C the contact function and its derivative.
3343 c           r0ij=1.02D0*rpp(iteli,itelj)
3344 c           r0ij=1.11D0*rpp(iteli,itelj)
3345             r0ij=2.20D0*rpp(iteli,itelj)
3346 c           r0ij=1.55D0*rpp(iteli,itelj)
3347             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3348             if (fcont.gt.0.0D0) then
3349               num_conti=num_conti+1
3350               if (num_conti.gt.maxconts) then
3351                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3352      &                         ' will skip next contacts for this conf.'
3353               else
3354                 jcont_hb(num_conti,i)=j
3355 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3356 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3357                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3358      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3359 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3360 C  terms.
3361                 d_cont(num_conti,i)=rij
3362 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3363 C     --- Electrostatic-interaction matrix ---
3364                 a_chuj(1,1,num_conti,i)=a22
3365                 a_chuj(1,2,num_conti,i)=a23
3366                 a_chuj(2,1,num_conti,i)=a32
3367                 a_chuj(2,2,num_conti,i)=a33
3368 C     --- Gradient of rij
3369                 do kkk=1,3
3370                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3371                 enddo
3372                 kkll=0
3373                 do k=1,2
3374                   do l=1,2
3375                     kkll=kkll+1
3376                     do m=1,3
3377                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3378                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3379                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3380                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3381                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3382                     enddo
3383                   enddo
3384                 enddo
3385                 ENDIF
3386                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3387 C Calculate contact energies
3388                 cosa4=4.0D0*cosa
3389                 wij=cosa-3.0D0*cosb*cosg
3390                 cosbg1=cosb+cosg
3391                 cosbg2=cosb-cosg
3392 c               fac3=dsqrt(-ael6i)/r0ij**3
3393                 fac3=dsqrt(-ael6i)*r3ij
3394 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3395                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3396                 if (ees0tmp.gt.0) then
3397                   ees0pij=dsqrt(ees0tmp)
3398                 else
3399                   ees0pij=0
3400                 endif
3401 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3402                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3403                 if (ees0tmp.gt.0) then
3404                   ees0mij=dsqrt(ees0tmp)
3405                 else
3406                   ees0mij=0
3407                 endif
3408 c               ees0mij=0.0D0
3409                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3410                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3411 C Diagnostics. Comment out or remove after debugging!
3412 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3413 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3414 c               ees0m(num_conti,i)=0.0D0
3415 C End diagnostics.
3416 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3417 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3418 C Angular derivatives of the contact function
3419                 ees0pij1=fac3/ees0pij
3420                 ees0mij1=fac3/ees0mij
3421                 fac3p=-3.0D0*fac3*rrmij
3422                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3423                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3424 c               ees0mij1=0.0D0
3425                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3426                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3427                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3428                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3429                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3430                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3431                 ecosap=ecosa1+ecosa2
3432                 ecosbp=ecosb1+ecosb2
3433                 ecosgp=ecosg1+ecosg2
3434                 ecosam=ecosa1-ecosa2
3435                 ecosbm=ecosb1-ecosb2
3436                 ecosgm=ecosg1-ecosg2
3437 C Diagnostics
3438 c               ecosap=ecosa1
3439 c               ecosbp=ecosb1
3440 c               ecosgp=ecosg1
3441 c               ecosam=0.0D0
3442 c               ecosbm=0.0D0
3443 c               ecosgm=0.0D0
3444 C End diagnostics
3445                 facont_hb(num_conti,i)=fcont
3446                 fprimcont=fprimcont/rij
3447 cd              facont_hb(num_conti,i)=1.0D0
3448 C Following line is for diagnostics.
3449 cd              fprimcont=0.0D0
3450                 do k=1,3
3451                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3452                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3453                 enddo
3454                 do k=1,3
3455                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3456                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3457                 enddo
3458                 gggp(1)=gggp(1)+ees0pijp*xj
3459                 gggp(2)=gggp(2)+ees0pijp*yj
3460                 gggp(3)=gggp(3)+ees0pijp*zj
3461                 gggm(1)=gggm(1)+ees0mijp*xj
3462                 gggm(2)=gggm(2)+ees0mijp*yj
3463                 gggm(3)=gggm(3)+ees0mijp*zj
3464 C Derivatives due to the contact function
3465                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3466                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3467                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3468                 do k=1,3
3469 c
3470 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3471 c          following the change of gradient-summation algorithm.
3472 c
3473 cgrad                  ghalfp=0.5D0*gggp(k)
3474 cgrad                  ghalfm=0.5D0*gggm(k)
3475                   gacontp_hb1(k,num_conti,i)=!ghalfp
3476      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3477      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3478                   gacontp_hb2(k,num_conti,i)=!ghalfp
3479      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3480      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3481                   gacontp_hb3(k,num_conti,i)=gggp(k)
3482                   gacontm_hb1(k,num_conti,i)=!ghalfm
3483      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3484      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3485                   gacontm_hb2(k,num_conti,i)=!ghalfm
3486      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3487      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3488                   gacontm_hb3(k,num_conti,i)=gggm(k)
3489                 enddo
3490 C Diagnostics. Comment out or remove after debugging!
3491 cdiag           do k=1,3
3492 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3493 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3494 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3495 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3496 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3497 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3498 cdiag           enddo
3499               ENDIF ! wcorr
3500               endif  ! num_conti.le.maxconts
3501             endif  ! fcont.gt.0
3502           endif    ! j.gt.i+1
3503           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3504             do k=1,4
3505               do l=1,3
3506                 ghalf=0.5d0*agg(l,k)
3507                 aggi(l,k)=aggi(l,k)+ghalf
3508                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3509                 aggj(l,k)=aggj(l,k)+ghalf
3510               enddo
3511             enddo
3512             if (j.eq.nres-1 .and. i.lt.j-2) then
3513               do k=1,4
3514                 do l=1,3
3515                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3516                 enddo
3517               enddo
3518             endif
3519           endif
3520 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3521       return
3522       end
3523 C-----------------------------------------------------------------------------
3524       subroutine eturn3(i,eello_turn3)
3525 C Third- and fourth-order contributions from turns
3526       implicit real*8 (a-h,o-z)
3527       include 'DIMENSIONS'
3528       include 'COMMON.IOUNITS'
3529       include 'COMMON.GEO'
3530       include 'COMMON.VAR'
3531       include 'COMMON.LOCAL'
3532       include 'COMMON.CHAIN'
3533       include 'COMMON.DERIV'
3534       include 'COMMON.INTERACT'
3535       include 'COMMON.CONTACTS'
3536       include 'COMMON.TORSION'
3537       include 'COMMON.VECTORS'
3538       include 'COMMON.FFIELD'
3539       include 'COMMON.CONTROL'
3540       dimension ggg(3)
3541       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3542      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3543      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3544       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3545      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3546       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3547      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3548      &    num_conti,j1,j2
3549       j=i+2
3550 c      write (iout,*) "eturn3",i,j,j1,j2
3551       a_temp(1,1)=a22
3552       a_temp(1,2)=a23
3553       a_temp(2,1)=a32
3554       a_temp(2,2)=a33
3555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3556 C
3557 C               Third-order contributions
3558 C
3559 C                 (i+2)o----(i+3)
3560 C                      | |
3561 C                      | |
3562 C                 (i+1)o----i
3563 C
3564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3565 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3566         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3567         call transpose2(auxmat(1,1),auxmat1(1,1))
3568         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3569         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3570         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3571      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3572 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3573 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3574 cd     &    ' eello_turn3_num',4*eello_turn3_num
3575 C Derivatives in gamma(i)
3576         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3577         call transpose2(auxmat2(1,1),auxmat3(1,1))
3578         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3579         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3580 C Derivatives in gamma(i+1)
3581         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3582         call transpose2(auxmat2(1,1),auxmat3(1,1))
3583         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3584         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3585      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3586 C Cartesian derivatives
3587         do l=1,3
3588 c            ghalf1=0.5d0*agg(l,1)
3589 c            ghalf2=0.5d0*agg(l,2)
3590 c            ghalf3=0.5d0*agg(l,3)
3591 c            ghalf4=0.5d0*agg(l,4)
3592           a_temp(1,1)=aggi(l,1)!+ghalf1
3593           a_temp(1,2)=aggi(l,2)!+ghalf2
3594           a_temp(2,1)=aggi(l,3)!+ghalf3
3595           a_temp(2,2)=aggi(l,4)!+ghalf4
3596           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3597           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3598      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3599           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3600           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3601           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3602           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3603           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3604           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3605      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3606           a_temp(1,1)=aggj(l,1)!+ghalf1
3607           a_temp(1,2)=aggj(l,2)!+ghalf2
3608           a_temp(2,1)=aggj(l,3)!+ghalf3
3609           a_temp(2,2)=aggj(l,4)!+ghalf4
3610           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3611           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3612      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3613           a_temp(1,1)=aggj1(l,1)
3614           a_temp(1,2)=aggj1(l,2)
3615           a_temp(2,1)=aggj1(l,3)
3616           a_temp(2,2)=aggj1(l,4)
3617           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3618           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3619      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3620         enddo
3621       return
3622       end
3623 C-------------------------------------------------------------------------------
3624       subroutine eturn4(i,eello_turn4)
3625 C Third- and fourth-order contributions from turns
3626       implicit real*8 (a-h,o-z)
3627       include 'DIMENSIONS'
3628       include 'COMMON.IOUNITS'
3629       include 'COMMON.GEO'
3630       include 'COMMON.VAR'
3631       include 'COMMON.LOCAL'
3632       include 'COMMON.CHAIN'
3633       include 'COMMON.DERIV'
3634       include 'COMMON.INTERACT'
3635       include 'COMMON.CONTACTS'
3636       include 'COMMON.TORSION'
3637       include 'COMMON.VECTORS'
3638       include 'COMMON.FFIELD'
3639       include 'COMMON.CONTROL'
3640       dimension ggg(3)
3641       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3642      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3643      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3644       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3645      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3646       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3647      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3648      &    num_conti,j1,j2
3649       j=i+3
3650 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3651 C
3652 C               Fourth-order contributions
3653 C
3654 C                 (i+3)o----(i+4)
3655 C                     /  |
3656 C               (i+2)o   |
3657 C                     \  |
3658 C                 (i+1)o----i
3659 C
3660 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3661 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3662 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3663         a_temp(1,1)=a22
3664         a_temp(1,2)=a23
3665         a_temp(2,1)=a32
3666         a_temp(2,2)=a33
3667         iti1=itortyp(itype(i+1))
3668         iti2=itortyp(itype(i+2))
3669         iti3=itortyp(itype(i+3))
3670 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3671         call transpose2(EUg(1,1,i+1),e1t(1,1))
3672         call transpose2(Eug(1,1,i+2),e2t(1,1))
3673         call transpose2(Eug(1,1,i+3),e3t(1,1))
3674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3676         s1=scalar2(b1(1,iti2),auxvec(1))
3677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3679         s2=scalar2(b1(1,iti1),auxvec(1))
3680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3683         eello_turn4=eello_turn4-(s1+s2+s3)
3684         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3685      &      'eturn4',i,j,-(s1+s2+s3)
3686 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3687 cd     &    ' eello_turn4_num',8*eello_turn4_num
3688 C Derivatives in gamma(i)
3689         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3690         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3691         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3692         s1=scalar2(b1(1,iti2),auxvec(1))
3693         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3696 C Derivatives in gamma(i+1)
3697         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3698         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3699         s2=scalar2(b1(1,iti1),auxvec(1))
3700         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3701         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3702         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3703         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3704 C Derivatives in gamma(i+2)
3705         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3706         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3707         s1=scalar2(b1(1,iti2),auxvec(1))
3708         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3709         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3710         s2=scalar2(b1(1,iti1),auxvec(1))
3711         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3712         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3715 C Cartesian derivatives
3716 C Derivatives of this turn contributions in DC(i+2)
3717         if (j.lt.nres-1) then
3718           do l=1,3
3719             a_temp(1,1)=agg(l,1)
3720             a_temp(1,2)=agg(l,2)
3721             a_temp(2,1)=agg(l,3)
3722             a_temp(2,2)=agg(l,4)
3723             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3724             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3725             s1=scalar2(b1(1,iti2),auxvec(1))
3726             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3727             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3728             s2=scalar2(b1(1,iti1),auxvec(1))
3729             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3730             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3731             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732             ggg(l)=-(s1+s2+s3)
3733             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3734           enddo
3735         endif
3736 C Remaining derivatives of this turn contribution
3737         do l=1,3
3738           a_temp(1,1)=aggi(l,1)
3739           a_temp(1,2)=aggi(l,2)
3740           a_temp(2,1)=aggi(l,3)
3741           a_temp(2,2)=aggi(l,4)
3742           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3743           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3744           s1=scalar2(b1(1,iti2),auxvec(1))
3745           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3746           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3747           s2=scalar2(b1(1,iti1),auxvec(1))
3748           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3749           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3750           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3751           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3752           a_temp(1,1)=aggi1(l,1)
3753           a_temp(1,2)=aggi1(l,2)
3754           a_temp(2,1)=aggi1(l,3)
3755           a_temp(2,2)=aggi1(l,4)
3756           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3758           s1=scalar2(b1(1,iti2),auxvec(1))
3759           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3760           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3761           s2=scalar2(b1(1,iti1),auxvec(1))
3762           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3763           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3766           a_temp(1,1)=aggj(l,1)
3767           a_temp(1,2)=aggj(l,2)
3768           a_temp(2,1)=aggj(l,3)
3769           a_temp(2,2)=aggj(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,iti2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,iti1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3780           a_temp(1,1)=aggj1(l,1)
3781           a_temp(1,2)=aggj1(l,2)
3782           a_temp(2,1)=aggj1(l,3)
3783           a_temp(2,2)=aggj1(l,4)
3784           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3785           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3786           s1=scalar2(b1(1,iti2),auxvec(1))
3787           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3788           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3789           s2=scalar2(b1(1,iti1),auxvec(1))
3790           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3794           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3795         enddo
3796       return
3797       end
3798 C-----------------------------------------------------------------------------
3799       subroutine vecpr(u,v,w)
3800       implicit real*8(a-h,o-z)
3801       dimension u(3),v(3),w(3)
3802       w(1)=u(2)*v(3)-u(3)*v(2)
3803       w(2)=-u(1)*v(3)+u(3)*v(1)
3804       w(3)=u(1)*v(2)-u(2)*v(1)
3805       return
3806       end
3807 C-----------------------------------------------------------------------------
3808       subroutine unormderiv(u,ugrad,unorm,ungrad)
3809 C This subroutine computes the derivatives of a normalized vector u, given
3810 C the derivatives computed without normalization conditions, ugrad. Returns
3811 C ungrad.
3812       implicit none
3813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3814       double precision vec(3)
3815       double precision scalar
3816       integer i,j
3817 c      write (2,*) 'ugrad',ugrad
3818 c      write (2,*) 'u',u
3819       do i=1,3
3820         vec(i)=scalar(ugrad(1,i),u(1))
3821       enddo
3822 c      write (2,*) 'vec',vec
3823       do i=1,3
3824         do j=1,3
3825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3826         enddo
3827       enddo
3828 c      write (2,*) 'ungrad',ungrad
3829       return
3830       end
3831 C-----------------------------------------------------------------------------
3832       subroutine escp_soft_sphere(evdw2,evdw2_14)
3833 C
3834 C This subroutine calculates the excluded-volume interaction energy between
3835 C peptide-group centers and side chains and its gradient in virtual-bond and
3836 C side-chain vectors.
3837 C
3838       implicit real*8 (a-h,o-z)
3839       include 'DIMENSIONS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.FFIELD'
3847       include 'COMMON.IOUNITS'
3848       include 'COMMON.CONTROL'
3849       dimension ggg(3)
3850       evdw2=0.0D0
3851       evdw2_14=0.0d0
3852       r0_scp=4.5d0
3853 cd    print '(a)','Enter ESCP'
3854 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3855       do i=iatscp_s,iatscp_e
3856         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3857         iteli=itel(i)
3858         xi=0.5D0*(c(1,i)+c(1,i+1))
3859         yi=0.5D0*(c(2,i)+c(2,i+1))
3860         zi=0.5D0*(c(3,i)+c(3,i+1))
3861
3862         do iint=1,nscp_gr(i)
3863
3864         do j=iscpstart(i,iint),iscpend(i,iint)
3865           if (itype(j).eq.ntyp1) cycle
3866           itypj=iabs(itype(j))
3867 C Uncomment following three lines for SC-p interactions
3868 c         xj=c(1,nres+j)-xi
3869 c         yj=c(2,nres+j)-yi
3870 c         zj=c(3,nres+j)-zi
3871 C Uncomment following three lines for Ca-p interactions
3872           xj=c(1,j)-xi
3873           yj=c(2,j)-yi
3874           zj=c(3,j)-zi
3875           rij=xj*xj+yj*yj+zj*zj
3876           r0ij=r0_scp
3877           r0ijsq=r0ij*r0ij
3878           if (rij.lt.r0ijsq) then
3879             evdwij=0.25d0*(rij-r0ijsq)**2
3880             fac=rij-r0ijsq
3881           else
3882             evdwij=0.0d0
3883             fac=0.0d0
3884           endif
3885           evdw2=evdw2+evdwij
3886 C
3887 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3888 C
3889           ggg(1)=xj*fac
3890           ggg(2)=yj*fac
3891           ggg(3)=zj*fac
3892 cgrad          if (j.lt.i) then
3893 cd          write (iout,*) 'j<i'
3894 C Uncomment following three lines for SC-p interactions
3895 c           do k=1,3
3896 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3897 c           enddo
3898 cgrad          else
3899 cd          write (iout,*) 'j>i'
3900 cgrad            do k=1,3
3901 cgrad              ggg(k)=-ggg(k)
3902 C Uncomment following line for SC-p interactions
3903 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3904 cgrad            enddo
3905 cgrad          endif
3906 cgrad          do k=1,3
3907 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3908 cgrad          enddo
3909 cgrad          kstart=min0(i+1,j)
3910 cgrad          kend=max0(i-1,j-1)
3911 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3912 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3913 cgrad          do k=kstart,kend
3914 cgrad            do l=1,3
3915 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3916 cgrad            enddo
3917 cgrad          enddo
3918           do k=1,3
3919             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3920             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3921           enddo
3922         enddo
3923
3924         enddo ! iint
3925       enddo ! i
3926       return
3927       end
3928 C-----------------------------------------------------------------------------
3929       subroutine escp(evdw2,evdw2_14)
3930 C
3931 C This subroutine calculates the excluded-volume interaction energy between
3932 C peptide-group centers and side chains and its gradient in virtual-bond and
3933 C side-chain vectors.
3934 C
3935       implicit real*8 (a-h,o-z)
3936       include 'DIMENSIONS'
3937       include 'COMMON.GEO'
3938       include 'COMMON.VAR'
3939       include 'COMMON.LOCAL'
3940       include 'COMMON.CHAIN'
3941       include 'COMMON.DERIV'
3942       include 'COMMON.INTERACT'
3943       include 'COMMON.FFIELD'
3944       include 'COMMON.IOUNITS'
3945       include 'COMMON.CONTROL'
3946       dimension ggg(3)
3947       evdw2=0.0D0
3948       evdw2_14=0.0d0
3949 cd    print '(a)','Enter ESCP'
3950 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3951       do i=iatscp_s,iatscp_e
3952         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3953         iteli=itel(i)
3954         xi=0.5D0*(c(1,i)+c(1,i+1))
3955         yi=0.5D0*(c(2,i)+c(2,i+1))
3956         zi=0.5D0*(c(3,i)+c(3,i+1))
3957
3958         do iint=1,nscp_gr(i)
3959
3960         do j=iscpstart(i,iint),iscpend(i,iint)
3961           itypj=iabs(itype(j))
3962           if (itypj.eq.ntyp1) cycle
3963 C Uncomment following three lines for SC-p interactions
3964 c         xj=c(1,nres+j)-xi
3965 c         yj=c(2,nres+j)-yi
3966 c         zj=c(3,nres+j)-zi
3967 C Uncomment following three lines for Ca-p interactions
3968           xj=c(1,j)-xi
3969           yj=c(2,j)-yi
3970           zj=c(3,j)-zi
3971           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3972           fac=rrij**expon2
3973           e1=fac*fac*aad(itypj,iteli)
3974           e2=fac*bad(itypj,iteli)
3975           if (iabs(j-i) .le. 2) then
3976             e1=scal14*e1
3977             e2=scal14*e2
3978             evdw2_14=evdw2_14+e1+e2
3979           endif
3980           evdwij=e1+e2
3981           evdw2=evdw2+evdwij
3982           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3983      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3984      &       bad(itypj,iteli)
3985 C
3986 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3987 C
3988           fac=-(evdwij+e1)*rrij
3989           ggg(1)=xj*fac
3990           ggg(2)=yj*fac
3991           ggg(3)=zj*fac
3992 cgrad          if (j.lt.i) then
3993 cd          write (iout,*) 'j<i'
3994 C Uncomment following three lines for SC-p interactions
3995 c           do k=1,3
3996 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3997 c           enddo
3998 cgrad          else
3999 cd          write (iout,*) 'j>i'
4000 cgrad            do k=1,3
4001 cgrad              ggg(k)=-ggg(k)
4002 C Uncomment following line for SC-p interactions
4003 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4004 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4005 cgrad            enddo
4006 cgrad          endif
4007 cgrad          do k=1,3
4008 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4009 cgrad          enddo
4010 cgrad          kstart=min0(i+1,j)
4011 cgrad          kend=max0(i-1,j-1)
4012 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4013 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4014 cgrad          do k=kstart,kend
4015 cgrad            do l=1,3
4016 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4017 cgrad            enddo
4018 cgrad          enddo
4019           do k=1,3
4020             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4021             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4022           enddo
4023         enddo
4024
4025         enddo ! iint
4026       enddo ! i
4027       do i=1,nct
4028         do j=1,3
4029           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4030           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4031           gradx_scp(j,i)=expon*gradx_scp(j,i)
4032         enddo
4033       enddo
4034 C******************************************************************************
4035 C
4036 C                              N O T E !!!
4037 C
4038 C To save time the factor EXPON has been extracted from ALL components
4039 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4040 C use!
4041 C
4042 C******************************************************************************
4043       return
4044       end
4045 C--------------------------------------------------------------------------
4046       subroutine edis(ehpb)
4047 C
4048 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4049 C
4050       implicit real*8 (a-h,o-z)
4051       include 'DIMENSIONS'
4052       include 'COMMON.SBRIDGE'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.DERIV'
4055       include 'COMMON.VAR'
4056       include 'COMMON.INTERACT'
4057       include 'COMMON.IOUNITS'
4058       dimension ggg(3)
4059       ehpb=0.0D0
4060 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4061 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4062       if (link_end.eq.0) return
4063       do i=link_start,link_end
4064 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4065 C CA-CA distance used in regularization of structure.
4066         ii=ihpb(i)
4067         jj=jhpb(i)
4068 C iii and jjj point to the residues for which the distance is assigned.
4069         if (ii.gt.nres) then
4070           iii=ii-nres
4071           jjj=jj-nres
4072         else
4073           iii=ii
4074           jjj=jj
4075         endif
4076 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4077 c     &    dhpb(i),dhpb1(i),forcon(i)
4078 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4079 C    distance and angle dependent SS bond potential.
4080 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4081 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4082         if (.not.dyn_ss .and. i.le.nss) then
4083 C 15/02/13 CC dynamic SSbond - additional check
4084          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4085      & iabs(itype(jjj)).eq.1) then
4086           call ssbond_ene(iii,jjj,eij)
4087           ehpb=ehpb+2*eij
4088          endif
4089 cd          write (iout,*) "eij",eij
4090         else
4091 C Calculate the distance between the two points and its difference from the
4092 C target distance.
4093           dd=dist(ii,jj)
4094             rdis=dd-dhpb(i)
4095 C Get the force constant corresponding to this distance.
4096             waga=forcon(i)
4097 C Calculate the contribution to energy.
4098             ehpb=ehpb+waga*rdis*rdis
4099 C
4100 C Evaluate gradient.
4101 C
4102             fac=waga*rdis/dd
4103 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4104 cd   &   ' waga=',waga,' fac=',fac
4105             do j=1,3
4106               ggg(j)=fac*(c(j,jj)-c(j,ii))
4107             enddo
4108 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4109 C If this is a SC-SC distance, we need to calculate the contributions to the
4110 C Cartesian gradient in the SC vectors (ghpbx).
4111           if (iii.lt.ii) then
4112           do j=1,3
4113             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4114             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4115           enddo
4116           endif
4117 cgrad        do j=iii,jjj-1
4118 cgrad          do k=1,3
4119 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4120 cgrad          enddo
4121 cgrad        enddo
4122           do k=1,3
4123             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4124             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4125           enddo
4126         endif
4127       enddo
4128       ehpb=0.5D0*ehpb
4129       return
4130       end
4131 C--------------------------------------------------------------------------
4132       subroutine ssbond_ene(i,j,eij)
4133 C
4134 C Calculate the distance and angle dependent SS-bond potential energy
4135 C using a free-energy function derived based on RHF/6-31G** ab initio
4136 C calculations of diethyl disulfide.
4137 C
4138 C A. Liwo and U. Kozlowska, 11/24/03
4139 C
4140       implicit real*8 (a-h,o-z)
4141       include 'DIMENSIONS'
4142       include 'COMMON.SBRIDGE'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.DERIV'
4145       include 'COMMON.LOCAL'
4146       include 'COMMON.INTERACT'
4147       include 'COMMON.VAR'
4148       include 'COMMON.IOUNITS'
4149       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4150       itypi=iabs(itype(i))
4151       xi=c(1,nres+i)
4152       yi=c(2,nres+i)
4153       zi=c(3,nres+i)
4154       dxi=dc_norm(1,nres+i)
4155       dyi=dc_norm(2,nres+i)
4156       dzi=dc_norm(3,nres+i)
4157 c      dsci_inv=dsc_inv(itypi)
4158       dsci_inv=vbld_inv(nres+i)
4159       itypj=iabs(itype(j))
4160 c      dscj_inv=dsc_inv(itypj)
4161       dscj_inv=vbld_inv(nres+j)
4162       xj=c(1,nres+j)-xi
4163       yj=c(2,nres+j)-yi
4164       zj=c(3,nres+j)-zi
4165       dxj=dc_norm(1,nres+j)
4166       dyj=dc_norm(2,nres+j)
4167       dzj=dc_norm(3,nres+j)
4168       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4169       rij=dsqrt(rrij)
4170       erij(1)=xj*rij
4171       erij(2)=yj*rij
4172       erij(3)=zj*rij
4173       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4174       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4175       om12=dxi*dxj+dyi*dyj+dzi*dzj
4176       do k=1,3
4177         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4178         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4179       enddo
4180       rij=1.0d0/rij
4181       deltad=rij-d0cm
4182       deltat1=1.0d0-om1
4183       deltat2=1.0d0+om2
4184       deltat12=om2-om1+2.0d0
4185       cosphi=om12-om1*om2
4186       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4187      &  +akct*deltad*deltat12
4188      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4189 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4190 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4191 c     &  " deltat12",deltat12," eij",eij
4192       ed=2*akcm*deltad+akct*deltat12
4193       pom1=akct*deltad
4194       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4195       eom1=-2*akth*deltat1-pom1-om2*pom2
4196       eom2= 2*akth*deltat2+pom1-om1*pom2
4197       eom12=pom2
4198       do k=1,3
4199         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4200         ghpbx(k,i)=ghpbx(k,i)-ggk
4201      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4202      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4203         ghpbx(k,j)=ghpbx(k,j)+ggk
4204      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4205      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4206         ghpbc(k,i)=ghpbc(k,i)-ggk
4207         ghpbc(k,j)=ghpbc(k,j)+ggk
4208       enddo
4209 C
4210 C Calculate the components of the gradient in DC and X
4211 C
4212 cgrad      do k=i,j-1
4213 cgrad        do l=1,3
4214 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4215 cgrad        enddo
4216 cgrad      enddo
4217       return
4218       end
4219 C--------------------------------------------------------------------------
4220       subroutine ebond(estr)
4221 c
4222 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4223 c
4224       implicit real*8 (a-h,o-z)
4225       include 'DIMENSIONS'
4226       include 'COMMON.LOCAL'
4227       include 'COMMON.GEO'
4228       include 'COMMON.INTERACT'
4229       include 'COMMON.DERIV'
4230       include 'COMMON.VAR'
4231       include 'COMMON.CHAIN'
4232       include 'COMMON.IOUNITS'
4233       include 'COMMON.NAMES'
4234       include 'COMMON.FFIELD'
4235       include 'COMMON.CONTROL'
4236       include 'COMMON.SETUP'
4237       double precision u(3),ud(3)
4238       estr=0.0d0
4239       estr1=0.0d0
4240       do i=ibondp_start,ibondp_end
4241         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4242           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4243           do j=1,3
4244           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4245      &      *dc(j,i-1)/vbld(i)
4246           enddo
4247           if (energy_dec) write(iout,*)
4248      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4249         else
4250         diff = vbld(i)-vbldp0
4251         if (energy_dec) write (iout,*)
4252      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4253         estr=estr+diff*diff
4254         do j=1,3
4255           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4256         enddo
4257 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4258         endif
4259       enddo
4260       estr=0.5d0*AKP*estr+estr1
4261 c
4262 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4263 c
4264       do i=ibond_start,ibond_end
4265         iti=iabs(itype(i))
4266         if (iti.ne.10 .and. iti.ne.ntyp1) then
4267           nbi=nbondterm(iti)
4268           if (nbi.eq.1) then
4269             diff=vbld(i+nres)-vbldsc0(1,iti)
4270             if (energy_dec) write (iout,*)
4271      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4272      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4273             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4274             do j=1,3
4275               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4276             enddo
4277           else
4278             do j=1,nbi
4279               diff=vbld(i+nres)-vbldsc0(j,iti)
4280               ud(j)=aksc(j,iti)*diff
4281               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4282             enddo
4283             uprod=u(1)
4284             do j=2,nbi
4285               uprod=uprod*u(j)
4286             enddo
4287             usum=0.0d0
4288             usumsqder=0.0d0
4289             do j=1,nbi
4290               uprod1=1.0d0
4291               uprod2=1.0d0
4292               do k=1,nbi
4293                 if (k.ne.j) then
4294                   uprod1=uprod1*u(k)
4295                   uprod2=uprod2*u(k)*u(k)
4296                 endif
4297               enddo
4298               usum=usum+uprod1
4299               usumsqder=usumsqder+ud(j)*uprod2
4300             enddo
4301             estr=estr+uprod/usum
4302             do j=1,3
4303              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4304             enddo
4305           endif
4306         endif
4307       enddo
4308       return
4309       end
4310 #ifdef CRYST_THETA
4311 C--------------------------------------------------------------------------
4312       subroutine ebend(etheta)
4313 C
4314 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4315 C angles gamma and its derivatives in consecutive thetas and gammas.
4316 C
4317       implicit real*8 (a-h,o-z)
4318       include 'DIMENSIONS'
4319       include 'COMMON.LOCAL'
4320       include 'COMMON.GEO'
4321       include 'COMMON.INTERACT'
4322       include 'COMMON.DERIV'
4323       include 'COMMON.VAR'
4324       include 'COMMON.CHAIN'
4325       include 'COMMON.IOUNITS'
4326       include 'COMMON.NAMES'
4327       include 'COMMON.FFIELD'
4328       include 'COMMON.CONTROL'
4329       common /calcthet/ term1,term2,termm,diffak,ratak,
4330      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4331      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4332       double precision y(2),z(2)
4333       delta=0.02d0*pi
4334 c      time11=dexp(-2*time)
4335 c      time12=1.0d0
4336       etheta=0.0D0
4337 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4338       do i=ithet_start,ithet_end
4339         if (itype(i-1).eq.ntyp1) cycle
4340 C Zero the energy function and its derivative at 0 or pi.
4341         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4342         it=itype(i-1)
4343         ichir1=isign(1,itype(i-2))
4344         ichir2=isign(1,itype(i))
4345          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4346          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4347          if (itype(i-1).eq.10) then
4348           itype1=isign(10,itype(i-2))
4349           ichir11=isign(1,itype(i-2))
4350           ichir12=isign(1,itype(i-2))
4351           itype2=isign(10,itype(i))
4352           ichir21=isign(1,itype(i))
4353           ichir22=isign(1,itype(i))
4354          endif
4355
4356         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4357 #ifdef OSF
4358           phii=phi(i)
4359           if (phii.ne.phii) phii=150.0
4360 #else
4361           phii=phi(i)
4362 #endif
4363           y(1)=dcos(phii)
4364           y(2)=dsin(phii)
4365         else
4366           y(1)=0.0D0
4367           y(2)=0.0D0
4368         endif
4369         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4370 #ifdef OSF
4371           phii1=phi(i+1)
4372           if (phii1.ne.phii1) phii1=150.0
4373           phii1=pinorm(phii1)
4374           z(1)=cos(phii1)
4375 #else
4376           phii1=phi(i+1)
4377           z(1)=dcos(phii1)
4378 #endif
4379           z(2)=dsin(phii1)
4380         else
4381           z(1)=0.0D0
4382           z(2)=0.0D0
4383         endif
4384 C Calculate the "mean" value of theta from the part of the distribution
4385 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4386 C In following comments this theta will be referred to as t_c.
4387         thet_pred_mean=0.0d0
4388         do k=1,2
4389             athetk=athet(k,it,ichir1,ichir2)
4390             bthetk=bthet(k,it,ichir1,ichir2)
4391           if (it.eq.10) then
4392              athetk=athet(k,itype1,ichir11,ichir12)
4393              bthetk=bthet(k,itype2,ichir21,ichir22)
4394           endif
4395          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4396         enddo
4397         dthett=thet_pred_mean*ssd
4398         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4399 C Derivatives of the "mean" values in gamma1 and gamma2.
4400         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4401      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4402          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4403      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4404          if (it.eq.10) then
4405       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4406      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4407         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4408      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4409          endif
4410         if (theta(i).gt.pi-delta) then
4411           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4412      &         E_tc0)
4413           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4414           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4415           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4416      &        E_theta)
4417           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4418      &        E_tc)
4419         else if (theta(i).lt.delta) then
4420           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4421           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4422           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4423      &        E_theta)
4424           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4425           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4426      &        E_tc)
4427         else
4428           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4429      &        E_theta,E_tc)
4430         endif
4431         etheta=etheta+ethetai
4432         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4433      &      'ebend',i,ethetai
4434         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4435         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4436         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4437       enddo
4438 C Ufff.... We've done all this!!!
4439       return
4440       end
4441 C---------------------------------------------------------------------------
4442       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4443      &     E_tc)
4444       implicit real*8 (a-h,o-z)
4445       include 'DIMENSIONS'
4446       include 'COMMON.LOCAL'
4447       include 'COMMON.IOUNITS'
4448       common /calcthet/ term1,term2,termm,diffak,ratak,
4449      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4450      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4451 C Calculate the contributions to both Gaussian lobes.
4452 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4453 C The "polynomial part" of the "standard deviation" of this part of
4454 C the distribution.
4455         sig=polthet(3,it)
4456         do j=2,0,-1
4457           sig=sig*thet_pred_mean+polthet(j,it)
4458         enddo
4459 C Derivative of the "interior part" of the "standard deviation of the"
4460 C gamma-dependent Gaussian lobe in t_c.
4461         sigtc=3*polthet(3,it)
4462         do j=2,1,-1
4463           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4464         enddo
4465         sigtc=sig*sigtc
4466 C Set the parameters of both Gaussian lobes of the distribution.
4467 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4468         fac=sig*sig+sigc0(it)
4469         sigcsq=fac+fac
4470         sigc=1.0D0/sigcsq
4471 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4472         sigsqtc=-4.0D0*sigcsq*sigtc
4473 c       print *,i,sig,sigtc,sigsqtc
4474 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4475         sigtc=-sigtc/(fac*fac)
4476 C Following variable is sigma(t_c)**(-2)
4477         sigcsq=sigcsq*sigcsq
4478         sig0i=sig0(it)
4479         sig0inv=1.0D0/sig0i**2
4480         delthec=thetai-thet_pred_mean
4481         delthe0=thetai-theta0i
4482         term1=-0.5D0*sigcsq*delthec*delthec
4483         term2=-0.5D0*sig0inv*delthe0*delthe0
4484 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4485 C NaNs in taking the logarithm. We extract the largest exponent which is added
4486 C to the energy (this being the log of the distribution) at the end of energy
4487 C term evaluation for this virtual-bond angle.
4488         if (term1.gt.term2) then
4489           termm=term1
4490           term2=dexp(term2-termm)
4491           term1=1.0d0
4492         else
4493           termm=term2
4494           term1=dexp(term1-termm)
4495           term2=1.0d0
4496         endif
4497 C The ratio between the gamma-independent and gamma-dependent lobes of
4498 C the distribution is a Gaussian function of thet_pred_mean too.
4499         diffak=gthet(2,it)-thet_pred_mean
4500         ratak=diffak/gthet(3,it)**2
4501         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4502 C Let's differentiate it in thet_pred_mean NOW.
4503         aktc=ak*ratak
4504 C Now put together the distribution terms to make complete distribution.
4505         termexp=term1+ak*term2
4506         termpre=sigc+ak*sig0i
4507 C Contribution of the bending energy from this theta is just the -log of
4508 C the sum of the contributions from the two lobes and the pre-exponential
4509 C factor. Simple enough, isn't it?
4510         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4511 C NOW the derivatives!!!
4512 C 6/6/97 Take into account the deformation.
4513         E_theta=(delthec*sigcsq*term1
4514      &       +ak*delthe0*sig0inv*term2)/termexp
4515         E_tc=((sigtc+aktc*sig0i)/termpre
4516      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4517      &       aktc*term2)/termexp)
4518       return
4519       end
4520 c-----------------------------------------------------------------------------
4521       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4522       implicit real*8 (a-h,o-z)
4523       include 'DIMENSIONS'
4524       include 'COMMON.LOCAL'
4525       include 'COMMON.IOUNITS'
4526       common /calcthet/ term1,term2,termm,diffak,ratak,
4527      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4528      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4529       delthec=thetai-thet_pred_mean
4530       delthe0=thetai-theta0i
4531 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4532       t3 = thetai-thet_pred_mean
4533       t6 = t3**2
4534       t9 = term1
4535       t12 = t3*sigcsq
4536       t14 = t12+t6*sigsqtc
4537       t16 = 1.0d0
4538       t21 = thetai-theta0i
4539       t23 = t21**2
4540       t26 = term2
4541       t27 = t21*t26
4542       t32 = termexp
4543       t40 = t32**2
4544       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4545      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4546      & *(-t12*t9-ak*sig0inv*t27)
4547       return
4548       end
4549 #else
4550 C--------------------------------------------------------------------------
4551       subroutine ebend(etheta)
4552 C
4553 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4554 C angles gamma and its derivatives in consecutive thetas and gammas.
4555 C ab initio-derived potentials from
4556 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4557 C
4558       implicit real*8 (a-h,o-z)
4559       include 'DIMENSIONS'
4560       include 'COMMON.LOCAL'
4561       include 'COMMON.GEO'
4562       include 'COMMON.INTERACT'
4563       include 'COMMON.DERIV'
4564       include 'COMMON.VAR'
4565       include 'COMMON.CHAIN'
4566       include 'COMMON.IOUNITS'
4567       include 'COMMON.NAMES'
4568       include 'COMMON.FFIELD'
4569       include 'COMMON.CONTROL'
4570       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4571      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4572      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4573      & sinph1ph2(maxdouble,maxdouble)
4574       logical lprn /.false./, lprn1 /.false./
4575       etheta=0.0D0
4576       do i=ithet_start,ithet_end
4577         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4578      &(itype(i).eq.ntyp1)) cycle
4579 C        print *,i,theta(i)
4580         if (iabs(itype(i+1)).eq.20) iblock=2
4581         if (iabs(itype(i+1)).ne.20) iblock=1
4582         dethetai=0.0d0
4583         dephii=0.0d0
4584         dephii1=0.0d0
4585         theti2=0.5d0*theta(i)
4586         ityp2=ithetyp((itype(i-1)))
4587         do k=1,nntheterm
4588           coskt(k)=dcos(k*theti2)
4589           sinkt(k)=dsin(k*theti2)
4590         enddo
4591 C        print *,ethetai
4592
4593         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4594 #ifdef OSF
4595           phii=phi(i)
4596           if (phii.ne.phii) phii=150.0
4597 #else
4598           phii=phi(i)
4599 #endif
4600           ityp1=ithetyp((itype(i-2)))
4601 C propagation of chirality for glycine type
4602           do k=1,nsingle
4603             cosph1(k)=dcos(k*phii)
4604             sinph1(k)=dsin(k*phii)
4605           enddo
4606         else
4607           phii=0.0d0
4608           do k=1,nsingle
4609           ityp1=ithetyp((itype(i-2)))
4610             cosph1(k)=0.0d0
4611             sinph1(k)=0.0d0
4612           enddo
4613         endif
4614         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4615 #ifdef OSF
4616           phii1=phi(i+1)
4617           if (phii1.ne.phii1) phii1=150.0
4618           phii1=pinorm(phii1)
4619 #else
4620           phii1=phi(i+1)
4621 #endif
4622           ityp3=ithetyp((itype(i)))
4623           do k=1,nsingle
4624             cosph2(k)=dcos(k*phii1)
4625             sinph2(k)=dsin(k*phii1)
4626           enddo
4627         else
4628           phii1=0.0d0
4629           ityp3=ithetyp((itype(i)))
4630           do k=1,nsingle
4631             cosph2(k)=0.0d0
4632             sinph2(k)=0.0d0
4633           enddo
4634         endif
4635         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4636         do k=1,ndouble
4637           do l=1,k-1
4638             ccl=cosph1(l)*cosph2(k-l)
4639             ssl=sinph1(l)*sinph2(k-l)
4640             scl=sinph1(l)*cosph2(k-l)
4641             csl=cosph1(l)*sinph2(k-l)
4642             cosph1ph2(l,k)=ccl-ssl
4643             cosph1ph2(k,l)=ccl+ssl
4644             sinph1ph2(l,k)=scl+csl
4645             sinph1ph2(k,l)=scl-csl
4646           enddo
4647         enddo
4648         if (lprn) then
4649         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4650      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4651         write (iout,*) "coskt and sinkt"
4652         do k=1,nntheterm
4653           write (iout,*) k,coskt(k),sinkt(k)
4654         enddo
4655         endif
4656         do k=1,ntheterm
4657           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4658           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4659      &      *coskt(k)
4660           if (lprn)
4661      &    write (iout,*) "k",k,"
4662      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4663      &     " ethetai",ethetai
4664         enddo
4665         if (lprn) then
4666         write (iout,*) "cosph and sinph"
4667         do k=1,nsingle
4668           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4669         enddo
4670         write (iout,*) "cosph1ph2 and sinph2ph2"
4671         do k=2,ndouble
4672           do l=1,k-1
4673             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4674      &         sinph1ph2(l,k),sinph1ph2(k,l)
4675           enddo
4676         enddo
4677         write(iout,*) "ethetai",ethetai
4678         endif
4679 C       print *,ethetai
4680         do m=1,ntheterm2
4681           do k=1,nsingle
4682             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4683      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4684      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4685      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4686             ethetai=ethetai+sinkt(m)*aux
4687             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4688             dephii=dephii+k*sinkt(m)*(
4689      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4690      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4691             dephii1=dephii1+k*sinkt(m)*(
4692      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4693      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4694             if (lprn)
4695      &      write (iout,*) "m",m," k",k," bbthet",
4696      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4697      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4698      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4699      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4700 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4701           enddo
4702         enddo
4703 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4704 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4705 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4706 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4707         if (lprn)
4708      &  write(iout,*) "ethetai",ethetai
4709 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4710         do m=1,ntheterm3
4711           do k=2,ndouble
4712             do l=1,k-1
4713               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4714      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4715      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4716      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4717               ethetai=ethetai+sinkt(m)*aux
4718               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4719               dephii=dephii+l*sinkt(m)*(
4720      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4721      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4722      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4723      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4724               dephii1=dephii1+(k-l)*sinkt(m)*(
4725      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4726      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4727      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4728      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4729               if (lprn) then
4730               write (iout,*) "m",m," k",k," l",l," ffthet",
4731      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4732      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4733      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4734      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4735      &            " ethetai",ethetai
4736               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4737      &            cosph1ph2(k,l)*sinkt(m),
4738      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4739               endif
4740             enddo
4741           enddo
4742         enddo
4743 10      continue
4744 c        lprn1=.true.
4745 C        print *,ethetai
4746         if (lprn1)
4747      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4748      &   i,theta(i)*rad2deg,phii*rad2deg,
4749      &   phii1*rad2deg,ethetai
4750 c        lprn1=.false.
4751         etheta=etheta+ethetai
4752         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4753         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4754         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4755       enddo
4756       return
4757       end
4758 #endif
4759 #ifdef CRYST_SC
4760 c-----------------------------------------------------------------------------
4761       subroutine esc(escloc)
4762 C Calculate the local energy of a side chain and its derivatives in the
4763 C corresponding virtual-bond valence angles THETA and the spherical angles
4764 C ALPHA and OMEGA.
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.GEO'
4768       include 'COMMON.LOCAL'
4769       include 'COMMON.VAR'
4770       include 'COMMON.INTERACT'
4771       include 'COMMON.DERIV'
4772       include 'COMMON.CHAIN'
4773       include 'COMMON.IOUNITS'
4774       include 'COMMON.NAMES'
4775       include 'COMMON.FFIELD'
4776       include 'COMMON.CONTROL'
4777       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4778      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4779       common /sccalc/ time11,time12,time112,theti,it,nlobit
4780       delta=0.02d0*pi
4781       escloc=0.0D0
4782 c     write (iout,'(a)') 'ESC'
4783       do i=loc_start,loc_end
4784         it=itype(i)
4785         if (it.eq.ntyp1) cycle
4786         if (it.eq.10) goto 1
4787         nlobit=nlob(iabs(it))
4788 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4789 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4790         theti=theta(i+1)-pipol
4791         x(1)=dtan(theti)
4792         x(2)=alph(i)
4793         x(3)=omeg(i)
4794
4795         if (x(2).gt.pi-delta) then
4796           xtemp(1)=x(1)
4797           xtemp(2)=pi-delta
4798           xtemp(3)=x(3)
4799           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4800           xtemp(2)=pi
4801           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4802           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4803      &        escloci,dersc(2))
4804           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4805      &        ddersc0(1),dersc(1))
4806           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4807      &        ddersc0(3),dersc(3))
4808           xtemp(2)=pi-delta
4809           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4810           xtemp(2)=pi
4811           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4812           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4813      &            dersc0(2),esclocbi,dersc02)
4814           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4815      &            dersc12,dersc01)
4816           call splinthet(x(2),0.5d0*delta,ss,ssd)
4817           dersc0(1)=dersc01
4818           dersc0(2)=dersc02
4819           dersc0(3)=0.0d0
4820           do k=1,3
4821             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4822           enddo
4823           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4824 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4825 c    &             esclocbi,ss,ssd
4826           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4827 c         escloci=esclocbi
4828 c         write (iout,*) escloci
4829         else if (x(2).lt.delta) then
4830           xtemp(1)=x(1)
4831           xtemp(2)=delta
4832           xtemp(3)=x(3)
4833           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4834           xtemp(2)=0.0d0
4835           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4836           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4837      &        escloci,dersc(2))
4838           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4839      &        ddersc0(1),dersc(1))
4840           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4841      &        ddersc0(3),dersc(3))
4842           xtemp(2)=delta
4843           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4844           xtemp(2)=0.0d0
4845           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4846           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4847      &            dersc0(2),esclocbi,dersc02)
4848           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4849      &            dersc12,dersc01)
4850           dersc0(1)=dersc01
4851           dersc0(2)=dersc02
4852           dersc0(3)=0.0d0
4853           call splinthet(x(2),0.5d0*delta,ss,ssd)
4854           do k=1,3
4855             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4856           enddo
4857           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4858 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4859 c    &             esclocbi,ss,ssd
4860           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4861 c         write (iout,*) escloci
4862         else
4863           call enesc(x,escloci,dersc,ddummy,.false.)
4864         endif
4865
4866         escloc=escloc+escloci
4867         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4868      &     'escloc',i,escloci
4869 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4870
4871         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4872      &   wscloc*dersc(1)
4873         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4874         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4875     1   continue
4876       enddo
4877       return
4878       end
4879 C---------------------------------------------------------------------------
4880       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4881       implicit real*8 (a-h,o-z)
4882       include 'DIMENSIONS'
4883       include 'COMMON.GEO'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.IOUNITS'
4886       common /sccalc/ time11,time12,time112,theti,it,nlobit
4887       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4888       double precision contr(maxlob,-1:1)
4889       logical mixed
4890 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4891         escloc_i=0.0D0
4892         do j=1,3
4893           dersc(j)=0.0D0
4894           if (mixed) ddersc(j)=0.0d0
4895         enddo
4896         x3=x(3)
4897
4898 C Because of periodicity of the dependence of the SC energy in omega we have
4899 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4900 C To avoid underflows, first compute & store the exponents.
4901
4902         do iii=-1,1
4903
4904           x(3)=x3+iii*dwapi
4905
4906           do j=1,nlobit
4907             do k=1,3
4908               z(k)=x(k)-censc(k,j,it)
4909             enddo
4910             do k=1,3
4911               Axk=0.0D0
4912               do l=1,3
4913                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4914               enddo
4915               Ax(k,j,iii)=Axk
4916             enddo
4917             expfac=0.0D0
4918             do k=1,3
4919               expfac=expfac+Ax(k,j,iii)*z(k)
4920             enddo
4921             contr(j,iii)=expfac
4922           enddo ! j
4923
4924         enddo ! iii
4925
4926         x(3)=x3
4927 C As in the case of ebend, we want to avoid underflows in exponentiation and
4928 C subsequent NaNs and INFs in energy calculation.
4929 C Find the largest exponent
4930         emin=contr(1,-1)
4931         do iii=-1,1
4932           do j=1,nlobit
4933             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4934           enddo
4935         enddo
4936         emin=0.5D0*emin
4937 cd      print *,'it=',it,' emin=',emin
4938
4939 C Compute the contribution to SC energy and derivatives
4940         do iii=-1,1
4941
4942           do j=1,nlobit
4943 #ifdef OSF
4944             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4945             if(adexp.ne.adexp) adexp=1.0
4946             expfac=dexp(adexp)
4947 #else
4948             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4949 #endif
4950 cd          print *,'j=',j,' expfac=',expfac
4951             escloc_i=escloc_i+expfac
4952             do k=1,3
4953               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4954             enddo
4955             if (mixed) then
4956               do k=1,3,2
4957                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4958      &            +gaussc(k,2,j,it))*expfac
4959               enddo
4960             endif
4961           enddo
4962
4963         enddo ! iii
4964
4965         dersc(1)=dersc(1)/cos(theti)**2
4966         ddersc(1)=ddersc(1)/cos(theti)**2
4967         ddersc(3)=ddersc(3)
4968
4969         escloci=-(dlog(escloc_i)-emin)
4970         do j=1,3
4971           dersc(j)=dersc(j)/escloc_i
4972         enddo
4973         if (mixed) then
4974           do j=1,3,2
4975             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4976           enddo
4977         endif
4978       return
4979       end
4980 C------------------------------------------------------------------------------
4981       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4982       implicit real*8 (a-h,o-z)
4983       include 'DIMENSIONS'
4984       include 'COMMON.GEO'
4985       include 'COMMON.LOCAL'
4986       include 'COMMON.IOUNITS'
4987       common /sccalc/ time11,time12,time112,theti,it,nlobit
4988       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4989       double precision contr(maxlob)
4990       logical mixed
4991
4992       escloc_i=0.0D0
4993
4994       do j=1,3
4995         dersc(j)=0.0D0
4996       enddo
4997
4998       do j=1,nlobit
4999         do k=1,2
5000           z(k)=x(k)-censc(k,j,it)
5001         enddo
5002         z(3)=dwapi
5003         do k=1,3
5004           Axk=0.0D0
5005           do l=1,3
5006             Axk=Axk+gaussc(l,k,j,it)*z(l)
5007           enddo
5008           Ax(k,j)=Axk
5009         enddo
5010         expfac=0.0D0
5011         do k=1,3
5012           expfac=expfac+Ax(k,j)*z(k)
5013         enddo
5014         contr(j)=expfac
5015       enddo ! j
5016
5017 C As in the case of ebend, we want to avoid underflows in exponentiation and
5018 C subsequent NaNs and INFs in energy calculation.
5019 C Find the largest exponent
5020       emin=contr(1)
5021       do j=1,nlobit
5022         if (emin.gt.contr(j)) emin=contr(j)
5023       enddo
5024       emin=0.5D0*emin
5025
5026 C Compute the contribution to SC energy and derivatives
5027
5028       dersc12=0.0d0
5029       do j=1,nlobit
5030         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5031         escloc_i=escloc_i+expfac
5032         do k=1,2
5033           dersc(k)=dersc(k)+Ax(k,j)*expfac
5034         enddo
5035         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5036      &            +gaussc(1,2,j,it))*expfac
5037         dersc(3)=0.0d0
5038       enddo
5039
5040       dersc(1)=dersc(1)/cos(theti)**2
5041       dersc12=dersc12/cos(theti)**2
5042       escloci=-(dlog(escloc_i)-emin)
5043       do j=1,2
5044         dersc(j)=dersc(j)/escloc_i
5045       enddo
5046       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5047       return
5048       end
5049 #else
5050 c----------------------------------------------------------------------------------
5051       subroutine esc(escloc)
5052 C Calculate the local energy of a side chain and its derivatives in the
5053 C corresponding virtual-bond valence angles THETA and the spherical angles
5054 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5055 C added by Urszula Kozlowska. 07/11/2007
5056 C
5057       implicit real*8 (a-h,o-z)
5058       include 'DIMENSIONS'
5059       include 'COMMON.GEO'
5060       include 'COMMON.LOCAL'
5061       include 'COMMON.VAR'
5062       include 'COMMON.SCROT'
5063       include 'COMMON.INTERACT'
5064       include 'COMMON.DERIV'
5065       include 'COMMON.CHAIN'
5066       include 'COMMON.IOUNITS'
5067       include 'COMMON.NAMES'
5068       include 'COMMON.FFIELD'
5069       include 'COMMON.CONTROL'
5070       include 'COMMON.VECTORS'
5071       double precision x_prime(3),y_prime(3),z_prime(3)
5072      &    , sumene,dsc_i,dp2_i,x(65),
5073      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5074      &    de_dxx,de_dyy,de_dzz,de_dt
5075       double precision s1_t,s1_6_t,s2_t,s2_6_t
5076       double precision
5077      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5078      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5079      & dt_dCi(3),dt_dCi1(3)
5080       common /sccalc/ time11,time12,time112,theti,it,nlobit
5081       delta=0.02d0*pi
5082       escloc=0.0D0
5083       do i=loc_start,loc_end
5084         if (itype(i).eq.ntyp1) cycle
5085         costtab(i+1) =dcos(theta(i+1))
5086         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5087         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5088         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5089         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5090         cosfac=dsqrt(cosfac2)
5091         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5092         sinfac=dsqrt(sinfac2)
5093         it=iabs(itype(i))
5094         if (it.eq.10) goto 1
5095 c
5096 C  Compute the axes of tghe local cartesian coordinates system; store in
5097 c   x_prime, y_prime and z_prime
5098 c
5099         do j=1,3
5100           x_prime(j) = 0.00
5101           y_prime(j) = 0.00
5102           z_prime(j) = 0.00
5103         enddo
5104 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5105 C     &   dc_norm(3,i+nres)
5106         do j = 1,3
5107           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5108           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5109         enddo
5110         do j = 1,3
5111           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5112         enddo
5113 c       write (2,*) "i",i
5114 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5115 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5116 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5117 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5118 c      & " xy",scalar(x_prime(1),y_prime(1)),
5119 c      & " xz",scalar(x_prime(1),z_prime(1)),
5120 c      & " yy",scalar(y_prime(1),y_prime(1)),
5121 c      & " yz",scalar(y_prime(1),z_prime(1)),
5122 c      & " zz",scalar(z_prime(1),z_prime(1))
5123 c
5124 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5125 C to local coordinate system. Store in xx, yy, zz.
5126 c
5127         xx=0.0d0
5128         yy=0.0d0
5129         zz=0.0d0
5130         do j = 1,3
5131           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5132           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5133           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5134         enddo
5135
5136         xxtab(i)=xx
5137         yytab(i)=yy
5138         zztab(i)=zz
5139 C
5140 C Compute the energy of the ith side cbain
5141 C
5142 c        write (2,*) "xx",xx," yy",yy," zz",zz
5143         it=iabs(itype(i))
5144         do j = 1,65
5145           x(j) = sc_parmin(j,it)
5146         enddo
5147 #ifdef CHECK_COORD
5148 Cc diagnostics - remove later
5149         xx1 = dcos(alph(2))
5150         yy1 = dsin(alph(2))*dcos(omeg(2))
5151         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5152         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5153      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5154      &    xx1,yy1,zz1
5155 C,"  --- ", xx_w,yy_w,zz_w
5156 c end diagnostics
5157 #endif
5158         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5159      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5160      &   + x(10)*yy*zz
5161         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5162      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5163      & + x(20)*yy*zz
5164         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5165      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5166      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5167      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5168      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5169      &  +x(40)*xx*yy*zz
5170         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5171      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5172      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5173      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5174      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5175      &  +x(60)*xx*yy*zz
5176         dsc_i   = 0.743d0+x(61)
5177         dp2_i   = 1.9d0+x(62)
5178         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5179      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5180         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5181      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5182         s1=(1+x(63))/(0.1d0 + dscp1)
5183         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5184         s2=(1+x(65))/(0.1d0 + dscp2)
5185         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5186         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5187      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5188 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5189 c     &   sumene4,
5190 c     &   dscp1,dscp2,sumene
5191 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5192         escloc = escloc + sumene
5193 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5194 c     & ,zz,xx,yy
5195 c#define DEBUG
5196 #ifdef DEBUG
5197 C
5198 C This section to check the numerical derivatives of the energy of ith side
5199 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5200 C #define DEBUG in the code to turn it on.
5201 C
5202         write (2,*) "sumene               =",sumene
5203         aincr=1.0d-7
5204         xxsave=xx
5205         xx=xx+aincr
5206         write (2,*) xx,yy,zz
5207         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5208         de_dxx_num=(sumenep-sumene)/aincr
5209         xx=xxsave
5210         write (2,*) "xx+ sumene from enesc=",sumenep
5211         yysave=yy
5212         yy=yy+aincr
5213         write (2,*) xx,yy,zz
5214         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5215         de_dyy_num=(sumenep-sumene)/aincr
5216         yy=yysave
5217         write (2,*) "yy+ sumene from enesc=",sumenep
5218         zzsave=zz
5219         zz=zz+aincr
5220         write (2,*) xx,yy,zz
5221         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5222         de_dzz_num=(sumenep-sumene)/aincr
5223         zz=zzsave
5224         write (2,*) "zz+ sumene from enesc=",sumenep
5225         costsave=cost2tab(i+1)
5226         sintsave=sint2tab(i+1)
5227         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5228         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5229         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5230         de_dt_num=(sumenep-sumene)/aincr
5231         write (2,*) " t+ sumene from enesc=",sumenep
5232         cost2tab(i+1)=costsave
5233         sint2tab(i+1)=sintsave
5234 C End of diagnostics section.
5235 #endif
5236 C
5237 C Compute the gradient of esc
5238 C
5239 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5240         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5241         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5242         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5243         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5244         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5245         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5246         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5247         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5248         pom1=(sumene3*sint2tab(i+1)+sumene1)
5249      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5250         pom2=(sumene4*cost2tab(i+1)+sumene2)
5251      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5252         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5253         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5254      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5255      &  +x(40)*yy*zz
5256         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5257         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5258      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5259      &  +x(60)*yy*zz
5260         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5261      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5262      &        +(pom1+pom2)*pom_dx
5263 #ifdef DEBUG
5264         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5265 #endif
5266 C
5267         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5268         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5269      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5270      &  +x(40)*xx*zz
5271         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5272         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5273      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5274      &  +x(59)*zz**2 +x(60)*xx*zz
5275         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5276      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5277      &        +(pom1-pom2)*pom_dy
5278 #ifdef DEBUG
5279         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5280 #endif
5281 C
5282         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5283      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5284      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5285      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5286      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5287      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5288      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5289      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5290 #ifdef DEBUG
5291         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5292 #endif
5293 C
5294         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5295      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5296      &  +pom1*pom_dt1+pom2*pom_dt2
5297 #ifdef DEBUG
5298         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5299 #endif
5300 c#undef DEBUG
5301 c
5302 C
5303        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5304        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5305        cosfac2xx=cosfac2*xx
5306        sinfac2yy=sinfac2*yy
5307        do k = 1,3
5308          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5309      &      vbld_inv(i+1)
5310          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5311      &      vbld_inv(i)
5312          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5313          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5314 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5315 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5316 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5317 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5318          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5319          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5320          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5321          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5322          dZZ_Ci1(k)=0.0d0
5323          dZZ_Ci(k)=0.0d0
5324          do j=1,3
5325            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5326      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5327            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5328      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5329          enddo
5330
5331          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5332          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5333          dZZ_XYZ(k)=vbld_inv(i+nres)*
5334      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5335 c
5336          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5337          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5338        enddo
5339
5340        do k=1,3
5341          dXX_Ctab(k,i)=dXX_Ci(k)
5342          dXX_C1tab(k,i)=dXX_Ci1(k)
5343          dYY_Ctab(k,i)=dYY_Ci(k)
5344          dYY_C1tab(k,i)=dYY_Ci1(k)
5345          dZZ_Ctab(k,i)=dZZ_Ci(k)
5346          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5347          dXX_XYZtab(k,i)=dXX_XYZ(k)
5348          dYY_XYZtab(k,i)=dYY_XYZ(k)
5349          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5350        enddo
5351
5352        do k = 1,3
5353 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5354 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5355 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5356 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5357 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5358 c     &    dt_dci(k)
5359 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5360 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5361          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5362      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5363          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5364      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5365          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5366      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5367        enddo
5368 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5369 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5370
5371 C to check gradient call subroutine check_grad
5372
5373     1 continue
5374       enddo
5375       return
5376       end
5377 c------------------------------------------------------------------------------
5378       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5379       implicit none
5380       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5381      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5382       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5383      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5384      &   + x(10)*yy*zz
5385       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5386      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5387      & + x(20)*yy*zz
5388       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5389      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5390      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5391      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5392      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5393      &  +x(40)*xx*yy*zz
5394       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5395      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5396      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5397      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5398      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5399      &  +x(60)*xx*yy*zz
5400       dsc_i   = 0.743d0+x(61)
5401       dp2_i   = 1.9d0+x(62)
5402       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5403      &          *(xx*cost2+yy*sint2))
5404       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5405      &          *(xx*cost2-yy*sint2))
5406       s1=(1+x(63))/(0.1d0 + dscp1)
5407       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5408       s2=(1+x(65))/(0.1d0 + dscp2)
5409       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5410       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5411      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5412       enesc=sumene
5413       return
5414       end
5415 #endif
5416 c------------------------------------------------------------------------------
5417       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5418 C
5419 C This procedure calculates two-body contact function g(rij) and its derivative:
5420 C
5421 C           eps0ij                                     !       x < -1
5422 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5423 C            0                                         !       x > 1
5424 C
5425 C where x=(rij-r0ij)/delta
5426 C
5427 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5428 C
5429       implicit none
5430       double precision rij,r0ij,eps0ij,fcont,fprimcont
5431       double precision x,x2,x4,delta
5432 c     delta=0.02D0*r0ij
5433 c      delta=0.2D0*r0ij
5434       x=(rij-r0ij)/delta
5435       if (x.lt.-1.0D0) then
5436         fcont=eps0ij
5437         fprimcont=0.0D0
5438       else if (x.le.1.0D0) then
5439         x2=x*x
5440         x4=x2*x2
5441         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5442         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5443       else
5444         fcont=0.0D0
5445         fprimcont=0.0D0
5446       endif
5447       return
5448       end
5449 c------------------------------------------------------------------------------
5450       subroutine splinthet(theti,delta,ss,ssder)
5451       implicit real*8 (a-h,o-z)
5452       include 'DIMENSIONS'
5453       include 'COMMON.VAR'
5454       include 'COMMON.GEO'
5455       thetup=pi-delta
5456       thetlow=delta
5457       if (theti.gt.pipol) then
5458         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5459       else
5460         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5461         ssder=-ssder
5462       endif
5463       return
5464       end
5465 c------------------------------------------------------------------------------
5466       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5467       implicit none
5468       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5469       double precision ksi,ksi2,ksi3,a1,a2,a3
5470       a1=fprim0*delta/(f1-f0)
5471       a2=3.0d0-2.0d0*a1
5472       a3=a1-2.0d0
5473       ksi=(x-x0)/delta
5474       ksi2=ksi*ksi
5475       ksi3=ksi2*ksi
5476       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5477       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5478       return
5479       end
5480 c------------------------------------------------------------------------------
5481       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5482       implicit none
5483       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5484       double precision ksi,ksi2,ksi3,a1,a2,a3
5485       ksi=(x-x0)/delta
5486       ksi2=ksi*ksi
5487       ksi3=ksi2*ksi
5488       a1=fprim0x*delta
5489       a2=3*(f1x-f0x)-2*fprim0x*delta
5490       a3=fprim0x*delta-2*(f1x-f0x)
5491       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5492       return
5493       end
5494 C-----------------------------------------------------------------------------
5495 #ifdef CRYST_TOR
5496 C-----------------------------------------------------------------------------
5497       subroutine etor(etors,edihcnstr)
5498       implicit real*8 (a-h,o-z)
5499       include 'DIMENSIONS'
5500       include 'COMMON.VAR'
5501       include 'COMMON.GEO'
5502       include 'COMMON.LOCAL'
5503       include 'COMMON.TORSION'
5504       include 'COMMON.INTERACT'
5505       include 'COMMON.DERIV'
5506       include 'COMMON.CHAIN'
5507       include 'COMMON.NAMES'
5508       include 'COMMON.IOUNITS'
5509       include 'COMMON.FFIELD'
5510       include 'COMMON.TORCNSTR'
5511       include 'COMMON.CONTROL'
5512       logical lprn
5513 C Set lprn=.true. for debugging
5514       lprn=.false.
5515 c      lprn=.true.
5516       etors=0.0D0
5517       do i=iphi_start,iphi_end
5518       etors_ii=0.0D0
5519         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5520      &      .or. itype(i).eq.ntyp1) cycle
5521         itori=itortyp(itype(i-2))
5522         itori1=itortyp(itype(i-1))
5523         phii=phi(i)
5524         gloci=0.0D0
5525 C Proline-Proline pair is a special case...
5526         if (itori.eq.3 .and. itori1.eq.3) then
5527           if (phii.gt.-dwapi3) then
5528             cosphi=dcos(3*phii)
5529             fac=1.0D0/(1.0D0-cosphi)
5530             etorsi=v1(1,3,3)*fac
5531             etorsi=etorsi+etorsi
5532             etors=etors+etorsi-v1(1,3,3)
5533             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5534             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5535           endif
5536           do j=1,3
5537             v1ij=v1(j+1,itori,itori1)
5538             v2ij=v2(j+1,itori,itori1)
5539             cosphi=dcos(j*phii)
5540             sinphi=dsin(j*phii)
5541             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5542             if (energy_dec) etors_ii=etors_ii+
5543      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5544             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5545           enddo
5546         else
5547           do j=1,nterm_old
5548             v1ij=v1(j,itori,itori1)
5549             v2ij=v2(j,itori,itori1)
5550             cosphi=dcos(j*phii)
5551             sinphi=dsin(j*phii)
5552             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5553             if (energy_dec) etors_ii=etors_ii+
5554      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5555             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5556           enddo
5557         endif
5558         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5559              'etor',i,etors_ii
5560         if (lprn)
5561      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5562      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5563      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5564         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5565 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5566       enddo
5567 ! 6/20/98 - dihedral angle constraints
5568       edihcnstr=0.0d0
5569       do i=1,ndih_constr
5570         itori=idih_constr(i)
5571         phii=phi(itori)
5572         difi=phii-phi0(i)
5573         if (difi.gt.drange(i)) then
5574           difi=difi-drange(i)
5575           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5576           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5577         else if (difi.lt.-drange(i)) then
5578           difi=difi+drange(i)
5579           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5580           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5581         endif
5582 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5583 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5584       enddo
5585 !      write (iout,*) 'edihcnstr',edihcnstr
5586       return
5587       end
5588 c------------------------------------------------------------------------------
5589       subroutine etor_d(etors_d)
5590       etors_d=0.0d0
5591       return
5592       end
5593 c----------------------------------------------------------------------------
5594 #else
5595       subroutine etor(etors,edihcnstr)
5596       implicit real*8 (a-h,o-z)
5597       include 'DIMENSIONS'
5598       include 'COMMON.VAR'
5599       include 'COMMON.GEO'
5600       include 'COMMON.LOCAL'
5601       include 'COMMON.TORSION'
5602       include 'COMMON.INTERACT'
5603       include 'COMMON.DERIV'
5604       include 'COMMON.CHAIN'
5605       include 'COMMON.NAMES'
5606       include 'COMMON.IOUNITS'
5607       include 'COMMON.FFIELD'
5608       include 'COMMON.TORCNSTR'
5609       include 'COMMON.CONTROL'
5610       logical lprn
5611 C Set lprn=.true. for debugging
5612       lprn=.false.
5613 c     lprn=.true.
5614       etors=0.0D0
5615       do i=iphi_start,iphi_end
5616         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5617      &       .or. itype(i).eq.ntyp1) cycle
5618         etors_ii=0.0D0
5619          if (iabs(itype(i)).eq.20) then
5620          iblock=2
5621          else
5622          iblock=1
5623          endif
5624         itori=itortyp(itype(i-2))
5625         itori1=itortyp(itype(i-1))
5626         phii=phi(i)
5627         gloci=0.0D0
5628 C Regular cosine and sine terms
5629         do j=1,nterm(itori,itori1,iblock)
5630           v1ij=v1(j,itori,itori1,iblock)
5631           v2ij=v2(j,itori,itori1,iblock)
5632           cosphi=dcos(j*phii)
5633           sinphi=dsin(j*phii)
5634           etors=etors+v1ij*cosphi+v2ij*sinphi
5635           if (energy_dec) etors_ii=etors_ii+
5636      &                v1ij*cosphi+v2ij*sinphi
5637           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5638         enddo
5639 C Lorentz terms
5640 C                         v1
5641 C  E = SUM ----------------------------------- - v1
5642 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5643 C
5644         cosphi=dcos(0.5d0*phii)
5645         sinphi=dsin(0.5d0*phii)
5646         do j=1,nlor(itori,itori1,iblock)
5647           vl1ij=vlor1(j,itori,itori1)
5648           vl2ij=vlor2(j,itori,itori1)
5649           vl3ij=vlor3(j,itori,itori1)
5650           pom=vl2ij*cosphi+vl3ij*sinphi
5651           pom1=1.0d0/(pom*pom+1.0d0)
5652           etors=etors+vl1ij*pom1
5653           if (energy_dec) etors_ii=etors_ii+
5654      &                vl1ij*pom1
5655           pom=-pom*pom1*pom1
5656           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5657         enddo
5658 C Subtract the constant term
5659         etors=etors-v0(itori,itori1,iblock)
5660           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5661      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5662         if (lprn)
5663      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5664      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5665      &  (v1(j,itori,itori1,iblock),j=1,6),
5666      &  (v2(j,itori,itori1,iblock),j=1,6)
5667         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5668 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5669       enddo
5670 ! 6/20/98 - dihedral angle constraints
5671       edihcnstr=0.0d0
5672 c      do i=1,ndih_constr
5673       do i=idihconstr_start,idihconstr_end
5674         itori=idih_constr(i)
5675         phii=phi(itori)
5676         difi=pinorm(phii-phi0(i))
5677         if (difi.gt.drange(i)) then
5678           difi=difi-drange(i)
5679           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5680           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5681         else if (difi.lt.-drange(i)) then
5682           difi=difi+drange(i)
5683           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5684           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5685         else
5686           difi=0.0
5687         endif
5688 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5689 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5690 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5691       enddo
5692 cd       write (iout,*) 'edihcnstr',edihcnstr
5693       return
5694       end
5695 c----------------------------------------------------------------------------
5696       subroutine etor_d(etors_d)
5697 C 6/23/01 Compute double torsional energy
5698       implicit real*8 (a-h,o-z)
5699       include 'DIMENSIONS'
5700       include 'COMMON.VAR'
5701       include 'COMMON.GEO'
5702       include 'COMMON.LOCAL'
5703       include 'COMMON.TORSION'
5704       include 'COMMON.INTERACT'
5705       include 'COMMON.DERIV'
5706       include 'COMMON.CHAIN'
5707       include 'COMMON.NAMES'
5708       include 'COMMON.IOUNITS'
5709       include 'COMMON.FFIELD'
5710       include 'COMMON.TORCNSTR'
5711       logical lprn
5712 C Set lprn=.true. for debugging
5713       lprn=.false.
5714 c     lprn=.true.
5715       etors_d=0.0D0
5716 c      write(iout,*) "a tu??"
5717       do i=iphid_start,iphid_end
5718         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5719      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5720         itori=itortyp(itype(i-2))
5721         itori1=itortyp(itype(i-1))
5722         itori2=itortyp(itype(i))
5723         phii=phi(i)
5724         phii1=phi(i+1)
5725         gloci1=0.0D0
5726         gloci2=0.0D0
5727         iblock=1
5728         if (iabs(itype(i+1)).eq.20) iblock=2
5729
5730 C Regular cosine and sine terms
5731         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5732           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5733           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5734           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5735           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5736           cosphi1=dcos(j*phii)
5737           sinphi1=dsin(j*phii)
5738           cosphi2=dcos(j*phii1)
5739           sinphi2=dsin(j*phii1)
5740           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5741      &     v2cij*cosphi2+v2sij*sinphi2
5742           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5743           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5744         enddo
5745         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5746           do l=1,k-1
5747             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5748             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5749             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5750             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5751             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5752             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5753             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5754             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5755             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5756      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5757             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5758      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5759             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5760      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5761           enddo
5762         enddo
5763         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5764         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5765       enddo
5766       return
5767       end
5768 #endif
5769 c------------------------------------------------------------------------------
5770       subroutine eback_sc_corr(esccor)
5771 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5772 c        conformational states; temporarily implemented as differences
5773 c        between UNRES torsional potentials (dependent on three types of
5774 c        residues) and the torsional potentials dependent on all 20 types
5775 c        of residues computed from AM1  energy surfaces of terminally-blocked
5776 c        amino-acid residues.
5777       implicit real*8 (a-h,o-z)
5778       include 'DIMENSIONS'
5779       include 'COMMON.VAR'
5780       include 'COMMON.GEO'
5781       include 'COMMON.LOCAL'
5782       include 'COMMON.TORSION'
5783       include 'COMMON.SCCOR'
5784       include 'COMMON.INTERACT'
5785       include 'COMMON.DERIV'
5786       include 'COMMON.CHAIN'
5787       include 'COMMON.NAMES'
5788       include 'COMMON.IOUNITS'
5789       include 'COMMON.FFIELD'
5790       include 'COMMON.CONTROL'
5791       logical lprn
5792 C Set lprn=.true. for debugging
5793       lprn=.false.
5794 c      lprn=.true.
5795 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5796       esccor=0.0D0
5797       do i=itau_start,itau_end
5798         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5799         esccor_ii=0.0D0
5800         isccori=isccortyp(itype(i-2))
5801         isccori1=isccortyp(itype(i-1))
5802 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5803         phii=phi(i)
5804         do intertyp=1,3 !intertyp
5805 cc Added 09 May 2012 (Adasko)
5806 cc  Intertyp means interaction type of backbone mainchain correlation:
5807 c   1 = SC...Ca...Ca...Ca
5808 c   2 = Ca...Ca...Ca...SC
5809 c   3 = SC...Ca...Ca...SCi
5810         gloci=0.0D0
5811         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5812      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5813      &      (itype(i-1).eq.ntyp1)))
5814      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5815      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5816      &     .or.(itype(i).eq.ntyp1)))
5817      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5818      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5819      &      (itype(i-3).eq.ntyp1)))) cycle
5820         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5821         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5822      & cycle
5823        do j=1,nterm_sccor(isccori,isccori1)
5824           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5825           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5826           cosphi=dcos(j*tauangle(intertyp,i))
5827           sinphi=dsin(j*tauangle(intertyp,i))
5828           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5829           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5830         enddo
5831 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5832         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5833         if (lprn)
5834      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5835      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5836      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5837      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5838         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5839        enddo !intertyp
5840       enddo
5841
5842       return
5843       end
5844 c----------------------------------------------------------------------------
5845       subroutine multibody(ecorr)
5846 C This subroutine calculates multi-body contributions to energy following
5847 C the idea of Skolnick et al. If side chains I and J make a contact and
5848 C at the same time side chains I+1 and J+1 make a contact, an extra
5849 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5850       implicit real*8 (a-h,o-z)
5851       include 'DIMENSIONS'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.DERIV'
5854       include 'COMMON.INTERACT'
5855       include 'COMMON.CONTACTS'
5856       double precision gx(3),gx1(3)
5857       logical lprn
5858
5859 C Set lprn=.true. for debugging
5860       lprn=.false.
5861
5862       if (lprn) then
5863         write (iout,'(a)') 'Contact function values:'
5864         do i=nnt,nct-2
5865           write (iout,'(i2,20(1x,i2,f10.5))')
5866      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5867         enddo
5868       endif
5869       ecorr=0.0D0
5870       do i=nnt,nct
5871         do j=1,3
5872           gradcorr(j,i)=0.0D0
5873           gradxorr(j,i)=0.0D0
5874         enddo
5875       enddo
5876       do i=nnt,nct-2
5877
5878         DO ISHIFT = 3,4
5879
5880         i1=i+ishift
5881         num_conti=num_cont(i)
5882         num_conti1=num_cont(i1)
5883         do jj=1,num_conti
5884           j=jcont(jj,i)
5885           do kk=1,num_conti1
5886             j1=jcont(kk,i1)
5887             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5888 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5889 cd   &                   ' ishift=',ishift
5890 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5891 C The system gains extra energy.
5892               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5893             endif   ! j1==j+-ishift
5894           enddo     ! kk
5895         enddo       ! jj
5896
5897         ENDDO ! ISHIFT
5898
5899       enddo         ! i
5900       return
5901       end
5902 c------------------------------------------------------------------------------
5903       double precision function esccorr(i,j,k,l,jj,kk)
5904       implicit real*8 (a-h,o-z)
5905       include 'DIMENSIONS'
5906       include 'COMMON.IOUNITS'
5907       include 'COMMON.DERIV'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.CONTACTS'
5910       double precision gx(3),gx1(3)
5911       logical lprn
5912       lprn=.false.
5913       eij=facont(jj,i)
5914       ekl=facont(kk,k)
5915 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5916 C Calculate the multi-body contribution to energy.
5917 C Calculate multi-body contributions to the gradient.
5918 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5919 cd   & k,l,(gacont(m,kk,k),m=1,3)
5920       do m=1,3
5921         gx(m) =ekl*gacont(m,jj,i)
5922         gx1(m)=eij*gacont(m,kk,k)
5923         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5924         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5925         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5926         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5927       enddo
5928       do m=i,j-1
5929         do ll=1,3
5930           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5931         enddo
5932       enddo
5933       do m=k,l-1
5934         do ll=1,3
5935           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5936         enddo
5937       enddo
5938       esccorr=-eij*ekl
5939       return
5940       end
5941 c------------------------------------------------------------------------------
5942       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5943 C This subroutine calculates multi-body contributions to hydrogen-bonding
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'COMMON.IOUNITS'
5947 #ifdef MPI
5948       include "mpif.h"
5949       parameter (max_cont=maxconts)
5950       parameter (max_dim=26)
5951       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5952       double precision zapas(max_dim,maxconts,max_fg_procs),
5953      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5954       common /przechowalnia/ zapas
5955       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5956      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5957 #endif
5958       include 'COMMON.SETUP'
5959       include 'COMMON.FFIELD'
5960       include 'COMMON.DERIV'
5961       include 'COMMON.INTERACT'
5962       include 'COMMON.CONTACTS'
5963       include 'COMMON.CONTROL'
5964       include 'COMMON.LOCAL'
5965       double precision gx(3),gx1(3),time00
5966       logical lprn,ldone
5967
5968 C Set lprn=.true. for debugging
5969       lprn=.false.
5970 #ifdef MPI
5971       n_corr=0
5972       n_corr1=0
5973       if (nfgtasks.le.1) goto 30
5974       if (lprn) then
5975         write (iout,'(a)') 'Contact function values before RECEIVE:'
5976         do i=nnt,nct-2
5977           write (iout,'(2i3,50(1x,i2,f5.2))')
5978      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5979      &    j=1,num_cont_hb(i))
5980         enddo
5981       endif
5982       call flush(iout)
5983       do i=1,ntask_cont_from
5984         ncont_recv(i)=0
5985       enddo
5986       do i=1,ntask_cont_to
5987         ncont_sent(i)=0
5988       enddo
5989 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5990 c     & ntask_cont_to
5991 C Make the list of contacts to send to send to other procesors
5992 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5993 c      call flush(iout)
5994       do i=iturn3_start,iturn3_end
5995 c        write (iout,*) "make contact list turn3",i," num_cont",
5996 c     &    num_cont_hb(i)
5997         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5998       enddo
5999       do i=iturn4_start,iturn4_end
6000 c        write (iout,*) "make contact list turn4",i," num_cont",
6001 c     &   num_cont_hb(i)
6002         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6003       enddo
6004       do ii=1,nat_sent
6005         i=iat_sent(ii)
6006 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6007 c     &    num_cont_hb(i)
6008         do j=1,num_cont_hb(i)
6009         do k=1,4
6010           jjc=jcont_hb(j,i)
6011           iproc=iint_sent_local(k,jjc,ii)
6012 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6013           if (iproc.gt.0) then
6014             ncont_sent(iproc)=ncont_sent(iproc)+1
6015             nn=ncont_sent(iproc)
6016             zapas(1,nn,iproc)=i
6017             zapas(2,nn,iproc)=jjc
6018             zapas(3,nn,iproc)=facont_hb(j,i)
6019             zapas(4,nn,iproc)=ees0p(j,i)
6020             zapas(5,nn,iproc)=ees0m(j,i)
6021             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6022             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6023             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6024             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6025             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6026             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6027             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6028             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6029             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6030             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6031             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6032             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6033             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6034             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6035             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6036             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6037             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6038             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6039             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6040             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6041             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6042           endif
6043         enddo
6044         enddo
6045       enddo
6046       if (lprn) then
6047       write (iout,*)
6048      &  "Numbers of contacts to be sent to other processors",
6049      &  (ncont_sent(i),i=1,ntask_cont_to)
6050       write (iout,*) "Contacts sent"
6051       do ii=1,ntask_cont_to
6052         nn=ncont_sent(ii)
6053         iproc=itask_cont_to(ii)
6054         write (iout,*) nn," contacts to processor",iproc,
6055      &   " of CONT_TO_COMM group"
6056         do i=1,nn
6057           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6058         enddo
6059       enddo
6060       call flush(iout)
6061       endif
6062       CorrelType=477
6063       CorrelID=fg_rank+1
6064       CorrelType1=478
6065       CorrelID1=nfgtasks+fg_rank+1
6066       ireq=0
6067 C Receive the numbers of needed contacts from other processors
6068       do ii=1,ntask_cont_from
6069         iproc=itask_cont_from(ii)
6070         ireq=ireq+1
6071         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6072      &    FG_COMM,req(ireq),IERR)
6073       enddo
6074 c      write (iout,*) "IRECV ended"
6075 c      call flush(iout)
6076 C Send the number of contacts needed by other processors
6077       do ii=1,ntask_cont_to
6078         iproc=itask_cont_to(ii)
6079         ireq=ireq+1
6080         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6081      &    FG_COMM,req(ireq),IERR)
6082       enddo
6083 c      write (iout,*) "ISEND ended"
6084 c      write (iout,*) "number of requests (nn)",ireq
6085       call flush(iout)
6086       if (ireq.gt.0)
6087      &  call MPI_Waitall(ireq,req,status_array,ierr)
6088 c      write (iout,*)
6089 c     &  "Numbers of contacts to be received from other processors",
6090 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6091 c      call flush(iout)
6092 C Receive contacts
6093       ireq=0
6094       do ii=1,ntask_cont_from
6095         iproc=itask_cont_from(ii)
6096         nn=ncont_recv(ii)
6097 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6098 c     &   " of CONT_TO_COMM group"
6099         call flush(iout)
6100         if (nn.gt.0) then
6101           ireq=ireq+1
6102           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6103      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6104 c          write (iout,*) "ireq,req",ireq,req(ireq)
6105         endif
6106       enddo
6107 C Send the contacts to processors that need them
6108       do ii=1,ntask_cont_to
6109         iproc=itask_cont_to(ii)
6110         nn=ncont_sent(ii)
6111 c        write (iout,*) nn," contacts to processor",iproc,
6112 c     &   " of CONT_TO_COMM group"
6113         if (nn.gt.0) then
6114           ireq=ireq+1
6115           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6116      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6117 c          write (iout,*) "ireq,req",ireq,req(ireq)
6118 c          do i=1,nn
6119 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6120 c          enddo
6121         endif
6122       enddo
6123 c      write (iout,*) "number of requests (contacts)",ireq
6124 c      write (iout,*) "req",(req(i),i=1,4)
6125 c      call flush(iout)
6126       if (ireq.gt.0)
6127      & call MPI_Waitall(ireq,req,status_array,ierr)
6128       do iii=1,ntask_cont_from
6129         iproc=itask_cont_from(iii)
6130         nn=ncont_recv(iii)
6131         if (lprn) then
6132         write (iout,*) "Received",nn," contacts from processor",iproc,
6133      &   " of CONT_FROM_COMM group"
6134         call flush(iout)
6135         do i=1,nn
6136           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6137         enddo
6138         call flush(iout)
6139         endif
6140         do i=1,nn
6141           ii=zapas_recv(1,i,iii)
6142 c Flag the received contacts to prevent double-counting
6143           jj=-zapas_recv(2,i,iii)
6144 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6145 c          call flush(iout)
6146           nnn=num_cont_hb(ii)+1
6147           num_cont_hb(ii)=nnn
6148           jcont_hb(nnn,ii)=jj
6149           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6150           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6151           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6152           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6153           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6154           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6155           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6156           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6157           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6158           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6159           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6160           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6161           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6162           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6163           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6164           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6165           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6166           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6167           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6168           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6169           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6170           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6171           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6172           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6173         enddo
6174       enddo
6175       call flush(iout)
6176       if (lprn) then
6177         write (iout,'(a)') 'Contact function values after receive:'
6178         do i=nnt,nct-2
6179           write (iout,'(2i3,50(1x,i3,f5.2))')
6180      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6181      &    j=1,num_cont_hb(i))
6182         enddo
6183         call flush(iout)
6184       endif
6185    30 continue
6186 #endif
6187       if (lprn) then
6188         write (iout,'(a)') 'Contact function values:'
6189         do i=nnt,nct-2
6190           write (iout,'(2i3,50(1x,i3,f5.2))')
6191      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6192      &    j=1,num_cont_hb(i))
6193         enddo
6194       endif
6195       ecorr=0.0D0
6196 C Remove the loop below after debugging !!!
6197       do i=nnt,nct
6198         do j=1,3
6199           gradcorr(j,i)=0.0D0
6200           gradxorr(j,i)=0.0D0
6201         enddo
6202       enddo
6203 C Calculate the local-electrostatic correlation terms
6204       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6205         i1=i+1
6206         num_conti=num_cont_hb(i)
6207         num_conti1=num_cont_hb(i+1)
6208         do jj=1,num_conti
6209           j=jcont_hb(jj,i)
6210           jp=iabs(j)
6211           do kk=1,num_conti1
6212             j1=jcont_hb(kk,i1)
6213             jp1=iabs(j1)
6214 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6215 c     &         ' jj=',jj,' kk=',kk
6216             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6217      &          .or. j.lt.0 .and. j1.gt.0) .and.
6218      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6219 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6220 C The system gains extra energy.
6221               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6222               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6223      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6224               n_corr=n_corr+1
6225             else if (j1.eq.j) then
6226 C Contacts I-J and I-(J+1) occur simultaneously.
6227 C The system loses extra energy.
6228 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6229             endif
6230           enddo ! kk
6231           do kk=1,num_conti
6232             j1=jcont_hb(kk,i)
6233 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6234 c    &         ' jj=',jj,' kk=',kk
6235             if (j1.eq.j+1) then
6236 C Contacts I-J and (I+1)-J occur simultaneously.
6237 C The system loses extra energy.
6238 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6239             endif ! j1==j+1
6240           enddo ! kk
6241         enddo ! jj
6242       enddo ! i
6243       return
6244       end
6245 c------------------------------------------------------------------------------
6246       subroutine add_hb_contact(ii,jj,itask)
6247       implicit real*8 (a-h,o-z)
6248       include "DIMENSIONS"
6249       include "COMMON.IOUNITS"
6250       integer max_cont
6251       integer max_dim
6252       parameter (max_cont=maxconts)
6253       parameter (max_dim=26)
6254       include "COMMON.CONTACTS"
6255       double precision zapas(max_dim,maxconts,max_fg_procs),
6256      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6257       common /przechowalnia/ zapas
6258       integer i,j,ii,jj,iproc,itask(4),nn
6259 c      write (iout,*) "itask",itask
6260       do i=1,2
6261         iproc=itask(i)
6262         if (iproc.gt.0) then
6263           do j=1,num_cont_hb(ii)
6264             jjc=jcont_hb(j,ii)
6265 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6266             if (jjc.eq.jj) then
6267               ncont_sent(iproc)=ncont_sent(iproc)+1
6268               nn=ncont_sent(iproc)
6269               zapas(1,nn,iproc)=ii
6270               zapas(2,nn,iproc)=jjc
6271               zapas(3,nn,iproc)=facont_hb(j,ii)
6272               zapas(4,nn,iproc)=ees0p(j,ii)
6273               zapas(5,nn,iproc)=ees0m(j,ii)
6274               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6275               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6276               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6277               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6278               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6279               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6280               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6281               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6282               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6283               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6284               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6285               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6286               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6287               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6288               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6289               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6290               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6291               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6292               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6293               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6294               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6295               exit
6296             endif
6297           enddo
6298         endif
6299       enddo
6300       return
6301       end
6302 c------------------------------------------------------------------------------
6303       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6304      &  n_corr1)
6305 C This subroutine calculates multi-body contributions to hydrogen-bonding
6306       implicit real*8 (a-h,o-z)
6307       include 'DIMENSIONS'
6308       include 'COMMON.IOUNITS'
6309 #ifdef MPI
6310       include "mpif.h"
6311       parameter (max_cont=maxconts)
6312       parameter (max_dim=70)
6313       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6314       double precision zapas(max_dim,maxconts,max_fg_procs),
6315      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6316       common /przechowalnia/ zapas
6317       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6318      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6319 #endif
6320       include 'COMMON.SETUP'
6321       include 'COMMON.FFIELD'
6322       include 'COMMON.DERIV'
6323       include 'COMMON.LOCAL'
6324       include 'COMMON.INTERACT'
6325       include 'COMMON.CONTACTS'
6326       include 'COMMON.CHAIN'
6327       include 'COMMON.CONTROL'
6328       double precision gx(3),gx1(3)
6329       integer num_cont_hb_old(maxres)
6330       logical lprn,ldone
6331       double precision eello4,eello5,eelo6,eello_turn6
6332       external eello4,eello5,eello6,eello_turn6
6333 C Set lprn=.true. for debugging
6334       lprn=.false.
6335       eturn6=0.0d0
6336 #ifdef MPI
6337       do i=1,nres
6338         num_cont_hb_old(i)=num_cont_hb(i)
6339       enddo
6340       n_corr=0
6341       n_corr1=0
6342       if (nfgtasks.le.1) goto 30
6343       if (lprn) then
6344         write (iout,'(a)') 'Contact function values before RECEIVE:'
6345         do i=nnt,nct-2
6346           write (iout,'(2i3,50(1x,i2,f5.2))')
6347      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6348      &    j=1,num_cont_hb(i))
6349         enddo
6350       endif
6351       call flush(iout)
6352       do i=1,ntask_cont_from
6353         ncont_recv(i)=0
6354       enddo
6355       do i=1,ntask_cont_to
6356         ncont_sent(i)=0
6357       enddo
6358 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6359 c     & ntask_cont_to
6360 C Make the list of contacts to send to send to other procesors
6361       do i=iturn3_start,iturn3_end
6362 c        write (iout,*) "make contact list turn3",i," num_cont",
6363 c     &    num_cont_hb(i)
6364         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6365       enddo
6366       do i=iturn4_start,iturn4_end
6367 c        write (iout,*) "make contact list turn4",i," num_cont",
6368 c     &   num_cont_hb(i)
6369         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6370       enddo
6371       do ii=1,nat_sent
6372         i=iat_sent(ii)
6373 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6374 c     &    num_cont_hb(i)
6375         do j=1,num_cont_hb(i)
6376         do k=1,4
6377           jjc=jcont_hb(j,i)
6378           iproc=iint_sent_local(k,jjc,ii)
6379 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6380           if (iproc.ne.0) then
6381             ncont_sent(iproc)=ncont_sent(iproc)+1
6382             nn=ncont_sent(iproc)
6383             zapas(1,nn,iproc)=i
6384             zapas(2,nn,iproc)=jjc
6385             zapas(3,nn,iproc)=d_cont(j,i)
6386             ind=3
6387             do kk=1,3
6388               ind=ind+1
6389               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6390             enddo
6391             do kk=1,2
6392               do ll=1,2
6393                 ind=ind+1
6394                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6395               enddo
6396             enddo
6397             do jj=1,5
6398               do kk=1,3
6399                 do ll=1,2
6400                   do mm=1,2
6401                     ind=ind+1
6402                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6403                   enddo
6404                 enddo
6405               enddo
6406             enddo
6407           endif
6408         enddo
6409         enddo
6410       enddo
6411       if (lprn) then
6412       write (iout,*)
6413      &  "Numbers of contacts to be sent to other processors",
6414      &  (ncont_sent(i),i=1,ntask_cont_to)
6415       write (iout,*) "Contacts sent"
6416       do ii=1,ntask_cont_to
6417         nn=ncont_sent(ii)
6418         iproc=itask_cont_to(ii)
6419         write (iout,*) nn," contacts to processor",iproc,
6420      &   " of CONT_TO_COMM group"
6421         do i=1,nn
6422           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6423         enddo
6424       enddo
6425       call flush(iout)
6426       endif
6427       CorrelType=477
6428       CorrelID=fg_rank+1
6429       CorrelType1=478
6430       CorrelID1=nfgtasks+fg_rank+1
6431       ireq=0
6432 C Receive the numbers of needed contacts from other processors
6433       do ii=1,ntask_cont_from
6434         iproc=itask_cont_from(ii)
6435         ireq=ireq+1
6436         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6437      &    FG_COMM,req(ireq),IERR)
6438       enddo
6439 c      write (iout,*) "IRECV ended"
6440 c      call flush(iout)
6441 C Send the number of contacts needed by other processors
6442       do ii=1,ntask_cont_to
6443         iproc=itask_cont_to(ii)
6444         ireq=ireq+1
6445         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6446      &    FG_COMM,req(ireq),IERR)
6447       enddo
6448 c      write (iout,*) "ISEND ended"
6449 c      write (iout,*) "number of requests (nn)",ireq
6450       call flush(iout)
6451       if (ireq.gt.0)
6452      &  call MPI_Waitall(ireq,req,status_array,ierr)
6453 c      write (iout,*)
6454 c     &  "Numbers of contacts to be received from other processors",
6455 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6456 c      call flush(iout)
6457 C Receive contacts
6458       ireq=0
6459       do ii=1,ntask_cont_from
6460         iproc=itask_cont_from(ii)
6461         nn=ncont_recv(ii)
6462 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6463 c     &   " of CONT_TO_COMM group"
6464         call flush(iout)
6465         if (nn.gt.0) then
6466           ireq=ireq+1
6467           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6468      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6469 c          write (iout,*) "ireq,req",ireq,req(ireq)
6470         endif
6471       enddo
6472 C Send the contacts to processors that need them
6473       do ii=1,ntask_cont_to
6474         iproc=itask_cont_to(ii)
6475         nn=ncont_sent(ii)
6476 c        write (iout,*) nn," contacts to processor",iproc,
6477 c     &   " of CONT_TO_COMM group"
6478         if (nn.gt.0) then
6479           ireq=ireq+1
6480           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6481      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6482 c          write (iout,*) "ireq,req",ireq,req(ireq)
6483 c          do i=1,nn
6484 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6485 c          enddo
6486         endif
6487       enddo
6488 c      write (iout,*) "number of requests (contacts)",ireq
6489 c      write (iout,*) "req",(req(i),i=1,4)
6490 c      call flush(iout)
6491       if (ireq.gt.0)
6492      & call MPI_Waitall(ireq,req,status_array,ierr)
6493       do iii=1,ntask_cont_from
6494         iproc=itask_cont_from(iii)
6495         nn=ncont_recv(iii)
6496         if (lprn) then
6497         write (iout,*) "Received",nn," contacts from processor",iproc,
6498      &   " of CONT_FROM_COMM group"
6499         call flush(iout)
6500         do i=1,nn
6501           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6502         enddo
6503         call flush(iout)
6504         endif
6505         do i=1,nn
6506           ii=zapas_recv(1,i,iii)
6507 c Flag the received contacts to prevent double-counting
6508           jj=-zapas_recv(2,i,iii)
6509 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6510 c          call flush(iout)
6511           nnn=num_cont_hb(ii)+1
6512           num_cont_hb(ii)=nnn
6513           jcont_hb(nnn,ii)=jj
6514           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6515           ind=3
6516           do kk=1,3
6517             ind=ind+1
6518             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6519           enddo
6520           do kk=1,2
6521             do ll=1,2
6522               ind=ind+1
6523               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6524             enddo
6525           enddo
6526           do jj=1,5
6527             do kk=1,3
6528               do ll=1,2
6529                 do mm=1,2
6530                   ind=ind+1
6531                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6532                 enddo
6533               enddo
6534             enddo
6535           enddo
6536         enddo
6537       enddo
6538       call flush(iout)
6539       if (lprn) then
6540         write (iout,'(a)') 'Contact function values after receive:'
6541         do i=nnt,nct-2
6542           write (iout,'(2i3,50(1x,i3,5f6.3))')
6543      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6544      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6545         enddo
6546         call flush(iout)
6547       endif
6548    30 continue
6549 #endif
6550       if (lprn) then
6551         write (iout,'(a)') 'Contact function values:'
6552         do i=nnt,nct-2
6553           write (iout,'(2i3,50(1x,i2,5f6.3))')
6554      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6555      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6556         enddo
6557       endif
6558       ecorr=0.0D0
6559       ecorr5=0.0d0
6560       ecorr6=0.0d0
6561 C Remove the loop below after debugging !!!
6562       do i=nnt,nct
6563         do j=1,3
6564           gradcorr(j,i)=0.0D0
6565           gradxorr(j,i)=0.0D0
6566         enddo
6567       enddo
6568 C Calculate the dipole-dipole interaction energies
6569       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6570       do i=iatel_s,iatel_e+1
6571         num_conti=num_cont_hb(i)
6572         do jj=1,num_conti
6573           j=jcont_hb(jj,i)
6574 #ifdef MOMENT
6575           call dipole(i,j,jj)
6576 #endif
6577         enddo
6578       enddo
6579       endif
6580 C Calculate the local-electrostatic correlation terms
6581 c                write (iout,*) "gradcorr5 in eello5 before loop"
6582 c                do iii=1,nres
6583 c                  write (iout,'(i5,3f10.5)')
6584 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6585 c                enddo
6586       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6587 c        write (iout,*) "corr loop i",i
6588         i1=i+1
6589         num_conti=num_cont_hb(i)
6590         num_conti1=num_cont_hb(i+1)
6591         do jj=1,num_conti
6592           j=jcont_hb(jj,i)
6593           jp=iabs(j)
6594           do kk=1,num_conti1
6595             j1=jcont_hb(kk,i1)
6596             jp1=iabs(j1)
6597 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6598 c     &         ' jj=',jj,' kk=',kk
6599 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6600             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6601      &          .or. j.lt.0 .and. j1.gt.0) .and.
6602      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6603 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6604 C The system gains extra energy.
6605               n_corr=n_corr+1
6606               sqd1=dsqrt(d_cont(jj,i))
6607               sqd2=dsqrt(d_cont(kk,i1))
6608               sred_geom = sqd1*sqd2
6609               IF (sred_geom.lt.cutoff_corr) THEN
6610                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6611      &            ekont,fprimcont)
6612 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6613 cd     &         ' jj=',jj,' kk=',kk
6614                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6615                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6616                 do l=1,3
6617                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6618                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6619                 enddo
6620                 n_corr1=n_corr1+1
6621 cd               write (iout,*) 'sred_geom=',sred_geom,
6622 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6623 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6624 cd               write (iout,*) "g_contij",g_contij
6625 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6626 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6627                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6628                 if (wcorr4.gt.0.0d0)
6629      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6630                   if (energy_dec.and.wcorr4.gt.0.0d0)
6631      1                 write (iout,'(a6,4i5,0pf7.3)')
6632      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6633 c                write (iout,*) "gradcorr5 before eello5"
6634 c                do iii=1,nres
6635 c                  write (iout,'(i5,3f10.5)')
6636 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6637 c                enddo
6638                 if (wcorr5.gt.0.0d0)
6639      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6640 c                write (iout,*) "gradcorr5 after eello5"
6641 c                do iii=1,nres
6642 c                  write (iout,'(i5,3f10.5)')
6643 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6644 c                enddo
6645                   if (energy_dec.and.wcorr5.gt.0.0d0)
6646      1                 write (iout,'(a6,4i5,0pf7.3)')
6647      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6648 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6649 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6650                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6651      &               .or. wturn6.eq.0.0d0))then
6652 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6653                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6654                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6655      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6656 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6657 cd     &            'ecorr6=',ecorr6
6658 cd                write (iout,'(4e15.5)') sred_geom,
6659 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6660 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6661 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6662                 else if (wturn6.gt.0.0d0
6663      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6664 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6665                   eturn6=eturn6+eello_turn6(i,jj,kk)
6666                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6667      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6668 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6669                 endif
6670               ENDIF
6671 1111          continue
6672             endif
6673           enddo ! kk
6674         enddo ! jj
6675       enddo ! i
6676       do i=1,nres
6677         num_cont_hb(i)=num_cont_hb_old(i)
6678       enddo
6679 c                write (iout,*) "gradcorr5 in eello5"
6680 c                do iii=1,nres
6681 c                  write (iout,'(i5,3f10.5)')
6682 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6683 c                enddo
6684       return
6685       end
6686 c------------------------------------------------------------------------------
6687       subroutine add_hb_contact_eello(ii,jj,itask)
6688       implicit real*8 (a-h,o-z)
6689       include "DIMENSIONS"
6690       include "COMMON.IOUNITS"
6691       integer max_cont
6692       integer max_dim
6693       parameter (max_cont=maxconts)
6694       parameter (max_dim=70)
6695       include "COMMON.CONTACTS"
6696       double precision zapas(max_dim,maxconts,max_fg_procs),
6697      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6698       common /przechowalnia/ zapas
6699       integer i,j,ii,jj,iproc,itask(4),nn
6700 c      write (iout,*) "itask",itask
6701       do i=1,2
6702         iproc=itask(i)
6703         if (iproc.gt.0) then
6704           do j=1,num_cont_hb(ii)
6705             jjc=jcont_hb(j,ii)
6706 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6707             if (jjc.eq.jj) then
6708               ncont_sent(iproc)=ncont_sent(iproc)+1
6709               nn=ncont_sent(iproc)
6710               zapas(1,nn,iproc)=ii
6711               zapas(2,nn,iproc)=jjc
6712               zapas(3,nn,iproc)=d_cont(j,ii)
6713               ind=3
6714               do kk=1,3
6715                 ind=ind+1
6716                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6717               enddo
6718               do kk=1,2
6719                 do ll=1,2
6720                   ind=ind+1
6721                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6722                 enddo
6723               enddo
6724               do jj=1,5
6725                 do kk=1,3
6726                   do ll=1,2
6727                     do mm=1,2
6728                       ind=ind+1
6729                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6730                     enddo
6731                   enddo
6732                 enddo
6733               enddo
6734               exit
6735             endif
6736           enddo
6737         endif
6738       enddo
6739       return
6740       end
6741 c------------------------------------------------------------------------------
6742       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6743       implicit real*8 (a-h,o-z)
6744       include 'DIMENSIONS'
6745       include 'COMMON.IOUNITS'
6746       include 'COMMON.DERIV'
6747       include 'COMMON.INTERACT'
6748       include 'COMMON.CONTACTS'
6749       double precision gx(3),gx1(3)
6750       logical lprn
6751       lprn=.false.
6752       eij=facont_hb(jj,i)
6753       ekl=facont_hb(kk,k)
6754       ees0pij=ees0p(jj,i)
6755       ees0pkl=ees0p(kk,k)
6756       ees0mij=ees0m(jj,i)
6757       ees0mkl=ees0m(kk,k)
6758       ekont=eij*ekl
6759       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6760 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6761 C Following 4 lines for diagnostics.
6762 cd    ees0pkl=0.0D0
6763 cd    ees0pij=1.0D0
6764 cd    ees0mkl=0.0D0
6765 cd    ees0mij=1.0D0
6766 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6767 c     & 'Contacts ',i,j,
6768 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6769 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6770 c     & 'gradcorr_long'
6771 C Calculate the multi-body contribution to energy.
6772 c      ecorr=ecorr+ekont*ees
6773 C Calculate multi-body contributions to the gradient.
6774       coeffpees0pij=coeffp*ees0pij
6775       coeffmees0mij=coeffm*ees0mij
6776       coeffpees0pkl=coeffp*ees0pkl
6777       coeffmees0mkl=coeffm*ees0mkl
6778       do ll=1,3
6779 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6780         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6781      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6782      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6783         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6784      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6785      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6786 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6787         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6788      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6789      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6790         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6791      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6792      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6793         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6794      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6795      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6796         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6797         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6798         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6799      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6800      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6801         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6802         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6803 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6804       enddo
6805 c      write (iout,*)
6806 cgrad      do m=i+1,j-1
6807 cgrad        do ll=1,3
6808 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6809 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6810 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6811 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6812 cgrad        enddo
6813 cgrad      enddo
6814 cgrad      do m=k+1,l-1
6815 cgrad        do ll=1,3
6816 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6817 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6818 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6819 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6820 cgrad        enddo
6821 cgrad      enddo
6822 c      write (iout,*) "ehbcorr",ekont*ees
6823       ehbcorr=ekont*ees
6824       return
6825       end
6826 #ifdef MOMENT
6827 C---------------------------------------------------------------------------
6828       subroutine dipole(i,j,jj)
6829       implicit real*8 (a-h,o-z)
6830       include 'DIMENSIONS'
6831       include 'COMMON.IOUNITS'
6832       include 'COMMON.CHAIN'
6833       include 'COMMON.FFIELD'
6834       include 'COMMON.DERIV'
6835       include 'COMMON.INTERACT'
6836       include 'COMMON.CONTACTS'
6837       include 'COMMON.TORSION'
6838       include 'COMMON.VAR'
6839       include 'COMMON.GEO'
6840       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6841      &  auxmat(2,2)
6842       iti1 = itortyp(itype(i+1))
6843       if (j.lt.nres-1) then
6844         itj1 = itortyp(itype(j+1))
6845       else
6846         itj1=ntortyp+1
6847       endif
6848       do iii=1,2
6849         dipi(iii,1)=Ub2(iii,i)
6850         dipderi(iii)=Ub2der(iii,i)
6851         dipi(iii,2)=b1(iii,iti1)
6852         dipj(iii,1)=Ub2(iii,j)
6853         dipderj(iii)=Ub2der(iii,j)
6854         dipj(iii,2)=b1(iii,itj1)
6855       enddo
6856       kkk=0
6857       do iii=1,2
6858         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6859         do jjj=1,2
6860           kkk=kkk+1
6861           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6862         enddo
6863       enddo
6864       do kkk=1,5
6865         do lll=1,3
6866           mmm=0
6867           do iii=1,2
6868             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6869      &        auxvec(1))
6870             do jjj=1,2
6871               mmm=mmm+1
6872               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6873             enddo
6874           enddo
6875         enddo
6876       enddo
6877       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6878       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6879       do iii=1,2
6880         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6881       enddo
6882       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6883       do iii=1,2
6884         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6885       enddo
6886       return
6887       end
6888 #endif
6889 C---------------------------------------------------------------------------
6890       subroutine calc_eello(i,j,k,l,jj,kk)
6891 C
6892 C This subroutine computes matrices and vectors needed to calculate
6893 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6894 C
6895       implicit real*8 (a-h,o-z)
6896       include 'DIMENSIONS'
6897       include 'COMMON.IOUNITS'
6898       include 'COMMON.CHAIN'
6899       include 'COMMON.DERIV'
6900       include 'COMMON.INTERACT'
6901       include 'COMMON.CONTACTS'
6902       include 'COMMON.TORSION'
6903       include 'COMMON.VAR'
6904       include 'COMMON.GEO'
6905       include 'COMMON.FFIELD'
6906       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6907      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6908       logical lprn
6909       common /kutas/ lprn
6910 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6911 cd     & ' jj=',jj,' kk=',kk
6912 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6913 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6914 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6915       do iii=1,2
6916         do jjj=1,2
6917           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6918           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6919         enddo
6920       enddo
6921       call transpose2(aa1(1,1),aa1t(1,1))
6922       call transpose2(aa2(1,1),aa2t(1,1))
6923       do kkk=1,5
6924         do lll=1,3
6925           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6926      &      aa1tder(1,1,lll,kkk))
6927           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6928      &      aa2tder(1,1,lll,kkk))
6929         enddo
6930       enddo
6931       if (l.eq.j+1) then
6932 C parallel orientation of the two CA-CA-CA frames.
6933         if (i.gt.1) then
6934           iti=itortyp(itype(i))
6935         else
6936           iti=ntortyp+1
6937         endif
6938         itk1=itortyp(itype(k+1))
6939         itj=itortyp(itype(j))
6940         if (l.lt.nres-1) then
6941           itl1=itortyp(itype(l+1))
6942         else
6943           itl1=ntortyp+1
6944         endif
6945 C A1 kernel(j+1) A2T
6946 cd        do iii=1,2
6947 cd          write (iout,'(3f10.5,5x,3f10.5)')
6948 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6949 cd        enddo
6950         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6951      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6952      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6953 C Following matrices are needed only for 6-th order cumulants
6954         IF (wcorr6.gt.0.0d0) THEN
6955         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6956      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6957      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6958         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6959      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6960      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6961      &   ADtEAderx(1,1,1,1,1,1))
6962         lprn=.false.
6963         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6964      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6965      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6966      &   ADtEA1derx(1,1,1,1,1,1))
6967         ENDIF
6968 C End 6-th order cumulants
6969 cd        lprn=.false.
6970 cd        if (lprn) then
6971 cd        write (2,*) 'In calc_eello6'
6972 cd        do iii=1,2
6973 cd          write (2,*) 'iii=',iii
6974 cd          do kkk=1,5
6975 cd            write (2,*) 'kkk=',kkk
6976 cd            do jjj=1,2
6977 cd              write (2,'(3(2f10.5),5x)')
6978 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6979 cd            enddo
6980 cd          enddo
6981 cd        enddo
6982 cd        endif
6983         call transpose2(EUgder(1,1,k),auxmat(1,1))
6984         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6985         call transpose2(EUg(1,1,k),auxmat(1,1))
6986         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6987         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6988         do iii=1,2
6989           do kkk=1,5
6990             do lll=1,3
6991               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6992      &          EAEAderx(1,1,lll,kkk,iii,1))
6993             enddo
6994           enddo
6995         enddo
6996 C A1T kernel(i+1) A2
6997         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6998      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6999      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7000 C Following matrices are needed only for 6-th order cumulants
7001         IF (wcorr6.gt.0.0d0) THEN
7002         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7003      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7004      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7005         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7006      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7007      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7008      &   ADtEAderx(1,1,1,1,1,2))
7009         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7010      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7011      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7012      &   ADtEA1derx(1,1,1,1,1,2))
7013         ENDIF
7014 C End 6-th order cumulants
7015         call transpose2(EUgder(1,1,l),auxmat(1,1))
7016         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7017         call transpose2(EUg(1,1,l),auxmat(1,1))
7018         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7019         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7020         do iii=1,2
7021           do kkk=1,5
7022             do lll=1,3
7023               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7024      &          EAEAderx(1,1,lll,kkk,iii,2))
7025             enddo
7026           enddo
7027         enddo
7028 C AEAb1 and AEAb2
7029 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7030 C They are needed only when the fifth- or the sixth-order cumulants are
7031 C indluded.
7032         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7033         call transpose2(AEA(1,1,1),auxmat(1,1))
7034         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7035         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7036         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7037         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7038         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7039         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7040         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7041         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7042         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7043         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7044         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7045         call transpose2(AEA(1,1,2),auxmat(1,1))
7046         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7047         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7048         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7049         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7050         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7051         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7052         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7053         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7054         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7055         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7056         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7057 C Calculate the Cartesian derivatives of the vectors.
7058         do iii=1,2
7059           do kkk=1,5
7060             do lll=1,3
7061               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7062               call matvec2(auxmat(1,1),b1(1,iti),
7063      &          AEAb1derx(1,lll,kkk,iii,1,1))
7064               call matvec2(auxmat(1,1),Ub2(1,i),
7065      &          AEAb2derx(1,lll,kkk,iii,1,1))
7066               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7067      &          AEAb1derx(1,lll,kkk,iii,2,1))
7068               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7069      &          AEAb2derx(1,lll,kkk,iii,2,1))
7070               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7071               call matvec2(auxmat(1,1),b1(1,itj),
7072      &          AEAb1derx(1,lll,kkk,iii,1,2))
7073               call matvec2(auxmat(1,1),Ub2(1,j),
7074      &          AEAb2derx(1,lll,kkk,iii,1,2))
7075               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7076      &          AEAb1derx(1,lll,kkk,iii,2,2))
7077               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7078      &          AEAb2derx(1,lll,kkk,iii,2,2))
7079             enddo
7080           enddo
7081         enddo
7082         ENDIF
7083 C End vectors
7084       else
7085 C Antiparallel orientation of the two CA-CA-CA frames.
7086         if (i.gt.1) then
7087           iti=itortyp(itype(i))
7088         else
7089           iti=ntortyp+1
7090         endif
7091         itk1=itortyp(itype(k+1))
7092         itl=itortyp(itype(l))
7093         itj=itortyp(itype(j))
7094         if (j.lt.nres-1) then
7095           itj1=itortyp(itype(j+1))
7096         else
7097           itj1=ntortyp+1
7098         endif
7099 C A2 kernel(j-1)T A1T
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7101      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7102      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7103 C Following matrices are needed only for 6-th order cumulants
7104         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7105      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7106         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7107      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7108      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7109         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7110      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7111      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7112      &   ADtEAderx(1,1,1,1,1,1))
7113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7114      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7115      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7116      &   ADtEA1derx(1,1,1,1,1,1))
7117         ENDIF
7118 C End 6-th order cumulants
7119         call transpose2(EUgder(1,1,k),auxmat(1,1))
7120         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7121         call transpose2(EUg(1,1,k),auxmat(1,1))
7122         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7123         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7124         do iii=1,2
7125           do kkk=1,5
7126             do lll=1,3
7127               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7128      &          EAEAderx(1,1,lll,kkk,iii,1))
7129             enddo
7130           enddo
7131         enddo
7132 C A2T kernel(i+1)T A1
7133         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7134      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7135      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7136 C Following matrices are needed only for 6-th order cumulants
7137         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7138      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7139         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7140      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7141      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7142         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7143      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7144      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7145      &   ADtEAderx(1,1,1,1,1,2))
7146         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7147      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7148      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7149      &   ADtEA1derx(1,1,1,1,1,2))
7150         ENDIF
7151 C End 6-th order cumulants
7152         call transpose2(EUgder(1,1,j),auxmat(1,1))
7153         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7154         call transpose2(EUg(1,1,j),auxmat(1,1))
7155         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7156         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7157         do iii=1,2
7158           do kkk=1,5
7159             do lll=1,3
7160               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7161      &          EAEAderx(1,1,lll,kkk,iii,2))
7162             enddo
7163           enddo
7164         enddo
7165 C AEAb1 and AEAb2
7166 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7167 C They are needed only when the fifth- or the sixth-order cumulants are
7168 C indluded.
7169         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7170      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7171         call transpose2(AEA(1,1,1),auxmat(1,1))
7172         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7173         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7174         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7175         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7176         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7177         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7178         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7179         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7180         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7181         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7182         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7183         call transpose2(AEA(1,1,2),auxmat(1,1))
7184         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7185         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7186         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7187         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7188         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7189         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7190         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7191         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7192         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7193         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7194         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7195 C Calculate the Cartesian derivatives of the vectors.
7196         do iii=1,2
7197           do kkk=1,5
7198             do lll=1,3
7199               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7200               call matvec2(auxmat(1,1),b1(1,iti),
7201      &          AEAb1derx(1,lll,kkk,iii,1,1))
7202               call matvec2(auxmat(1,1),Ub2(1,i),
7203      &          AEAb2derx(1,lll,kkk,iii,1,1))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7205      &          AEAb1derx(1,lll,kkk,iii,2,1))
7206               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7207      &          AEAb2derx(1,lll,kkk,iii,2,1))
7208               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7209               call matvec2(auxmat(1,1),b1(1,itl),
7210      &          AEAb1derx(1,lll,kkk,iii,1,2))
7211               call matvec2(auxmat(1,1),Ub2(1,l),
7212      &          AEAb2derx(1,lll,kkk,iii,1,2))
7213               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7214      &          AEAb1derx(1,lll,kkk,iii,2,2))
7215               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7216      &          AEAb2derx(1,lll,kkk,iii,2,2))
7217             enddo
7218           enddo
7219         enddo
7220         ENDIF
7221 C End vectors
7222       endif
7223       return
7224       end
7225 C---------------------------------------------------------------------------
7226       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7227      &  KK,KKderg,AKA,AKAderg,AKAderx)
7228       implicit none
7229       integer nderg
7230       logical transp
7231       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7232      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7233      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7234       integer iii,kkk,lll
7235       integer jjj,mmm
7236       logical lprn
7237       common /kutas/ lprn
7238       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7239       do iii=1,nderg
7240         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7241      &    AKAderg(1,1,iii))
7242       enddo
7243 cd      if (lprn) write (2,*) 'In kernel'
7244       do kkk=1,5
7245 cd        if (lprn) write (2,*) 'kkk=',kkk
7246         do lll=1,3
7247           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7248      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7249 cd          if (lprn) then
7250 cd            write (2,*) 'lll=',lll
7251 cd            write (2,*) 'iii=1'
7252 cd            do jjj=1,2
7253 cd              write (2,'(3(2f10.5),5x)')
7254 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7255 cd            enddo
7256 cd          endif
7257           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7258      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7259 cd          if (lprn) then
7260 cd            write (2,*) 'lll=',lll
7261 cd            write (2,*) 'iii=2'
7262 cd            do jjj=1,2
7263 cd              write (2,'(3(2f10.5),5x)')
7264 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7265 cd            enddo
7266 cd          endif
7267         enddo
7268       enddo
7269       return
7270       end
7271 C---------------------------------------------------------------------------
7272       double precision function eello4(i,j,k,l,jj,kk)
7273       implicit real*8 (a-h,o-z)
7274       include 'DIMENSIONS'
7275       include 'COMMON.IOUNITS'
7276       include 'COMMON.CHAIN'
7277       include 'COMMON.DERIV'
7278       include 'COMMON.INTERACT'
7279       include 'COMMON.CONTACTS'
7280       include 'COMMON.TORSION'
7281       include 'COMMON.VAR'
7282       include 'COMMON.GEO'
7283       double precision pizda(2,2),ggg1(3),ggg2(3)
7284 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7285 cd        eello4=0.0d0
7286 cd        return
7287 cd      endif
7288 cd      print *,'eello4:',i,j,k,l,jj,kk
7289 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7290 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7291 cold      eij=facont_hb(jj,i)
7292 cold      ekl=facont_hb(kk,k)
7293 cold      ekont=eij*ekl
7294       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7295 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7296       gcorr_loc(k-1)=gcorr_loc(k-1)
7297      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7298       if (l.eq.j+1) then
7299         gcorr_loc(l-1)=gcorr_loc(l-1)
7300      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7301       else
7302         gcorr_loc(j-1)=gcorr_loc(j-1)
7303      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7304       endif
7305       do iii=1,2
7306         do kkk=1,5
7307           do lll=1,3
7308             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7309      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7310 cd            derx(lll,kkk,iii)=0.0d0
7311           enddo
7312         enddo
7313       enddo
7314 cd      gcorr_loc(l-1)=0.0d0
7315 cd      gcorr_loc(j-1)=0.0d0
7316 cd      gcorr_loc(k-1)=0.0d0
7317 cd      eel4=1.0d0
7318 cd      write (iout,*)'Contacts have occurred for peptide groups',
7319 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7320 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7321       if (j.lt.nres-1) then
7322         j1=j+1
7323         j2=j-1
7324       else
7325         j1=j-1
7326         j2=j-2
7327       endif
7328       if (l.lt.nres-1) then
7329         l1=l+1
7330         l2=l-1
7331       else
7332         l1=l-1
7333         l2=l-2
7334       endif
7335       do ll=1,3
7336 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7337 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7338         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7339         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7340 cgrad        ghalf=0.5d0*ggg1(ll)
7341         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7342         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7343         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7344         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7345         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7346         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7347 cgrad        ghalf=0.5d0*ggg2(ll)
7348         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7349         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7350         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7351         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7352         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7353         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7354       enddo
7355 cgrad      do m=i+1,j-1
7356 cgrad        do ll=1,3
7357 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7358 cgrad        enddo
7359 cgrad      enddo
7360 cgrad      do m=k+1,l-1
7361 cgrad        do ll=1,3
7362 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7363 cgrad        enddo
7364 cgrad      enddo
7365 cgrad      do m=i+2,j2
7366 cgrad        do ll=1,3
7367 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7368 cgrad        enddo
7369 cgrad      enddo
7370 cgrad      do m=k+2,l2
7371 cgrad        do ll=1,3
7372 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7373 cgrad        enddo
7374 cgrad      enddo
7375 cd      do iii=1,nres-3
7376 cd        write (2,*) iii,gcorr_loc(iii)
7377 cd      enddo
7378       eello4=ekont*eel4
7379 cd      write (2,*) 'ekont',ekont
7380 cd      write (iout,*) 'eello4',ekont*eel4
7381       return
7382       end
7383 C---------------------------------------------------------------------------
7384       double precision function eello5(i,j,k,l,jj,kk)
7385       implicit real*8 (a-h,o-z)
7386       include 'DIMENSIONS'
7387       include 'COMMON.IOUNITS'
7388       include 'COMMON.CHAIN'
7389       include 'COMMON.DERIV'
7390       include 'COMMON.INTERACT'
7391       include 'COMMON.CONTACTS'
7392       include 'COMMON.TORSION'
7393       include 'COMMON.VAR'
7394       include 'COMMON.GEO'
7395       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7396       double precision ggg1(3),ggg2(3)
7397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7398 C                                                                              C
7399 C                            Parallel chains                                   C
7400 C                                                                              C
7401 C          o             o                   o             o                   C
7402 C         /l\           / \             \   / \           / \   /              C
7403 C        /   \         /   \             \ /   \         /   \ /               C
7404 C       j| o |l1       | o |              o| o |         | o |o                C
7405 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7406 C      \i/   \         /   \ /             /   \         /   \                 C
7407 C       o    k1             o                                                  C
7408 C         (I)          (II)                (III)          (IV)                 C
7409 C                                                                              C
7410 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7411 C                                                                              C
7412 C                            Antiparallel chains                               C
7413 C                                                                              C
7414 C          o             o                   o             o                   C
7415 C         /j\           / \             \   / \           / \   /              C
7416 C        /   \         /   \             \ /   \         /   \ /               C
7417 C      j1| o |l        | o |              o| o |         | o |o                C
7418 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7419 C      \i/   \         /   \ /             /   \         /   \                 C
7420 C       o     k1            o                                                  C
7421 C         (I)          (II)                (III)          (IV)                 C
7422 C                                                                              C
7423 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7424 C                                                                              C
7425 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7426 C                                                                              C
7427 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7428 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7429 cd        eello5=0.0d0
7430 cd        return
7431 cd      endif
7432 cd      write (iout,*)
7433 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7434 cd     &   ' and',k,l
7435       itk=itortyp(itype(k))
7436       itl=itortyp(itype(l))
7437       itj=itortyp(itype(j))
7438       eello5_1=0.0d0
7439       eello5_2=0.0d0
7440       eello5_3=0.0d0
7441       eello5_4=0.0d0
7442 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7443 cd     &   eel5_3_num,eel5_4_num)
7444       do iii=1,2
7445         do kkk=1,5
7446           do lll=1,3
7447             derx(lll,kkk,iii)=0.0d0
7448           enddo
7449         enddo
7450       enddo
7451 cd      eij=facont_hb(jj,i)
7452 cd      ekl=facont_hb(kk,k)
7453 cd      ekont=eij*ekl
7454 cd      write (iout,*)'Contacts have occurred for peptide groups',
7455 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7456 cd      goto 1111
7457 C Contribution from the graph I.
7458 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7459 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7460       call transpose2(EUg(1,1,k),auxmat(1,1))
7461       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7462       vv(1)=pizda(1,1)-pizda(2,2)
7463       vv(2)=pizda(1,2)+pizda(2,1)
7464       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7465      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7466 C Explicit gradient in virtual-dihedral angles.
7467       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7468      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7469      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7470       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7471       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7472       vv(1)=pizda(1,1)-pizda(2,2)
7473       vv(2)=pizda(1,2)+pizda(2,1)
7474       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7475      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7476      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7477       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7478       vv(1)=pizda(1,1)-pizda(2,2)
7479       vv(2)=pizda(1,2)+pizda(2,1)
7480       if (l.eq.j+1) then
7481         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7482      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7483      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7484       else
7485         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7486      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7487      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7488       endif
7489 C Cartesian gradient
7490       do iii=1,2
7491         do kkk=1,5
7492           do lll=1,3
7493             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7494      &        pizda(1,1))
7495             vv(1)=pizda(1,1)-pizda(2,2)
7496             vv(2)=pizda(1,2)+pizda(2,1)
7497             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7498      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7499      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7500           enddo
7501         enddo
7502       enddo
7503 c      goto 1112
7504 c1111  continue
7505 C Contribution from graph II
7506       call transpose2(EE(1,1,itk),auxmat(1,1))
7507       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7508       vv(1)=pizda(1,1)+pizda(2,2)
7509       vv(2)=pizda(2,1)-pizda(1,2)
7510       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7511      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7512 C Explicit gradient in virtual-dihedral angles.
7513       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7514      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7515       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7516       vv(1)=pizda(1,1)+pizda(2,2)
7517       vv(2)=pizda(2,1)-pizda(1,2)
7518       if (l.eq.j+1) then
7519         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7520      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7521      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7522       else
7523         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7524      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7525      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7526       endif
7527 C Cartesian gradient
7528       do iii=1,2
7529         do kkk=1,5
7530           do lll=1,3
7531             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7532      &        pizda(1,1))
7533             vv(1)=pizda(1,1)+pizda(2,2)
7534             vv(2)=pizda(2,1)-pizda(1,2)
7535             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7536      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7537      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7538           enddo
7539         enddo
7540       enddo
7541 cd      goto 1112
7542 cd1111  continue
7543       if (l.eq.j+1) then
7544 cd        goto 1110
7545 C Parallel orientation
7546 C Contribution from graph III
7547         call transpose2(EUg(1,1,l),auxmat(1,1))
7548         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7549         vv(1)=pizda(1,1)-pizda(2,2)
7550         vv(2)=pizda(1,2)+pizda(2,1)
7551         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7552      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7553 C Explicit gradient in virtual-dihedral angles.
7554         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7555      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7556      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7557         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7558         vv(1)=pizda(1,1)-pizda(2,2)
7559         vv(2)=pizda(1,2)+pizda(2,1)
7560         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7561      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7562      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7563         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7564         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7565         vv(1)=pizda(1,1)-pizda(2,2)
7566         vv(2)=pizda(1,2)+pizda(2,1)
7567         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7568      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7569      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7570 C Cartesian gradient
7571         do iii=1,2
7572           do kkk=1,5
7573             do lll=1,3
7574               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7575      &          pizda(1,1))
7576               vv(1)=pizda(1,1)-pizda(2,2)
7577               vv(2)=pizda(1,2)+pizda(2,1)
7578               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7579      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7580      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7581             enddo
7582           enddo
7583         enddo
7584 cd        goto 1112
7585 C Contribution from graph IV
7586 cd1110    continue
7587         call transpose2(EE(1,1,itl),auxmat(1,1))
7588         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7589         vv(1)=pizda(1,1)+pizda(2,2)
7590         vv(2)=pizda(2,1)-pizda(1,2)
7591         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7592      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7593 C Explicit gradient in virtual-dihedral angles.
7594         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7595      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7596         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7597         vv(1)=pizda(1,1)+pizda(2,2)
7598         vv(2)=pizda(2,1)-pizda(1,2)
7599         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7600      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7601      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7602 C Cartesian gradient
7603         do iii=1,2
7604           do kkk=1,5
7605             do lll=1,3
7606               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7607      &          pizda(1,1))
7608               vv(1)=pizda(1,1)+pizda(2,2)
7609               vv(2)=pizda(2,1)-pizda(1,2)
7610               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7611      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7612      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7613             enddo
7614           enddo
7615         enddo
7616       else
7617 C Antiparallel orientation
7618 C Contribution from graph III
7619 c        goto 1110
7620         call transpose2(EUg(1,1,j),auxmat(1,1))
7621         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7622         vv(1)=pizda(1,1)-pizda(2,2)
7623         vv(2)=pizda(1,2)+pizda(2,1)
7624         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7625      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7626 C Explicit gradient in virtual-dihedral angles.
7627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7628      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7629      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7630         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7631         vv(1)=pizda(1,1)-pizda(2,2)
7632         vv(2)=pizda(1,2)+pizda(2,1)
7633         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7634      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7635      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7636         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7637         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7638         vv(1)=pizda(1,1)-pizda(2,2)
7639         vv(2)=pizda(1,2)+pizda(2,1)
7640         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7641      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7642      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7643 C Cartesian gradient
7644         do iii=1,2
7645           do kkk=1,5
7646             do lll=1,3
7647               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7648      &          pizda(1,1))
7649               vv(1)=pizda(1,1)-pizda(2,2)
7650               vv(2)=pizda(1,2)+pizda(2,1)
7651               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7652      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7653      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7654             enddo
7655           enddo
7656         enddo
7657 cd        goto 1112
7658 C Contribution from graph IV
7659 1110    continue
7660         call transpose2(EE(1,1,itj),auxmat(1,1))
7661         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7662         vv(1)=pizda(1,1)+pizda(2,2)
7663         vv(2)=pizda(2,1)-pizda(1,2)
7664         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7665      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7666 C Explicit gradient in virtual-dihedral angles.
7667         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7668      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7669         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7670         vv(1)=pizda(1,1)+pizda(2,2)
7671         vv(2)=pizda(2,1)-pizda(1,2)
7672         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7673      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7674      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7675 C Cartesian gradient
7676         do iii=1,2
7677           do kkk=1,5
7678             do lll=1,3
7679               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7680      &          pizda(1,1))
7681               vv(1)=pizda(1,1)+pizda(2,2)
7682               vv(2)=pizda(2,1)-pizda(1,2)
7683               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7684      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7685      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7686             enddo
7687           enddo
7688         enddo
7689       endif
7690 1112  continue
7691       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7692 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7693 cd        write (2,*) 'ijkl',i,j,k,l
7694 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7695 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7696 cd      endif
7697 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7698 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7699 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7700 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7701       if (j.lt.nres-1) then
7702         j1=j+1
7703         j2=j-1
7704       else
7705         j1=j-1
7706         j2=j-2
7707       endif
7708       if (l.lt.nres-1) then
7709         l1=l+1
7710         l2=l-1
7711       else
7712         l1=l-1
7713         l2=l-2
7714       endif
7715 cd      eij=1.0d0
7716 cd      ekl=1.0d0
7717 cd      ekont=1.0d0
7718 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7719 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7720 C        summed up outside the subrouine as for the other subroutines
7721 C        handling long-range interactions. The old code is commented out
7722 C        with "cgrad" to keep track of changes.
7723       do ll=1,3
7724 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7725 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7726         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7727         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7728 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7729 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7730 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7731 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7732 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7733 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7734 c     &   gradcorr5ij,
7735 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7736 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7737 cgrad        ghalf=0.5d0*ggg1(ll)
7738 cd        ghalf=0.0d0
7739         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7740         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7741         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7742         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7743         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7744         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7745 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7746 cgrad        ghalf=0.5d0*ggg2(ll)
7747 cd        ghalf=0.0d0
7748         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7749         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7750         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7751         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7752         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7753         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7754       enddo
7755 cd      goto 1112
7756 cgrad      do m=i+1,j-1
7757 cgrad        do ll=1,3
7758 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7759 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7760 cgrad        enddo
7761 cgrad      enddo
7762 cgrad      do m=k+1,l-1
7763 cgrad        do ll=1,3
7764 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7765 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7766 cgrad        enddo
7767 cgrad      enddo
7768 c1112  continue
7769 cgrad      do m=i+2,j2
7770 cgrad        do ll=1,3
7771 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7772 cgrad        enddo
7773 cgrad      enddo
7774 cgrad      do m=k+2,l2
7775 cgrad        do ll=1,3
7776 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7777 cgrad        enddo
7778 cgrad      enddo
7779 cd      do iii=1,nres-3
7780 cd        write (2,*) iii,g_corr5_loc(iii)
7781 cd      enddo
7782       eello5=ekont*eel5
7783 cd      write (2,*) 'ekont',ekont
7784 cd      write (iout,*) 'eello5',ekont*eel5
7785       return
7786       end
7787 c--------------------------------------------------------------------------
7788       double precision function eello6(i,j,k,l,jj,kk)
7789       implicit real*8 (a-h,o-z)
7790       include 'DIMENSIONS'
7791       include 'COMMON.IOUNITS'
7792       include 'COMMON.CHAIN'
7793       include 'COMMON.DERIV'
7794       include 'COMMON.INTERACT'
7795       include 'COMMON.CONTACTS'
7796       include 'COMMON.TORSION'
7797       include 'COMMON.VAR'
7798       include 'COMMON.GEO'
7799       include 'COMMON.FFIELD'
7800       double precision ggg1(3),ggg2(3)
7801 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7802 cd        eello6=0.0d0
7803 cd        return
7804 cd      endif
7805 cd      write (iout,*)
7806 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7807 cd     &   ' and',k,l
7808       eello6_1=0.0d0
7809       eello6_2=0.0d0
7810       eello6_3=0.0d0
7811       eello6_4=0.0d0
7812       eello6_5=0.0d0
7813       eello6_6=0.0d0
7814 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7815 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7816       do iii=1,2
7817         do kkk=1,5
7818           do lll=1,3
7819             derx(lll,kkk,iii)=0.0d0
7820           enddo
7821         enddo
7822       enddo
7823 cd      eij=facont_hb(jj,i)
7824 cd      ekl=facont_hb(kk,k)
7825 cd      ekont=eij*ekl
7826 cd      eij=1.0d0
7827 cd      ekl=1.0d0
7828 cd      ekont=1.0d0
7829       if (l.eq.j+1) then
7830         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7831         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7832         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7833         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7834         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7835         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7836       else
7837         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7838         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7839         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7840         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7841         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7842           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7843         else
7844           eello6_5=0.0d0
7845         endif
7846         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7847       endif
7848 C If turn contributions are considered, they will be handled separately.
7849       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7850 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7851 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7852 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7853 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7854 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7855 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7856 cd      goto 1112
7857       if (j.lt.nres-1) then
7858         j1=j+1
7859         j2=j-1
7860       else
7861         j1=j-1
7862         j2=j-2
7863       endif
7864       if (l.lt.nres-1) then
7865         l1=l+1
7866         l2=l-1
7867       else
7868         l1=l-1
7869         l2=l-2
7870       endif
7871       do ll=1,3
7872 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7873 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7874 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7875 cgrad        ghalf=0.5d0*ggg1(ll)
7876 cd        ghalf=0.0d0
7877         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7878         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7879         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7880         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7881         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7882         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7883         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7884         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7885 cgrad        ghalf=0.5d0*ggg2(ll)
7886 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7887 cd        ghalf=0.0d0
7888         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7889         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7890         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7891         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7892         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7893         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7894       enddo
7895 cd      goto 1112
7896 cgrad      do m=i+1,j-1
7897 cgrad        do ll=1,3
7898 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7899 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7900 cgrad        enddo
7901 cgrad      enddo
7902 cgrad      do m=k+1,l-1
7903 cgrad        do ll=1,3
7904 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7905 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7906 cgrad        enddo
7907 cgrad      enddo
7908 cgrad1112  continue
7909 cgrad      do m=i+2,j2
7910 cgrad        do ll=1,3
7911 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7912 cgrad        enddo
7913 cgrad      enddo
7914 cgrad      do m=k+2,l2
7915 cgrad        do ll=1,3
7916 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7917 cgrad        enddo
7918 cgrad      enddo
7919 cd      do iii=1,nres-3
7920 cd        write (2,*) iii,g_corr6_loc(iii)
7921 cd      enddo
7922       eello6=ekont*eel6
7923 cd      write (2,*) 'ekont',ekont
7924 cd      write (iout,*) 'eello6',ekont*eel6
7925       return
7926       end
7927 c--------------------------------------------------------------------------
7928       double precision function eello6_graph1(i,j,k,l,imat,swap)
7929       implicit real*8 (a-h,o-z)
7930       include 'DIMENSIONS'
7931       include 'COMMON.IOUNITS'
7932       include 'COMMON.CHAIN'
7933       include 'COMMON.DERIV'
7934       include 'COMMON.INTERACT'
7935       include 'COMMON.CONTACTS'
7936       include 'COMMON.TORSION'
7937       include 'COMMON.VAR'
7938       include 'COMMON.GEO'
7939       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7940       logical swap
7941       logical lprn
7942       common /kutas/ lprn
7943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7944 C                                                                              C
7945 C      Parallel       Antiparallel                                             C
7946 C                                                                              C
7947 C          o             o                                                     C
7948 C         /l\           /j\                                                    C
7949 C        /   \         /   \                                                   C
7950 C       /| o |         | o |\                                                  C
7951 C     \ j|/k\|  /   \  |/k\|l /                                                C
7952 C      \ /   \ /     \ /   \ /                                                 C
7953 C       o     o       o     o                                                  C
7954 C       i             i                                                        C
7955 C                                                                              C
7956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7957       itk=itortyp(itype(k))
7958       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7959       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7960       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7961       call transpose2(EUgC(1,1,k),auxmat(1,1))
7962       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7963       vv1(1)=pizda1(1,1)-pizda1(2,2)
7964       vv1(2)=pizda1(1,2)+pizda1(2,1)
7965       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7966       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7967       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7968       s5=scalar2(vv(1),Dtobr2(1,i))
7969 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7970       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7971       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7972      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7973      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7974      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7975      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7976      & +scalar2(vv(1),Dtobr2der(1,i)))
7977       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7978       vv1(1)=pizda1(1,1)-pizda1(2,2)
7979       vv1(2)=pizda1(1,2)+pizda1(2,1)
7980       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7981       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7982       if (l.eq.j+1) then
7983         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7984      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7985      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7986      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7987      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7988       else
7989         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7990      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7991      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7992      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7993      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7994       endif
7995       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7996       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7997       vv1(1)=pizda1(1,1)-pizda1(2,2)
7998       vv1(2)=pizda1(1,2)+pizda1(2,1)
7999       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8000      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8001      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8002      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8003       do iii=1,2
8004         if (swap) then
8005           ind=3-iii
8006         else
8007           ind=iii
8008         endif
8009         do kkk=1,5
8010           do lll=1,3
8011             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8012             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8013             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8014             call transpose2(EUgC(1,1,k),auxmat(1,1))
8015             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8016      &        pizda1(1,1))
8017             vv1(1)=pizda1(1,1)-pizda1(2,2)
8018             vv1(2)=pizda1(1,2)+pizda1(2,1)
8019             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8020             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8021      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8022             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8023      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8024             s5=scalar2(vv(1),Dtobr2(1,i))
8025             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8026           enddo
8027         enddo
8028       enddo
8029       return
8030       end
8031 c----------------------------------------------------------------------------
8032       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8033       implicit real*8 (a-h,o-z)
8034       include 'DIMENSIONS'
8035       include 'COMMON.IOUNITS'
8036       include 'COMMON.CHAIN'
8037       include 'COMMON.DERIV'
8038       include 'COMMON.INTERACT'
8039       include 'COMMON.CONTACTS'
8040       include 'COMMON.TORSION'
8041       include 'COMMON.VAR'
8042       include 'COMMON.GEO'
8043       logical swap
8044       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8045      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8046       logical lprn
8047       common /kutas/ lprn
8048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8049 C                                                                              C
8050 C      Parallel       Antiparallel                                             C
8051 C                                                                              C
8052 C          o             o                                                     C
8053 C     \   /l\           /j\   /                                                C
8054 C      \ /   \         /   \ /                                                 C
8055 C       o| o |         | o |o                                                  C
8056 C     \ j|/k\|      \  |/k\|l                                                  C
8057 C      \ /   \       \ /   \                                                   C
8058 C       o             o                                                        C
8059 C       i             i                                                        C
8060 C                                                                              C
8061 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8062 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8063 C AL 7/4/01 s1 would occur in the sixth-order moment,
8064 C           but not in a cluster cumulant
8065 #ifdef MOMENT
8066       s1=dip(1,jj,i)*dip(1,kk,k)
8067 #endif
8068       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8069       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8070       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8071       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8072       call transpose2(EUg(1,1,k),auxmat(1,1))
8073       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8074       vv(1)=pizda(1,1)-pizda(2,2)
8075       vv(2)=pizda(1,2)+pizda(2,1)
8076       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8077 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8078 #ifdef MOMENT
8079       eello6_graph2=-(s1+s2+s3+s4)
8080 #else
8081       eello6_graph2=-(s2+s3+s4)
8082 #endif
8083 c      eello6_graph2=-s3
8084 C Derivatives in gamma(i-1)
8085       if (i.gt.1) then
8086 #ifdef MOMENT
8087         s1=dipderg(1,jj,i)*dip(1,kk,k)
8088 #endif
8089         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8090         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8091         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8092         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8093 #ifdef MOMENT
8094         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8095 #else
8096         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8097 #endif
8098 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8099       endif
8100 C Derivatives in gamma(k-1)
8101 #ifdef MOMENT
8102       s1=dip(1,jj,i)*dipderg(1,kk,k)
8103 #endif
8104       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8105       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8106       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8107       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8108       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8109       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8110       vv(1)=pizda(1,1)-pizda(2,2)
8111       vv(2)=pizda(1,2)+pizda(2,1)
8112       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8113 #ifdef MOMENT
8114       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8115 #else
8116       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8117 #endif
8118 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8119 C Derivatives in gamma(j-1) or gamma(l-1)
8120       if (j.gt.1) then
8121 #ifdef MOMENT
8122         s1=dipderg(3,jj,i)*dip(1,kk,k)
8123 #endif
8124         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8125         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8126         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8127         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8128         vv(1)=pizda(1,1)-pizda(2,2)
8129         vv(2)=pizda(1,2)+pizda(2,1)
8130         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8131 #ifdef MOMENT
8132         if (swap) then
8133           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8134         else
8135           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8136         endif
8137 #endif
8138         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8139 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8140       endif
8141 C Derivatives in gamma(l-1) or gamma(j-1)
8142       if (l.gt.1) then
8143 #ifdef MOMENT
8144         s1=dip(1,jj,i)*dipderg(3,kk,k)
8145 #endif
8146         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8147         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8148         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8149         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8150         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8151         vv(1)=pizda(1,1)-pizda(2,2)
8152         vv(2)=pizda(1,2)+pizda(2,1)
8153         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8154 #ifdef MOMENT
8155         if (swap) then
8156           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8157         else
8158           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8159         endif
8160 #endif
8161         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8162 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8163       endif
8164 C Cartesian derivatives.
8165       if (lprn) then
8166         write (2,*) 'In eello6_graph2'
8167         do iii=1,2
8168           write (2,*) 'iii=',iii
8169           do kkk=1,5
8170             write (2,*) 'kkk=',kkk
8171             do jjj=1,2
8172               write (2,'(3(2f10.5),5x)')
8173      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8174             enddo
8175           enddo
8176         enddo
8177       endif
8178       do iii=1,2
8179         do kkk=1,5
8180           do lll=1,3
8181 #ifdef MOMENT
8182             if (iii.eq.1) then
8183               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8184             else
8185               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8186             endif
8187 #endif
8188             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8189      &        auxvec(1))
8190             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8191             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8192      &        auxvec(1))
8193             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8194             call transpose2(EUg(1,1,k),auxmat(1,1))
8195             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8196      &        pizda(1,1))
8197             vv(1)=pizda(1,1)-pizda(2,2)
8198             vv(2)=pizda(1,2)+pizda(2,1)
8199             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8200 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8201 #ifdef MOMENT
8202             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8203 #else
8204             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8205 #endif
8206             if (swap) then
8207               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8208             else
8209               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8210             endif
8211           enddo
8212         enddo
8213       enddo
8214       return
8215       end
8216 c----------------------------------------------------------------------------
8217       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8218       implicit real*8 (a-h,o-z)
8219       include 'DIMENSIONS'
8220       include 'COMMON.IOUNITS'
8221       include 'COMMON.CHAIN'
8222       include 'COMMON.DERIV'
8223       include 'COMMON.INTERACT'
8224       include 'COMMON.CONTACTS'
8225       include 'COMMON.TORSION'
8226       include 'COMMON.VAR'
8227       include 'COMMON.GEO'
8228       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8229       logical swap
8230 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8231 C                                                                              C
8232 C      Parallel       Antiparallel                                             C
8233 C                                                                              C
8234 C          o             o                                                     C
8235 C         /l\   /   \   /j\                                                    C
8236 C        /   \ /     \ /   \                                                   C
8237 C       /| o |o       o| o |\                                                  C
8238 C       j|/k\|  /      |/k\|l /                                                C
8239 C        /   \ /       /   \ /                                                 C
8240 C       /     o       /     o                                                  C
8241 C       i             i                                                        C
8242 C                                                                              C
8243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8244 C
8245 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8246 C           energy moment and not to the cluster cumulant.
8247       iti=itortyp(itype(i))
8248       if (j.lt.nres-1) then
8249         itj1=itortyp(itype(j+1))
8250       else
8251         itj1=ntortyp+1
8252       endif
8253       itk=itortyp(itype(k))
8254       itk1=itortyp(itype(k+1))
8255       if (l.lt.nres-1) then
8256         itl1=itortyp(itype(l+1))
8257       else
8258         itl1=ntortyp+1
8259       endif
8260 #ifdef MOMENT
8261       s1=dip(4,jj,i)*dip(4,kk,k)
8262 #endif
8263       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8264       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8265       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8266       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8267       call transpose2(EE(1,1,itk),auxmat(1,1))
8268       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8269       vv(1)=pizda(1,1)+pizda(2,2)
8270       vv(2)=pizda(2,1)-pizda(1,2)
8271       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8272 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8273 cd     & "sum",-(s2+s3+s4)
8274 #ifdef MOMENT
8275       eello6_graph3=-(s1+s2+s3+s4)
8276 #else
8277       eello6_graph3=-(s2+s3+s4)
8278 #endif
8279 c      eello6_graph3=-s4
8280 C Derivatives in gamma(k-1)
8281       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8282       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8283       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8284       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8285 C Derivatives in gamma(l-1)
8286       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8287       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8288       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8289       vv(1)=pizda(1,1)+pizda(2,2)
8290       vv(2)=pizda(2,1)-pizda(1,2)
8291       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8292       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8293 C Cartesian derivatives.
8294       do iii=1,2
8295         do kkk=1,5
8296           do lll=1,3
8297 #ifdef MOMENT
8298             if (iii.eq.1) then
8299               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8300             else
8301               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8302             endif
8303 #endif
8304             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8305      &        auxvec(1))
8306             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8307             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8308      &        auxvec(1))
8309             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8310             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8311      &        pizda(1,1))
8312             vv(1)=pizda(1,1)+pizda(2,2)
8313             vv(2)=pizda(2,1)-pizda(1,2)
8314             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8315 #ifdef MOMENT
8316             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8317 #else
8318             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8319 #endif
8320             if (swap) then
8321               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8322             else
8323               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8324             endif
8325 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8326           enddo
8327         enddo
8328       enddo
8329       return
8330       end
8331 c----------------------------------------------------------------------------
8332       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8333       implicit real*8 (a-h,o-z)
8334       include 'DIMENSIONS'
8335       include 'COMMON.IOUNITS'
8336       include 'COMMON.CHAIN'
8337       include 'COMMON.DERIV'
8338       include 'COMMON.INTERACT'
8339       include 'COMMON.CONTACTS'
8340       include 'COMMON.TORSION'
8341       include 'COMMON.VAR'
8342       include 'COMMON.GEO'
8343       include 'COMMON.FFIELD'
8344       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8345      & auxvec1(2),auxmat1(2,2)
8346       logical swap
8347 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8348 C                                                                              C
8349 C      Parallel       Antiparallel                                             C
8350 C                                                                              C
8351 C          o             o                                                     C
8352 C         /l\   /   \   /j\                                                    C
8353 C        /   \ /     \ /   \                                                   C
8354 C       /| o |o       o| o |\                                                  C
8355 C     \ j|/k\|      \  |/k\|l                                                  C
8356 C      \ /   \       \ /   \                                                   C
8357 C       o     \       o     \                                                  C
8358 C       i             i                                                        C
8359 C                                                                              C
8360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8361 C
8362 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8363 C           energy moment and not to the cluster cumulant.
8364 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8365       iti=itortyp(itype(i))
8366       itj=itortyp(itype(j))
8367       if (j.lt.nres-1) then
8368         itj1=itortyp(itype(j+1))
8369       else
8370         itj1=ntortyp+1
8371       endif
8372       itk=itortyp(itype(k))
8373       if (k.lt.nres-1) then
8374         itk1=itortyp(itype(k+1))
8375       else
8376         itk1=ntortyp+1
8377       endif
8378       itl=itortyp(itype(l))
8379       if (l.lt.nres-1) then
8380         itl1=itortyp(itype(l+1))
8381       else
8382         itl1=ntortyp+1
8383       endif
8384 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8385 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8386 cd     & ' itl',itl,' itl1',itl1
8387 #ifdef MOMENT
8388       if (imat.eq.1) then
8389         s1=dip(3,jj,i)*dip(3,kk,k)
8390       else
8391         s1=dip(2,jj,j)*dip(2,kk,l)
8392       endif
8393 #endif
8394       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8395       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8396       if (j.eq.l+1) then
8397         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8398         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8399       else
8400         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8401         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8402       endif
8403       call transpose2(EUg(1,1,k),auxmat(1,1))
8404       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8405       vv(1)=pizda(1,1)-pizda(2,2)
8406       vv(2)=pizda(2,1)+pizda(1,2)
8407       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8409 #ifdef MOMENT
8410       eello6_graph4=-(s1+s2+s3+s4)
8411 #else
8412       eello6_graph4=-(s2+s3+s4)
8413 #endif
8414 C Derivatives in gamma(i-1)
8415       if (i.gt.1) then
8416 #ifdef MOMENT
8417         if (imat.eq.1) then
8418           s1=dipderg(2,jj,i)*dip(3,kk,k)
8419         else
8420           s1=dipderg(4,jj,j)*dip(2,kk,l)
8421         endif
8422 #endif
8423         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8424         if (j.eq.l+1) then
8425           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8426           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8427         else
8428           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8429           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8430         endif
8431         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8432         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8433 cd          write (2,*) 'turn6 derivatives'
8434 #ifdef MOMENT
8435           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8436 #else
8437           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8438 #endif
8439         else
8440 #ifdef MOMENT
8441           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8442 #else
8443           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8444 #endif
8445         endif
8446       endif
8447 C Derivatives in gamma(k-1)
8448 #ifdef MOMENT
8449       if (imat.eq.1) then
8450         s1=dip(3,jj,i)*dipderg(2,kk,k)
8451       else
8452         s1=dip(2,jj,j)*dipderg(4,kk,l)
8453       endif
8454 #endif
8455       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8456       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8457       if (j.eq.l+1) then
8458         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8459         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8460       else
8461         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8462         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8463       endif
8464       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8465       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8466       vv(1)=pizda(1,1)-pizda(2,2)
8467       vv(2)=pizda(2,1)+pizda(1,2)
8468       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8469       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8470 #ifdef MOMENT
8471         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8472 #else
8473         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8474 #endif
8475       else
8476 #ifdef MOMENT
8477         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8478 #else
8479         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8480 #endif
8481       endif
8482 C Derivatives in gamma(j-1) or gamma(l-1)
8483       if (l.eq.j+1 .and. l.gt.1) then
8484         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8485         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8486         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8487         vv(1)=pizda(1,1)-pizda(2,2)
8488         vv(2)=pizda(2,1)+pizda(1,2)
8489         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8490         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8491       else if (j.gt.1) then
8492         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8493         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8494         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8495         vv(1)=pizda(1,1)-pizda(2,2)
8496         vv(2)=pizda(2,1)+pizda(1,2)
8497         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8498         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8499           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8500         else
8501           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8502         endif
8503       endif
8504 C Cartesian derivatives.
8505       do iii=1,2
8506         do kkk=1,5
8507           do lll=1,3
8508 #ifdef MOMENT
8509             if (iii.eq.1) then
8510               if (imat.eq.1) then
8511                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8512               else
8513                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8514               endif
8515             else
8516               if (imat.eq.1) then
8517                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8518               else
8519                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8520               endif
8521             endif
8522 #endif
8523             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8524      &        auxvec(1))
8525             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8526             if (j.eq.l+1) then
8527               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8528      &          b1(1,itj1),auxvec(1))
8529               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8530             else
8531               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8532      &          b1(1,itl1),auxvec(1))
8533               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8534             endif
8535             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8536      &        pizda(1,1))
8537             vv(1)=pizda(1,1)-pizda(2,2)
8538             vv(2)=pizda(2,1)+pizda(1,2)
8539             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8540             if (swap) then
8541               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8542 #ifdef MOMENT
8543                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8544      &             -(s1+s2+s4)
8545 #else
8546                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8547      &             -(s2+s4)
8548 #endif
8549                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8550               else
8551 #ifdef MOMENT
8552                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8553 #else
8554                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8555 #endif
8556                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8557               endif
8558             else
8559 #ifdef MOMENT
8560               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8561 #else
8562               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8563 #endif
8564               if (l.eq.j+1) then
8565                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8566               else
8567                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8568               endif
8569             endif
8570           enddo
8571         enddo
8572       enddo
8573       return
8574       end
8575 c----------------------------------------------------------------------------
8576       double precision function eello_turn6(i,jj,kk)
8577       implicit real*8 (a-h,o-z)
8578       include 'DIMENSIONS'
8579       include 'COMMON.IOUNITS'
8580       include 'COMMON.CHAIN'
8581       include 'COMMON.DERIV'
8582       include 'COMMON.INTERACT'
8583       include 'COMMON.CONTACTS'
8584       include 'COMMON.TORSION'
8585       include 'COMMON.VAR'
8586       include 'COMMON.GEO'
8587       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8588      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8589      &  ggg1(3),ggg2(3)
8590       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8591      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8592 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8593 C           the respective energy moment and not to the cluster cumulant.
8594       s1=0.0d0
8595       s8=0.0d0
8596       s13=0.0d0
8597 c
8598       eello_turn6=0.0d0
8599       j=i+4
8600       k=i+1
8601       l=i+3
8602       iti=itortyp(itype(i))
8603       itk=itortyp(itype(k))
8604       itk1=itortyp(itype(k+1))
8605       itl=itortyp(itype(l))
8606       itj=itortyp(itype(j))
8607 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8608 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8609 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8610 cd        eello6=0.0d0
8611 cd        return
8612 cd      endif
8613 cd      write (iout,*)
8614 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8615 cd     &   ' and',k,l
8616 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8617       do iii=1,2
8618         do kkk=1,5
8619           do lll=1,3
8620             derx_turn(lll,kkk,iii)=0.0d0
8621           enddo
8622         enddo
8623       enddo
8624 cd      eij=1.0d0
8625 cd      ekl=1.0d0
8626 cd      ekont=1.0d0
8627       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8628 cd      eello6_5=0.0d0
8629 cd      write (2,*) 'eello6_5',eello6_5
8630 #ifdef MOMENT
8631       call transpose2(AEA(1,1,1),auxmat(1,1))
8632       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8633       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8634       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8635 #endif
8636       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8637       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8638       s2 = scalar2(b1(1,itk),vtemp1(1))
8639 #ifdef MOMENT
8640       call transpose2(AEA(1,1,2),atemp(1,1))
8641       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8642       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8643       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8644 #endif
8645       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8646       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8647       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8648 #ifdef MOMENT
8649       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8650       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8651       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8652       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8653       ss13 = scalar2(b1(1,itk),vtemp4(1))
8654       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8655 #endif
8656 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8657 c      s1=0.0d0
8658 c      s2=0.0d0
8659 c      s8=0.0d0
8660 c      s12=0.0d0
8661 c      s13=0.0d0
8662       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8663 C Derivatives in gamma(i+2)
8664       s1d =0.0d0
8665       s8d =0.0d0
8666 #ifdef MOMENT
8667       call transpose2(AEA(1,1,1),auxmatd(1,1))
8668       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8669       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8670       call transpose2(AEAderg(1,1,2),atempd(1,1))
8671       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8672       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8673 #endif
8674       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8675       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8676       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8677 c      s1d=0.0d0
8678 c      s2d=0.0d0
8679 c      s8d=0.0d0
8680 c      s12d=0.0d0
8681 c      s13d=0.0d0
8682       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8683 C Derivatives in gamma(i+3)
8684 #ifdef MOMENT
8685       call transpose2(AEA(1,1,1),auxmatd(1,1))
8686       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8687       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8688       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8689 #endif
8690       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8691       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8692       s2d = scalar2(b1(1,itk),vtemp1d(1))
8693 #ifdef MOMENT
8694       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8695       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8696 #endif
8697       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8698 #ifdef MOMENT
8699       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8700       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8701       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8702 #endif
8703 c      s1d=0.0d0
8704 c      s2d=0.0d0
8705 c      s8d=0.0d0
8706 c      s12d=0.0d0
8707 c      s13d=0.0d0
8708 #ifdef MOMENT
8709       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8710      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8711 #else
8712       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8713      &               -0.5d0*ekont*(s2d+s12d)
8714 #endif
8715 C Derivatives in gamma(i+4)
8716       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8717       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8718       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8719 #ifdef MOMENT
8720       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8721       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8722       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8723 #endif
8724 c      s1d=0.0d0
8725 c      s2d=0.0d0
8726 c      s8d=0.0d0
8727 C      s12d=0.0d0
8728 c      s13d=0.0d0
8729 #ifdef MOMENT
8730       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8731 #else
8732       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8733 #endif
8734 C Derivatives in gamma(i+5)
8735 #ifdef MOMENT
8736       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8737       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8738       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8739 #endif
8740       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8741       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8742       s2d = scalar2(b1(1,itk),vtemp1d(1))
8743 #ifdef MOMENT
8744       call transpose2(AEA(1,1,2),atempd(1,1))
8745       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8746       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8747 #endif
8748       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8749       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8750 #ifdef MOMENT
8751       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8752       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8753       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8754 #endif
8755 c      s1d=0.0d0
8756 c      s2d=0.0d0
8757 c      s8d=0.0d0
8758 c      s12d=0.0d0
8759 c      s13d=0.0d0
8760 #ifdef MOMENT
8761       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8762      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8763 #else
8764       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8765      &               -0.5d0*ekont*(s2d+s12d)
8766 #endif
8767 C Cartesian derivatives
8768       do iii=1,2
8769         do kkk=1,5
8770           do lll=1,3
8771 #ifdef MOMENT
8772             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8773             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8774             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8775 #endif
8776             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8777             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8778      &          vtemp1d(1))
8779             s2d = scalar2(b1(1,itk),vtemp1d(1))
8780 #ifdef MOMENT
8781             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8782             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8783             s8d = -(atempd(1,1)+atempd(2,2))*
8784      &           scalar2(cc(1,1,itl),vtemp2(1))
8785 #endif
8786             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8787      &           auxmatd(1,1))
8788             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8789             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8790 c      s1d=0.0d0
8791 c      s2d=0.0d0
8792 c      s8d=0.0d0
8793 c      s12d=0.0d0
8794 c      s13d=0.0d0
8795 #ifdef MOMENT
8796             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8797      &        - 0.5d0*(s1d+s2d)
8798 #else
8799             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8800      &        - 0.5d0*s2d
8801 #endif
8802 #ifdef MOMENT
8803             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8804      &        - 0.5d0*(s8d+s12d)
8805 #else
8806             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8807      &        - 0.5d0*s12d
8808 #endif
8809           enddo
8810         enddo
8811       enddo
8812 #ifdef MOMENT
8813       do kkk=1,5
8814         do lll=1,3
8815           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8816      &      achuj_tempd(1,1))
8817           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8818           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8819           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8820           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8821           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8822      &      vtemp4d(1))
8823           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8824           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8825           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8826         enddo
8827       enddo
8828 #endif
8829 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8830 cd     &  16*eel_turn6_num
8831 cd      goto 1112
8832       if (j.lt.nres-1) then
8833         j1=j+1
8834         j2=j-1
8835       else
8836         j1=j-1
8837         j2=j-2
8838       endif
8839       if (l.lt.nres-1) then
8840         l1=l+1
8841         l2=l-1
8842       else
8843         l1=l-1
8844         l2=l-2
8845       endif
8846       do ll=1,3
8847 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8848 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8849 cgrad        ghalf=0.5d0*ggg1(ll)
8850 cd        ghalf=0.0d0
8851         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8852         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8853         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8854      &    +ekont*derx_turn(ll,2,1)
8855         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8856         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8857      &    +ekont*derx_turn(ll,4,1)
8858         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8859         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8860         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8861 cgrad        ghalf=0.5d0*ggg2(ll)
8862 cd        ghalf=0.0d0
8863         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8864      &    +ekont*derx_turn(ll,2,2)
8865         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8866         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8867      &    +ekont*derx_turn(ll,4,2)
8868         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8869         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8870         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8871       enddo
8872 cd      goto 1112
8873 cgrad      do m=i+1,j-1
8874 cgrad        do ll=1,3
8875 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8876 cgrad        enddo
8877 cgrad      enddo
8878 cgrad      do m=k+1,l-1
8879 cgrad        do ll=1,3
8880 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8881 cgrad        enddo
8882 cgrad      enddo
8883 cgrad1112  continue
8884 cgrad      do m=i+2,j2
8885 cgrad        do ll=1,3
8886 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8887 cgrad        enddo
8888 cgrad      enddo
8889 cgrad      do m=k+2,l2
8890 cgrad        do ll=1,3
8891 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8892 cgrad        enddo
8893 cgrad      enddo
8894 cd      do iii=1,nres-3
8895 cd        write (2,*) iii,g_corr6_loc(iii)
8896 cd      enddo
8897       eello_turn6=ekont*eel_turn6
8898 cd      write (2,*) 'ekont',ekont
8899 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8900       return
8901       end
8902
8903 C-----------------------------------------------------------------------------
8904       double precision function scalar(u,v)
8905 !DIR$ INLINEALWAYS scalar
8906 #ifndef OSF
8907 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8908 #endif
8909       implicit none
8910       double precision u(3),v(3)
8911 cd      double precision sc
8912 cd      integer i
8913 cd      sc=0.0d0
8914 cd      do i=1,3
8915 cd        sc=sc+u(i)*v(i)
8916 cd      enddo
8917 cd      scalar=sc
8918
8919       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8920       return
8921       end
8922 crc-------------------------------------------------
8923       SUBROUTINE MATVEC2(A1,V1,V2)
8924 !DIR$ INLINEALWAYS MATVEC2
8925 #ifndef OSF
8926 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8927 #endif
8928       implicit real*8 (a-h,o-z)
8929       include 'DIMENSIONS'
8930       DIMENSION A1(2,2),V1(2),V2(2)
8931 c      DO 1 I=1,2
8932 c        VI=0.0
8933 c        DO 3 K=1,2
8934 c    3     VI=VI+A1(I,K)*V1(K)
8935 c        Vaux(I)=VI
8936 c    1 CONTINUE
8937
8938       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8939       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8940
8941       v2(1)=vaux1
8942       v2(2)=vaux2
8943       END
8944 C---------------------------------------
8945       SUBROUTINE MATMAT2(A1,A2,A3)
8946 #ifndef OSF
8947 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8948 #endif
8949       implicit real*8 (a-h,o-z)
8950       include 'DIMENSIONS'
8951       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8952 c      DIMENSION AI3(2,2)
8953 c        DO  J=1,2
8954 c          A3IJ=0.0
8955 c          DO K=1,2
8956 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8957 c          enddo
8958 c          A3(I,J)=A3IJ
8959 c       enddo
8960 c      enddo
8961
8962       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8963       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8964       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8965       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8966
8967       A3(1,1)=AI3_11
8968       A3(2,1)=AI3_21
8969       A3(1,2)=AI3_12
8970       A3(2,2)=AI3_22
8971       END
8972
8973 c-------------------------------------------------------------------------
8974       double precision function scalar2(u,v)
8975 !DIR$ INLINEALWAYS scalar2
8976       implicit none
8977       double precision u(2),v(2)
8978       double precision sc
8979       integer i
8980       scalar2=u(1)*v(1)+u(2)*v(2)
8981       return
8982       end
8983
8984 C-----------------------------------------------------------------------------
8985
8986       subroutine transpose2(a,at)
8987 !DIR$ INLINEALWAYS transpose2
8988 #ifndef OSF
8989 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8990 #endif
8991       implicit none
8992       double precision a(2,2),at(2,2)
8993       at(1,1)=a(1,1)
8994       at(1,2)=a(2,1)
8995       at(2,1)=a(1,2)
8996       at(2,2)=a(2,2)
8997       return
8998       end
8999 c--------------------------------------------------------------------------
9000       subroutine transpose(n,a,at)
9001       implicit none
9002       integer n,i,j
9003       double precision a(n,n),at(n,n)
9004       do i=1,n
9005         do j=1,n
9006           at(j,i)=a(i,j)
9007         enddo
9008       enddo
9009       return
9010       end
9011 C---------------------------------------------------------------------------
9012       subroutine prodmat3(a1,a2,kk,transp,prod)
9013 !DIR$ INLINEALWAYS prodmat3
9014 #ifndef OSF
9015 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9016 #endif
9017       implicit none
9018       integer i,j
9019       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9020       logical transp
9021 crc      double precision auxmat(2,2),prod_(2,2)
9022
9023       if (transp) then
9024 crc        call transpose2(kk(1,1),auxmat(1,1))
9025 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9026 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9027
9028            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9029      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9030            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9031      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9032            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9033      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9034            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9035      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9036
9037       else
9038 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9039 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9040
9041            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9042      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9043            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9044      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9045            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9046      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9047            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9048      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9049
9050       endif
9051 c      call transpose2(a2(1,1),a2t(1,1))
9052
9053 crc      print *,transp
9054 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9055 crc      print *,((prod(i,j),i=1,2),j=1,2)
9056
9057       return
9058       end
9059