source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             endif    ! sss
1667             ENDIF    ! dyn_ss
1668           enddo      ! j
1669         enddo        ! iint
1670       enddo          ! i
1671 C      enddo          ! zshift
1672 C      enddo          ! yshift
1673 C      enddo          ! xshift
1674 c      write (iout,*) "Number of loop steps in EGB:",ind
1675 cccc      energy_dec=.false.
1676       return
1677       end
1678 C-----------------------------------------------------------------------------
1679       subroutine egbv(evdw)
1680 C
1681 C This subroutine calculates the interaction energy of nonbonded side chains
1682 C assuming the Gay-Berne-Vorobjev potential of interaction.
1683 C
1684       implicit real*8 (a-h,o-z)
1685       include 'DIMENSIONS'
1686       include 'COMMON.GEO'
1687       include 'COMMON.VAR'
1688       include 'COMMON.LOCAL'
1689       include 'COMMON.CHAIN'
1690       include 'COMMON.DERIV'
1691       include 'COMMON.NAMES'
1692       include 'COMMON.INTERACT'
1693       include 'COMMON.IOUNITS'
1694       include 'COMMON.CALC'
1695       common /srutu/ icall
1696       logical lprn
1697       evdw=0.0D0
1698 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1699       evdw=0.0D0
1700       lprn=.false.
1701 c     if (icall.eq.0) lprn=.true.
1702       ind=0
1703       do i=iatsc_s,iatsc_e
1704         itypi=iabs(itype(i))
1705         if (itypi.eq.ntyp1) cycle
1706         itypi1=iabs(itype(i+1))
1707         xi=c(1,nres+i)
1708         yi=c(2,nres+i)
1709         zi=c(3,nres+i)
1710         dxi=dc_norm(1,nres+i)
1711         dyi=dc_norm(2,nres+i)
1712         dzi=dc_norm(3,nres+i)
1713 c        dsci_inv=dsc_inv(itypi)
1714         dsci_inv=vbld_inv(i+nres)
1715 C
1716 C Calculate SC interaction energy.
1717 C
1718         do iint=1,nint_gr(i)
1719           do j=istart(i,iint),iend(i,iint)
1720             ind=ind+1
1721             itypj=iabs(itype(j))
1722             if (itypj.eq.ntyp1) cycle
1723 c            dscj_inv=dsc_inv(itypj)
1724             dscj_inv=vbld_inv(j+nres)
1725             sig0ij=sigma(itypi,itypj)
1726             r0ij=r0(itypi,itypj)
1727             chi1=chi(itypi,itypj)
1728             chi2=chi(itypj,itypi)
1729             chi12=chi1*chi2
1730             chip1=chip(itypi)
1731             chip2=chip(itypj)
1732             chip12=chip1*chip2
1733             alf1=alp(itypi)
1734             alf2=alp(itypj)
1735             alf12=0.5D0*(alf1+alf2)
1736 C For diagnostics only!!!
1737 c           chi1=0.0D0
1738 c           chi2=0.0D0
1739 c           chi12=0.0D0
1740 c           chip1=0.0D0
1741 c           chip2=0.0D0
1742 c           chip12=0.0D0
1743 c           alf1=0.0D0
1744 c           alf2=0.0D0
1745 c           alf12=0.0D0
1746             xj=c(1,nres+j)-xi
1747             yj=c(2,nres+j)-yi
1748             zj=c(3,nres+j)-zi
1749             dxj=dc_norm(1,nres+j)
1750             dyj=dc_norm(2,nres+j)
1751             dzj=dc_norm(3,nres+j)
1752             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1753             rij=dsqrt(rrij)
1754 C Calculate angle-dependent terms of energy and contributions to their
1755 C derivatives.
1756             call sc_angular
1757             sigsq=1.0D0/sigsq
1758             sig=sig0ij*dsqrt(sigsq)
1759             rij_shift=1.0D0/rij-sig+r0ij
1760 C I hate to put IF's in the loops, but here don't have another choice!!!!
1761             if (rij_shift.le.0.0D0) then
1762               evdw=1.0D20
1763               return
1764             endif
1765             sigder=-sig*sigsq
1766 c---------------------------------------------------------------
1767             rij_shift=1.0D0/rij_shift
1768             fac=rij_shift**expon
1769             e1=fac*fac*aa(itypi,itypj)
1770             e2=fac*bb(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             fac_augm=rrij**expon
1775             e_augm=augm(itypi,itypj)*fac_augm
1776             evdwij=evdwij*eps2rt*eps3rt
1777             evdw=evdw+evdwij+e_augm
1778             if (lprn) then
1779             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1780             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1781             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1782      &        restyp(itypi),i,restyp(itypj),j,
1783      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1784      &        chi1,chi2,chip1,chip2,
1785      &        eps1,eps2rt**2,eps3rt**2,
1786      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1787      &        evdwij+e_augm
1788             endif
1789 C Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac-2*expon*rrij*e_augm
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799             call sc_grad
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803       end
1804 C-----------------------------------------------------------------------------
1805       subroutine sc_angular
1806 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1807 C om12. Called by ebp, egb, and egbv.
1808       implicit none
1809       include 'COMMON.CALC'
1810       include 'COMMON.IOUNITS'
1811       erij(1)=xj*rij
1812       erij(2)=yj*rij
1813       erij(3)=zj*rij
1814       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1815       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1816       om12=dxi*dxj+dyi*dyj+dzi*dzj
1817       chiom12=chi12*om12
1818 C Calculate eps1(om12) and its derivative in om12
1819       faceps1=1.0D0-om12*chiom12
1820       faceps1_inv=1.0D0/faceps1
1821       eps1=dsqrt(faceps1_inv)
1822 C Following variable is eps1*deps1/dom12
1823       eps1_om12=faceps1_inv*chiom12
1824 c diagnostics only
1825 c      faceps1_inv=om12
1826 c      eps1=om12
1827 c      eps1_om12=1.0d0
1828 c      write (iout,*) "om12",om12," eps1",eps1
1829 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1830 C and om12.
1831       om1om2=om1*om2
1832       chiom1=chi1*om1
1833       chiom2=chi2*om2
1834       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1835       sigsq=1.0D0-facsig*faceps1_inv
1836       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1837       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1838       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1839 c diagnostics only
1840 c      sigsq=1.0d0
1841 c      sigsq_om1=0.0d0
1842 c      sigsq_om2=0.0d0
1843 c      sigsq_om12=0.0d0
1844 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1845 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1846 c     &    " eps1",eps1
1847 C Calculate eps2 and its derivatives in om1, om2, and om12.
1848       chipom1=chip1*om1
1849       chipom2=chip2*om2
1850       chipom12=chip12*om12
1851       facp=1.0D0-om12*chipom12
1852       facp_inv=1.0D0/facp
1853       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1854 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1855 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1856 C Following variable is the square root of eps2
1857       eps2rt=1.0D0-facp1*facp_inv
1858 C Following three variables are the derivatives of the square root of eps
1859 C in om1, om2, and om12.
1860       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1861       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1862       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1863 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1864       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1865 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1866 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1867 c     &  " eps2rt_om12",eps2rt_om12
1868 C Calculate whole angle-dependent part of epsilon and contributions
1869 C to its derivatives
1870       return
1871       end
1872 C----------------------------------------------------------------------------
1873       subroutine sc_grad
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CHAIN'
1877       include 'COMMON.DERIV'
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       double precision dcosom1(3),dcosom2(3)
1881 cc      print *,'sss=',sss
1882       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1883       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1884       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1885      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1886 c diagnostics only
1887 c      eom1=0.0d0
1888 c      eom2=0.0d0
1889 c      eom12=evdwij*eps1_om12
1890 c end diagnostics
1891 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1892 c     &  " sigder",sigder
1893 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1894 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1895       do k=1,3
1896         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1897         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1898       enddo
1899       do k=1,3
1900         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1901       enddo
1902 c      write (iout,*) "gg",(gg(k),k=1,3)
1903       do k=1,3
1904         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1905      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1906      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1907         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1908      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1910 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1911 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1912 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914       enddo
1915 C
1916 C Calculate the components of the gradient in DC and X
1917 C
1918 cgrad      do k=i,j-1
1919 cgrad        do l=1,3
1920 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1921 cgrad        enddo
1922 cgrad      enddo
1923       do l=1,3
1924         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1925         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1926       enddo
1927       return
1928       end
1929 C-----------------------------------------------------------------------
1930       subroutine e_softsphere(evdw)
1931 C
1932 C This subroutine calculates the interaction energy of nonbonded side chains
1933 C assuming the LJ potential of interaction.
1934 C
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937       parameter (accur=1.0d-10)
1938       include 'COMMON.GEO'
1939       include 'COMMON.VAR'
1940       include 'COMMON.LOCAL'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.INTERACT'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.SBRIDGE'
1946       include 'COMMON.NAMES'
1947       include 'COMMON.IOUNITS'
1948       include 'COMMON.CONTACTS'
1949       dimension gg(3)
1950 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1951       evdw=0.0D0
1952       do i=iatsc_s,iatsc_e
1953         itypi=iabs(itype(i))
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1964 cd   &                  'iend=',iend(i,iint)
1965           do j=istart(i,iint),iend(i,iint)
1966             itypj=iabs(itype(j))
1967             if (itypj.eq.ntyp1) cycle
1968             xj=c(1,nres+j)-xi
1969             yj=c(2,nres+j)-yi
1970             zj=c(3,nres+j)-zi
1971             rij=xj*xj+yj*yj+zj*zj
1972 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1973             r0ij=r0(itypi,itypj)
1974             r0ijsq=r0ij*r0ij
1975 c            print *,i,j,r0ij,dsqrt(rij)
1976             if (rij.lt.r0ijsq) then
1977               evdwij=0.25d0*(rij-r0ijsq)**2
1978               fac=rij-r0ijsq
1979             else
1980               evdwij=0.0d0
1981               fac=0.0d0
1982             endif
1983             evdw=evdw+evdwij
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987             gg(1)=xj*fac
1988             gg(2)=yj*fac
1989             gg(3)=zj*fac
1990             do k=1,3
1991               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1992               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1993               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1994               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1995             enddo
1996 cgrad            do k=i,j-1
1997 cgrad              do l=1,3
1998 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1999 cgrad              enddo
2000 cgrad            enddo
2001           enddo ! j
2002         enddo ! iint
2003       enddo ! i
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2008      &              eello_turn4)
2009 C
2010 C Soft-sphere potential of p-p interaction
2011 C
2012       implicit real*8 (a-h,o-z)
2013       include 'DIMENSIONS'
2014       include 'COMMON.CONTROL'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.GEO'
2017       include 'COMMON.VAR'
2018       include 'COMMON.LOCAL'
2019       include 'COMMON.CHAIN'
2020       include 'COMMON.DERIV'
2021       include 'COMMON.INTERACT'
2022       include 'COMMON.CONTACTS'
2023       include 'COMMON.TORSION'
2024       include 'COMMON.VECTORS'
2025       include 'COMMON.FFIELD'
2026       dimension ggg(3)
2027 C      write(iout,*) 'In EELEC_soft_sphere'
2028       ees=0.0D0
2029       evdw1=0.0D0
2030       eel_loc=0.0d0
2031       eello_turn3=0.0d0
2032       eello_turn4=0.0d0
2033       ind=0
2034       do i=iatel_s,iatel_e
2035         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2036         dxi=dc(1,i)
2037         dyi=dc(2,i)
2038         dzi=dc(3,i)
2039         xmedi=c(1,i)+0.5d0*dxi
2040         ymedi=c(2,i)+0.5d0*dyi
2041         zmedi=c(3,i)+0.5d0*dzi
2042           xmedi=mod(xmedi,boxxsize)
2043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2044           ymedi=mod(ymedi,boxysize)
2045           if (ymedi.lt.0) ymedi=ymedi+boxysize
2046           zmedi=mod(zmedi,boxzsize)
2047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2048         num_conti=0
2049 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2050         do j=ielstart(i),ielend(i)
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2052           ind=ind+1
2053           iteli=itel(i)
2054           itelj=itel(j)
2055           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2056           r0ij=rpp(iteli,itelj)
2057           r0ijsq=r0ij*r0ij
2058           dxj=dc(1,j)
2059           dyj=dc(2,j)
2060           dzj=dc(3,j)
2061           xj=c(1,j)+0.5D0*dxj
2062           yj=c(2,j)+0.5D0*dyj
2063           zj=c(3,j)+0.5D0*dzj
2064           xj=mod(xj,boxxsize)
2065           if (xj.lt.0) xj=xj+boxxsize
2066           yj=mod(yj,boxysize)
2067           if (yj.lt.0) yj=yj+boxysize
2068           zj=mod(zj,boxzsize)
2069           if (zj.lt.0) zj=zj+boxzsize
2070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2071       xj_safe=xj
2072       yj_safe=yj
2073       zj_safe=zj
2074       isubchap=0
2075       do xshift=-1,1
2076       do yshift=-1,1
2077       do zshift=-1,1
2078           xj=xj_safe+xshift*boxxsize
2079           yj=yj_safe+yshift*boxysize
2080           zj=zj_safe+zshift*boxzsize
2081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2082           if(dist_temp.lt.dist_init) then
2083             dist_init=dist_temp
2084             xj_temp=xj
2085             yj_temp=yj
2086             zj_temp=zj
2087             isubchap=1
2088           endif
2089        enddo
2090        enddo
2091        enddo
2092        if (isubchap.eq.1) then
2093           xj=xj_temp-xmedi
2094           yj=yj_temp-ymedi
2095           zj=zj_temp-zmedi
2096        else
2097           xj=xj_safe-xmedi
2098           yj=yj_safe-ymedi
2099           zj=zj_safe-zmedi
2100        endif
2101           rij=xj*xj+yj*yj+zj*zj
2102             sss=sscale(sqrt(rij))
2103             sssgrad=sscagrad(sqrt(rij))
2104           if (rij.lt.r0ijsq) then
2105             evdw1ij=0.25d0*(rij-r0ijsq)**2
2106             fac=rij-r0ijsq
2107           else
2108             evdw1ij=0.0d0
2109             fac=0.0d0
2110           endif
2111           evdw1=evdw1+evdw1ij*sss
2112 C
2113 C Calculate contributions to the Cartesian gradient.
2114 C
2115           ggg(1)=fac*xj*sssgrad
2116           ggg(2)=fac*yj*sssgrad
2117           ggg(3)=fac*zj*sssgrad
2118           do k=1,3
2119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2120             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2121           enddo
2122 *
2123 * Loop over residues i+1 thru j-1.
2124 *
2125 cgrad          do k=i+1,j-1
2126 cgrad            do l=1,3
2127 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2128 cgrad            enddo
2129 cgrad          enddo
2130         enddo ! j
2131       enddo   ! i
2132 cgrad      do i=nnt,nct-1
2133 cgrad        do k=1,3
2134 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2135 cgrad        enddo
2136 cgrad        do j=i+1,nct-1
2137 cgrad          do k=1,3
2138 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2139 cgrad          enddo
2140 cgrad        enddo
2141 cgrad      enddo
2142       return
2143       end
2144 c------------------------------------------------------------------------------
2145       subroutine vec_and_deriv
2146       implicit real*8 (a-h,o-z)
2147       include 'DIMENSIONS'
2148 #ifdef MPI
2149       include 'mpif.h'
2150 #endif
2151       include 'COMMON.IOUNITS'
2152       include 'COMMON.GEO'
2153       include 'COMMON.VAR'
2154       include 'COMMON.LOCAL'
2155       include 'COMMON.CHAIN'
2156       include 'COMMON.VECTORS'
2157       include 'COMMON.SETUP'
2158       include 'COMMON.TIME1'
2159       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2160 C Compute the local reference systems. For reference system (i), the
2161 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2162 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2163 #ifdef PARVEC
2164       do i=ivec_start,ivec_end
2165 #else
2166       do i=1,nres-1
2167 #endif
2168           if (i.eq.nres-1) then
2169 C Case of the last full residue
2170 C Compute the Z-axis
2171             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2172             costh=dcos(pi-theta(nres))
2173             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2174             do k=1,3
2175               uz(k,i)=fac*uz(k,i)
2176             enddo
2177 C Compute the derivatives of uz
2178             uzder(1,1,1)= 0.0d0
2179             uzder(2,1,1)=-dc_norm(3,i-1)
2180             uzder(3,1,1)= dc_norm(2,i-1)
2181             uzder(1,2,1)= dc_norm(3,i-1)
2182             uzder(2,2,1)= 0.0d0
2183             uzder(3,2,1)=-dc_norm(1,i-1)
2184             uzder(1,3,1)=-dc_norm(2,i-1)
2185             uzder(2,3,1)= dc_norm(1,i-1)
2186             uzder(3,3,1)= 0.0d0
2187             uzder(1,1,2)= 0.0d0
2188             uzder(2,1,2)= dc_norm(3,i)
2189             uzder(3,1,2)=-dc_norm(2,i)
2190             uzder(1,2,2)=-dc_norm(3,i)
2191             uzder(2,2,2)= 0.0d0
2192             uzder(3,2,2)= dc_norm(1,i)
2193             uzder(1,3,2)= dc_norm(2,i)
2194             uzder(2,3,2)=-dc_norm(1,i)
2195             uzder(3,3,2)= 0.0d0
2196 C Compute the Y-axis
2197             facy=fac
2198             do k=1,3
2199               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2200             enddo
2201 C Compute the derivatives of uy
2202             do j=1,3
2203               do k=1,3
2204                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2205      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2206                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2207               enddo
2208               uyder(j,j,1)=uyder(j,j,1)-costh
2209               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2210             enddo
2211             do j=1,2
2212               do k=1,3
2213                 do l=1,3
2214                   uygrad(l,k,j,i)=uyder(l,k,j)
2215                   uzgrad(l,k,j,i)=uzder(l,k,j)
2216                 enddo
2217               enddo
2218             enddo
2219             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2220             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2221             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2222             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2223           else
2224 C Other residues
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2227             costh=dcos(pi-theta(i+2))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i+1)
2235             uzder(3,1,1)= dc_norm(2,i+1)
2236             uzder(1,2,1)= dc_norm(3,i+1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i+1)
2239             uzder(1,3,1)=-dc_norm(2,i+1)
2240             uzder(2,3,1)= dc_norm(1,i+1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           endif
2279       enddo
2280       do i=1,nres-1
2281         vbld_inv_temp(1)=vbld_inv(i+1)
2282         if (i.lt.nres-1) then
2283           vbld_inv_temp(2)=vbld_inv(i+2)
2284           else
2285           vbld_inv_temp(2)=vbld_inv(i)
2286           endif
2287         do j=1,2
2288           do k=1,3
2289             do l=1,3
2290               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2291               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2292             enddo
2293           enddo
2294         enddo
2295       enddo
2296 #if defined(PARVEC) && defined(MPI)
2297       if (nfgtasks1.gt.1) then
2298         time00=MPI_Wtime()
2299 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2300 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2301 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2302         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2303      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2304      &   FG_COMM1,IERR)
2305         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2306      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2307      &   FG_COMM1,IERR)
2308         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2310      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2311         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2312      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2313      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         time_gather=time_gather+MPI_Wtime()-time00
2315       endif
2316 c      if (fg_rank.eq.0) then
2317 c        write (iout,*) "Arrays UY and UZ"
2318 c        do i=1,nres-1
2319 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2320 c     &     (uz(k,i),k=1,3)
2321 c        enddo
2322 c      endif
2323 #endif
2324       return
2325       end
2326 C-----------------------------------------------------------------------------
2327       subroutine check_vecgrad
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.VECTORS'
2336       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2337       dimension uyt(3,maxres),uzt(3,maxres)
2338       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2339       double precision delta /1.0d-7/
2340       call vec_and_deriv
2341 cd      do i=1,nres
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2344 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2345 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2346 cd     &     (dc_norm(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2348 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2349 cd          write(iout,'(a)')
2350 cd      enddo
2351       do i=1,nres
2352         do j=1,2
2353           do k=1,3
2354             do l=1,3
2355               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2356               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2357             enddo
2358           enddo
2359         enddo
2360       enddo
2361       call vec_and_deriv
2362       do i=1,nres
2363         do j=1,3
2364           uyt(j,i)=uy(j,i)
2365           uzt(j,i)=uz(j,i)
2366         enddo
2367       enddo
2368       do i=1,nres
2369 cd        write (iout,*) 'i=',i
2370         do k=1,3
2371           erij(k)=dc_norm(k,i)
2372         enddo
2373         do j=1,3
2374           do k=1,3
2375             dc_norm(k,i)=erij(k)
2376           enddo
2377           dc_norm(j,i)=dc_norm(j,i)+delta
2378 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2379 c          do k=1,3
2380 c            dc_norm(k,i)=dc_norm(k,i)/fac
2381 c          enddo
2382 c          write (iout,*) (dc_norm(k,i),k=1,3)
2383 c          write (iout,*) (erij(k),k=1,3)
2384           call vec_and_deriv
2385           do k=1,3
2386             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2387             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2388             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2389             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2390           enddo
2391 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2392 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2393 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2394         enddo
2395         do k=1,3
2396           dc_norm(k,i)=erij(k)
2397         enddo
2398 cd        do k=1,3
2399 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2400 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2401 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2402 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2403 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2404 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2405 cd          write (iout,'(a)')
2406 cd        enddo
2407       enddo
2408       return
2409       end
2410 C--------------------------------------------------------------------------
2411       subroutine set_matrices
2412       implicit real*8 (a-h,o-z)
2413       include 'DIMENSIONS'
2414 #ifdef MPI
2415       include "mpif.h"
2416       include "COMMON.SETUP"
2417       integer IERR
2418       integer status(MPI_STATUS_SIZE)
2419 #endif
2420       include 'COMMON.IOUNITS'
2421       include 'COMMON.GEO'
2422       include 'COMMON.VAR'
2423       include 'COMMON.LOCAL'
2424       include 'COMMON.CHAIN'
2425       include 'COMMON.DERIV'
2426       include 'COMMON.INTERACT'
2427       include 'COMMON.CONTACTS'
2428       include 'COMMON.TORSION'
2429       include 'COMMON.VECTORS'
2430       include 'COMMON.FFIELD'
2431       double precision auxvec(2),auxmat(2,2)
2432 C
2433 C Compute the virtual-bond-torsional-angle dependent quantities needed
2434 C to calculate the el-loc multibody terms of various order.
2435 C
2436 c      write(iout,*) 'nphi=',nphi,nres
2437 #ifdef PARMAT
2438       do i=ivec_start+2,ivec_end+2
2439 #else
2440       do i=3,nres+1
2441 #endif
2442 #ifdef NEWCORR
2443         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2444           iti = itortyp(itype(i-2))
2445         else
2446           iti=ntortyp+1
2447         endif
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           iti1 = itortyp(itype(i-1))
2451         else
2452           iti1=ntortyp+1
2453         endif
2454 c        write(iout,*),i
2455         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2456      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2457      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2458         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2459      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2460      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2461 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2462 c     &*(cos(theta(i)/2.0)
2463         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2464      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2465      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2466 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2467 c     &*(cos(theta(i)/2.0)
2468         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2469      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2470      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2471 c        if (ggb1(1,i).eq.0.0d0) then
2472 c        write(iout,*) 'i=',i,ggb1(1,i),
2473 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2474 c     &bnew1(2,1,iti)*cos(theta(i)),
2475 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2476 c        endif
2477         b1(2,i-2)=bnew1(1,2,iti)
2478         gtb1(2,i-2)=0.0
2479         b2(2,i-2)=bnew2(1,2,iti)
2480         gtb2(2,i-2)=0.0
2481         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2482         EE(1,2,i-2)=eeold(1,2,iti)
2483         EE(2,1,i-2)=eeold(2,1,iti)
2484         EE(2,2,i-2)=eeold(2,2,iti)
2485         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2486         gtEE(1,2,i-2)=0.0d0
2487         gtEE(2,2,i-2)=0.0d0
2488         gtEE(2,1,i-2)=0.0d0
2489 c        EE(2,2,iti)=0.0d0
2490 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2491 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2492 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2494        b1tilde(1,i-2)=b1(1,i-2)
2495        b1tilde(2,i-2)=-b1(2,i-2)
2496        b2tilde(1,i-2)=b2(1,i-2)
2497        b2tilde(2,i-2)=-b2(2,i-2)
2498 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2499 c       write(iout,*)  'b1=',b1(1,i-2)
2500 c       write (iout,*) 'theta=', theta(i-1)
2501        enddo
2502 #else
2503         b1(1,i-2)=b(3,iti)
2504         b1(2,i-2)=b(5,iti)
2505         b2(1,i-2)=b(2,iti)
2506         b2(2,i-2)=b(4,iti)
2507        b1tilde(1,i-2)=b1(1,i-2)
2508        b1tilde(2,i-2)=-b1(2,i-2)
2509        b2tilde(1,i-2)=b2(1,i-2)
2510        b2tilde(2,i-2)=-b2(2,i-2)
2511         EE(1,2,i-2)=eeold(1,2,iti)
2512         EE(2,1,i-2)=eeold(2,1,iti)
2513         EE(2,2,i-2)=eeold(2,2,iti)
2514         EE(1,1,i-2)=eeold(1,1,iti)
2515       enddo
2516 #endif
2517 #ifdef PARMAT
2518       do i=ivec_start+2,ivec_end+2
2519 #else
2520       do i=3,nres+1
2521 #endif
2522         if (i .lt. nres+1) then
2523           sin1=dsin(phi(i))
2524           cos1=dcos(phi(i))
2525           sintab(i-2)=sin1
2526           costab(i-2)=cos1
2527           obrot(1,i-2)=cos1
2528           obrot(2,i-2)=sin1
2529           sin2=dsin(2*phi(i))
2530           cos2=dcos(2*phi(i))
2531           sintab2(i-2)=sin2
2532           costab2(i-2)=cos2
2533           obrot2(1,i-2)=cos2
2534           obrot2(2,i-2)=sin2
2535           Ug(1,1,i-2)=-cos1
2536           Ug(1,2,i-2)=-sin1
2537           Ug(2,1,i-2)=-sin1
2538           Ug(2,2,i-2)= cos1
2539           Ug2(1,1,i-2)=-cos2
2540           Ug2(1,2,i-2)=-sin2
2541           Ug2(2,1,i-2)=-sin2
2542           Ug2(2,2,i-2)= cos2
2543         else
2544           costab(i-2)=1.0d0
2545           sintab(i-2)=0.0d0
2546           obrot(1,i-2)=1.0d0
2547           obrot(2,i-2)=0.0d0
2548           obrot2(1,i-2)=0.0d0
2549           obrot2(2,i-2)=0.0d0
2550           Ug(1,1,i-2)=1.0d0
2551           Ug(1,2,i-2)=0.0d0
2552           Ug(2,1,i-2)=0.0d0
2553           Ug(2,2,i-2)=1.0d0
2554           Ug2(1,1,i-2)=0.0d0
2555           Ug2(1,2,i-2)=0.0d0
2556           Ug2(2,1,i-2)=0.0d0
2557           Ug2(2,2,i-2)=0.0d0
2558         endif
2559         if (i .gt. 3 .and. i .lt. nres+1) then
2560           obrot_der(1,i-2)=-sin1
2561           obrot_der(2,i-2)= cos1
2562           Ugder(1,1,i-2)= sin1
2563           Ugder(1,2,i-2)=-cos1
2564           Ugder(2,1,i-2)=-cos1
2565           Ugder(2,2,i-2)=-sin1
2566           dwacos2=cos2+cos2
2567           dwasin2=sin2+sin2
2568           obrot2_der(1,i-2)=-dwasin2
2569           obrot2_der(2,i-2)= dwacos2
2570           Ug2der(1,1,i-2)= dwasin2
2571           Ug2der(1,2,i-2)=-dwacos2
2572           Ug2der(2,1,i-2)=-dwacos2
2573           Ug2der(2,2,i-2)=-dwasin2
2574         else
2575           obrot_der(1,i-2)=0.0d0
2576           obrot_der(2,i-2)=0.0d0
2577           Ugder(1,1,i-2)=0.0d0
2578           Ugder(1,2,i-2)=0.0d0
2579           Ugder(2,1,i-2)=0.0d0
2580           Ugder(2,2,i-2)=0.0d0
2581           obrot2_der(1,i-2)=0.0d0
2582           obrot2_der(2,i-2)=0.0d0
2583           Ug2der(1,1,i-2)=0.0d0
2584           Ug2der(1,2,i-2)=0.0d0
2585           Ug2der(2,1,i-2)=0.0d0
2586           Ug2der(2,2,i-2)=0.0d0
2587         endif
2588 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2589         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2590           iti = itortyp(itype(i-2))
2591         else
2592           iti=ntortyp
2593         endif
2594 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2595         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2596           iti1 = itortyp(itype(i-1))
2597         else
2598           iti1=ntortyp
2599         endif
2600 cd        write (iout,*) '*******i',i,' iti1',iti
2601 cd        write (iout,*) 'b1',b1(:,iti)
2602 cd        write (iout,*) 'b2',b2(:,iti)
2603 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2604 c        if (i .gt. iatel_s+2) then
2605         if (i .gt. nnt+2) then
2606           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2607 #ifdef NEWCORR
2608           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2609 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2610 #endif
2611 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2612 c     &    EE(1,2,iti),EE(2,2,iti)
2613           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2614           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2615 c          write(iout,*) "Macierz EUG",
2616 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2617 c     &    eug(2,2,i-2)
2618           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2619      &    then
2620           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2621           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2622           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2623           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2624           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2625           endif
2626         else
2627           do k=1,2
2628             Ub2(k,i-2)=0.0d0
2629             Ctobr(k,i-2)=0.0d0
2630             Dtobr2(k,i-2)=0.0d0
2631             do l=1,2
2632               EUg(l,k,i-2)=0.0d0
2633               CUg(l,k,i-2)=0.0d0
2634               DUg(l,k,i-2)=0.0d0
2635               DtUg2(l,k,i-2)=0.0d0
2636             enddo
2637           enddo
2638         endif
2639         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2640         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2641         do k=1,2
2642           muder(k,i-2)=Ub2der(k,i-2)
2643         enddo
2644 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2645         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2646           if (itype(i-1).le.ntyp) then
2647             iti1 = itortyp(itype(i-1))
2648           else
2649             iti1=ntortyp
2650           endif
2651         else
2652           iti1=ntortyp
2653         endif
2654         do k=1,2
2655           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2656         enddo
2657 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2658 cd        write (iout,*) 'mu1',mu1(:,i-2)
2659 cd        write (iout,*) 'mu2',mu2(:,i-2)
2660         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2661      &  then
2662         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2663         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2664         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2665         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2666         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2667 C Vectors and matrices dependent on a single virtual-bond dihedral.
2668         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2669         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2670         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2671         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2672         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2673         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2674         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2675         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2676         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2677         endif
2678       enddo
2679 C Matrices dependent on two consecutive virtual-bond dihedrals.
2680 C The order of matrices is from left to right.
2681       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2682      &then
2683 c      do i=max0(ivec_start,2),ivec_end
2684       do i=2,nres-1
2685         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2686         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2687         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2688         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2689         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2690         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2691         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2692         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2693       enddo
2694       endif
2695 #if defined(MPI) && defined(PARMAT)
2696 #ifdef DEBUG
2697 c      if (fg_rank.eq.0) then
2698         write (iout,*) "Arrays UG and UGDER before GATHER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2701      &     ((ug(l,k,i),l=1,2),k=1,2),
2702      &     ((ugder(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays UG2 and UG2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2707      &     ((ug2(l,k,i),l=1,2),k=1,2),
2708      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2713      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2714      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2715         enddo
2716         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2717         do i=1,nres-1
2718           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2719      &     costab(i),sintab(i),costab2(i),sintab2(i)
2720         enddo
2721         write (iout,*) "Array MUDER"
2722         do i=1,nres-1
2723           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2724         enddo
2725 c      endif
2726 #endif
2727       if (nfgtasks.gt.1) then
2728         time00=MPI_Wtime()
2729 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2730 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2731 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2732 #ifdef MATGATHER
2733         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2758      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2759      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2760         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2761      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2762      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2763         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2764      &  then
2765         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2800      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2803      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2804      &   FG_COMM1,IERR)
2805         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2806      &   ivec_count(fg_rank1),
2807      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2817      &   FG_COMM1,IERR)
2818        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2820      &   FG_COMM1,IERR)
2821         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2822      &   ivec_count(fg_rank1),
2823      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2824      &   FG_COMM1,IERR)
2825         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2826      &   ivec_count(fg_rank1),
2827      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2828      &   FG_COMM1,IERR)
2829         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2830      &   ivec_count(fg_rank1),
2831      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2832      &   MPI_MAT2,FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2834      &   ivec_count(fg_rank1),
2835      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2836      &   MPI_MAT2,FG_COMM1,IERR)
2837         endif
2838 #else
2839 c Passes matrix info through the ring
2840       isend=fg_rank1
2841       irecv=fg_rank1-1
2842       if (irecv.lt.0) irecv=nfgtasks1-1
2843       iprev=irecv
2844       inext=fg_rank1+1
2845       if (inext.ge.nfgtasks1) inext=0
2846       do i=1,nfgtasks1-1
2847 c        write (iout,*) "isend",isend," irecv",irecv
2848 c        call flush(iout)
2849         lensend=lentyp(isend)
2850         lenrecv=lentyp(irecv)
2851 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2852 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2853 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2854 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2855 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather ROTAT1"
2857 c        call flush(iout)
2858 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2859 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2860 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2861 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather ROTAT2"
2863 c        call flush(iout)
2864         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2865      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2866      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2867      &   iprev,4400+irecv,FG_COMM,status,IERR)
2868 c        write (iout,*) "Gather ROTAT_OLD"
2869 c        call flush(iout)
2870         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2871      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2872      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2873      &   iprev,5500+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP11"
2875 c        call flush(iout)
2876         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2877      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2878      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2879      &   iprev,6600+irecv,FG_COMM,status,IERR)
2880 c        write (iout,*) "Gather PRECOMP12"
2881 c        call flush(iout)
2882         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2883      &  then
2884         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2885      &   MPI_ROTAT2(lensend),inext,7700+isend,
2886      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2887      &   iprev,7700+irecv,FG_COMM,status,IERR)
2888 c        write (iout,*) "Gather PRECOMP21"
2889 c        call flush(iout)
2890         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2891      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2892      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2893      &   iprev,8800+irecv,FG_COMM,status,IERR)
2894 c        write (iout,*) "Gather PRECOMP22"
2895 c        call flush(iout)
2896         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2897      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2898      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2899      &   MPI_PRECOMP23(lenrecv),
2900      &   iprev,9900+irecv,FG_COMM,status,IERR)
2901 c        write (iout,*) "Gather PRECOMP23"
2902 c        call flush(iout)
2903         endif
2904         isend=irecv
2905         irecv=irecv-1
2906         if (irecv.lt.0) irecv=nfgtasks1-1
2907       enddo
2908 #endif
2909         time_gather=time_gather+MPI_Wtime()-time00
2910       endif
2911 #ifdef DEBUG
2912 c      if (fg_rank.eq.0) then
2913         write (iout,*) "Arrays UG and UGDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2916      &     ((ug(l,k,i),l=1,2),k=1,2),
2917      &     ((ugder(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays UG2 and UG2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2922      &     ((ug2(l,k,i),l=1,2),k=1,2),
2923      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2928      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2929      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2930         enddo
2931         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2932         do i=1,nres-1
2933           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2934      &     costab(i),sintab(i),costab2(i),sintab2(i)
2935         enddo
2936         write (iout,*) "Array MUDER"
2937         do i=1,nres-1
2938           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2939         enddo
2940 c      endif
2941 #endif
2942 #endif
2943 cd      do i=1,nres
2944 cd        iti = itortyp(itype(i))
2945 cd        write (iout,*) i
2946 cd        do j=1,2
2947 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2948 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2949 cd        enddo
2950 cd      enddo
2951       return
2952       end
2953 C--------------------------------------------------------------------------
2954       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2955 C
2956 C This subroutine calculates the average interaction energy and its gradient
2957 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2958 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2959 C The potential depends both on the distance of peptide-group centers and on
2960 C the orientation of the CA-CA virtual bonds.
2961 C
2962       implicit real*8 (a-h,o-z)
2963 #ifdef MPI
2964       include 'mpif.h'
2965 #endif
2966       include 'DIMENSIONS'
2967       include 'COMMON.CONTROL'
2968       include 'COMMON.SETUP'
2969       include 'COMMON.IOUNITS'
2970       include 'COMMON.GEO'
2971       include 'COMMON.VAR'
2972       include 'COMMON.LOCAL'
2973       include 'COMMON.CHAIN'
2974       include 'COMMON.DERIV'
2975       include 'COMMON.INTERACT'
2976       include 'COMMON.CONTACTS'
2977       include 'COMMON.TORSION'
2978       include 'COMMON.VECTORS'
2979       include 'COMMON.FFIELD'
2980       include 'COMMON.TIME1'
2981       include 'COMMON.SPLITELE'
2982       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2983      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2984       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2985      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2986       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2987      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2988      &    num_conti,j1,j2
2989 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2990 #ifdef MOMENT
2991       double precision scal_el /1.0d0/
2992 #else
2993       double precision scal_el /0.5d0/
2994 #endif
2995 C 12/13/98
2996 C 13-go grudnia roku pamietnego...
2997       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2998      &                   0.0d0,1.0d0,0.0d0,
2999      &                   0.0d0,0.0d0,1.0d0/
3000 cd      write(iout,*) 'In EELEC'
3001 cd      do i=1,nloctyp
3002 cd        write(iout,*) 'Type',i
3003 cd        write(iout,*) 'B1',B1(:,i)
3004 cd        write(iout,*) 'B2',B2(:,i)
3005 cd        write(iout,*) 'CC',CC(:,:,i)
3006 cd        write(iout,*) 'DD',DD(:,:,i)
3007 cd        write(iout,*) 'EE',EE(:,:,i)
3008 cd      enddo
3009 cd      call check_vecgrad
3010 cd      stop
3011       if (icheckgrad.eq.1) then
3012         do i=1,nres-1
3013           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3014           do k=1,3
3015             dc_norm(k,i)=dc(k,i)*fac
3016           enddo
3017 c          write (iout,*) 'i',i,' fac',fac
3018         enddo
3019       endif
3020       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3021      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3022      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3023 c        call vec_and_deriv
3024 #ifdef TIMING
3025         time01=MPI_Wtime()
3026 #endif
3027         call set_matrices
3028 #ifdef TIMING
3029         time_mat=time_mat+MPI_Wtime()-time01
3030 #endif
3031       endif
3032 cd      do i=1,nres-1
3033 cd        write (iout,*) 'i=',i
3034 cd        do k=1,3
3035 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3036 cd        enddo
3037 cd        do k=1,3
3038 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3039 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3040 cd        enddo
3041 cd      enddo
3042       t_eelecij=0.0d0
3043       ees=0.0D0
3044       evdw1=0.0D0
3045       eel_loc=0.0d0
3046       eello_turn3=0.0d0
3047       eello_turn4=0.0d0
3048       ind=0
3049       do i=1,nres
3050         num_cont_hb(i)=0
3051       enddo
3052 cd      print '(a)','Enter EELEC'
3053 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3054       do i=1,nres
3055         gel_loc_loc(i)=0.0d0
3056         gcorr_loc(i)=0.0d0
3057       enddo
3058 c
3059 c
3060 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3061 C
3062 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3063 C
3064 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3065       do i=iturn3_start,iturn3_end
3066         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3067 C changes suggested by Ana to avoid out of bounds
3068      & .or.((i+4).gt.nres)
3069      & .or.((i-1).le.0)
3070 C end of changes by Ana
3071      &  .or. itype(i+2).eq.ntyp1
3072      &  .or. itype(i+3).eq.ntyp1
3073      &  .or. itype(i-1).eq.ntyp1
3074      &  .or. itype(i+4).eq.ntyp1
3075      &  ) cycle
3076         dxi=dc(1,i)
3077         dyi=dc(2,i)
3078         dzi=dc(3,i)
3079         dx_normi=dc_norm(1,i)
3080         dy_normi=dc_norm(2,i)
3081         dz_normi=dc_norm(3,i)
3082         xmedi=c(1,i)+0.5d0*dxi
3083         ymedi=c(2,i)+0.5d0*dyi
3084         zmedi=c(3,i)+0.5d0*dzi
3085           xmedi=mod(xmedi,boxxsize)
3086           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3087           ymedi=mod(ymedi,boxysize)
3088           if (ymedi.lt.0) ymedi=ymedi+boxysize
3089           zmedi=mod(zmedi,boxzsize)
3090           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3091         num_conti=0
3092         call eelecij(i,i+2,ees,evdw1,eel_loc)
3093         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3094         num_cont_hb(i)=num_conti
3095       enddo
3096       do i=iturn4_start,iturn4_end
3097         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3098 C changes suggested by Ana to avoid out of bounds
3099      & .or.((i+5).gt.nres)
3100      & .or.((i-1).le.0)
3101 C end of changes suggested by Ana
3102      &    .or. itype(i+3).eq.ntyp1
3103      &    .or. itype(i+4).eq.ntyp1
3104      &    .or. itype(i+5).eq.ntyp1
3105      &    .or. itype(i).eq.ntyp1
3106      &    .or. itype(i-1).eq.ntyp1
3107      &                             ) cycle
3108         dxi=dc(1,i)
3109         dyi=dc(2,i)
3110         dzi=dc(3,i)
3111         dx_normi=dc_norm(1,i)
3112         dy_normi=dc_norm(2,i)
3113         dz_normi=dc_norm(3,i)
3114         xmedi=c(1,i)+0.5d0*dxi
3115         ymedi=c(2,i)+0.5d0*dyi
3116         zmedi=c(3,i)+0.5d0*dzi
3117 C Return atom into box, boxxsize is size of box in x dimension
3118 c  194   continue
3119 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3120 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3121 C Condition for being inside the proper box
3122 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3123 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3124 c        go to 194
3125 c        endif
3126 c  195   continue
3127 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3128 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3129 C Condition for being inside the proper box
3130 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3131 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3132 c        go to 195
3133 c        endif
3134 c  196   continue
3135 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3136 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3137 C Condition for being inside the proper box
3138 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3139 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3140 c        go to 196
3141 c        endif
3142           xmedi=mod(xmedi,boxxsize)
3143           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3144           ymedi=mod(ymedi,boxysize)
3145           if (ymedi.lt.0) ymedi=ymedi+boxysize
3146           zmedi=mod(zmedi,boxzsize)
3147           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3148
3149         num_conti=num_cont_hb(i)
3150 c        write(iout,*) "JESTEM W PETLI"
3151         call eelecij(i,i+3,ees,evdw1,eel_loc)
3152         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3153      &   call eturn4(i,eello_turn4)
3154         num_cont_hb(i)=num_conti
3155       enddo   ! i
3156 C Loop over all neighbouring boxes
3157 C      do xshift=-1,1
3158 C      do yshift=-1,1
3159 C      do zshift=-1,1
3160 c
3161 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3162 c
3163       do i=iatel_s,iatel_e
3164         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3165 C changes suggested by Ana to avoid out of bounds
3166      & .or.((i+2).gt.nres)
3167      & .or.((i-1).le.0)
3168 C end of changes by Ana
3169      &  .or. itype(i+2).eq.ntyp1
3170      &  .or. itype(i-1).eq.ntyp1
3171      &                ) cycle
3172         dxi=dc(1,i)
3173         dyi=dc(2,i)
3174         dzi=dc(3,i)
3175         dx_normi=dc_norm(1,i)
3176         dy_normi=dc_norm(2,i)
3177         dz_normi=dc_norm(3,i)
3178         xmedi=c(1,i)+0.5d0*dxi
3179         ymedi=c(2,i)+0.5d0*dyi
3180         zmedi=c(3,i)+0.5d0*dzi
3181           xmedi=mod(xmedi,boxxsize)
3182           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3183           ymedi=mod(ymedi,boxysize)
3184           if (ymedi.lt.0) ymedi=ymedi+boxysize
3185           zmedi=mod(zmedi,boxzsize)
3186           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3187 C          xmedi=xmedi+xshift*boxxsize
3188 C          ymedi=ymedi+yshift*boxysize
3189 C          zmedi=zmedi+zshift*boxzsize
3190
3191 C Return tom into box, boxxsize is size of box in x dimension
3192 c  164   continue
3193 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3194 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3195 C Condition for being inside the proper box
3196 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3197 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3198 c        go to 164
3199 c        endif
3200 c  165   continue
3201 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3202 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3203 C Condition for being inside the proper box
3204 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3205 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3206 c        go to 165
3207 c        endif
3208 c  166   continue
3209 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3210 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3211 cC Condition for being inside the proper box
3212 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3213 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3214 c        go to 166
3215 c        endif
3216
3217 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3218         num_conti=num_cont_hb(i)
3219         do j=ielstart(i),ielend(i)
3220 c          write (iout,*) i,j,itype(i),itype(j)
3221           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3222 C changes suggested by Ana to avoid out of bounds
3223      & .or.((j+2).gt.nres)
3224      & .or.((j-1).le.0)
3225 C end of changes by Ana
3226      & .or.itype(j+2).eq.ntyp1
3227      & .or.itype(j-1).eq.ntyp1
3228      &) cycle
3229           call eelecij(i,j,ees,evdw1,eel_loc)
3230         enddo ! j
3231         num_cont_hb(i)=num_conti
3232       enddo   ! i
3233 C     enddo   ! zshift
3234 C      enddo   ! yshift
3235 C      enddo   ! xshift
3236
3237 c      write (iout,*) "Number of loop steps in EELEC:",ind
3238 cd      do i=1,nres
3239 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3240 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3241 cd      enddo
3242 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3243 ccc      eel_loc=eel_loc+eello_turn3
3244 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3245       return
3246       end
3247 C-------------------------------------------------------------------------------
3248       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3249       implicit real*8 (a-h,o-z)
3250       include 'DIMENSIONS'
3251 #ifdef MPI
3252       include "mpif.h"
3253 #endif
3254       include 'COMMON.CONTROL'
3255       include 'COMMON.IOUNITS'
3256       include 'COMMON.GEO'
3257       include 'COMMON.VAR'
3258       include 'COMMON.LOCAL'
3259       include 'COMMON.CHAIN'
3260       include 'COMMON.DERIV'
3261       include 'COMMON.INTERACT'
3262       include 'COMMON.CONTACTS'
3263       include 'COMMON.TORSION'
3264       include 'COMMON.VECTORS'
3265       include 'COMMON.FFIELD'
3266       include 'COMMON.TIME1'
3267       include 'COMMON.SPLITELE'
3268       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3269      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3270       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3271      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3272      &    gmuij2(4),gmuji2(4)
3273       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3274      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3275      &    num_conti,j1,j2
3276 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3277 #ifdef MOMENT
3278       double precision scal_el /1.0d0/
3279 #else
3280       double precision scal_el /0.5d0/
3281 #endif
3282 C 12/13/98
3283 C 13-go grudnia roku pamietnego...
3284       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3285      &                   0.0d0,1.0d0,0.0d0,
3286      &                   0.0d0,0.0d0,1.0d0/
3287 c          time00=MPI_Wtime()
3288 cd      write (iout,*) "eelecij",i,j
3289 c          ind=ind+1
3290           iteli=itel(i)
3291           itelj=itel(j)
3292           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3293           aaa=app(iteli,itelj)
3294           bbb=bpp(iteli,itelj)
3295           ael6i=ael6(iteli,itelj)
3296           ael3i=ael3(iteli,itelj)
3297           dxj=dc(1,j)
3298           dyj=dc(2,j)
3299           dzj=dc(3,j)
3300           dx_normj=dc_norm(1,j)
3301           dy_normj=dc_norm(2,j)
3302           dz_normj=dc_norm(3,j)
3303 C          xj=c(1,j)+0.5D0*dxj-xmedi
3304 C          yj=c(2,j)+0.5D0*dyj-ymedi
3305 C          zj=c(3,j)+0.5D0*dzj-zmedi
3306           xj=c(1,j)+0.5D0*dxj
3307           yj=c(2,j)+0.5D0*dyj
3308           zj=c(3,j)+0.5D0*dzj
3309           xj=mod(xj,boxxsize)
3310           if (xj.lt.0) xj=xj+boxxsize
3311           yj=mod(yj,boxysize)
3312           if (yj.lt.0) yj=yj+boxysize
3313           zj=mod(zj,boxzsize)
3314           if (zj.lt.0) zj=zj+boxzsize
3315           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3316       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3317       xj_safe=xj
3318       yj_safe=yj
3319       zj_safe=zj
3320       isubchap=0
3321       do xshift=-1,1
3322       do yshift=-1,1
3323       do zshift=-1,1
3324           xj=xj_safe+xshift*boxxsize
3325           yj=yj_safe+yshift*boxysize
3326           zj=zj_safe+zshift*boxzsize
3327           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3328           if(dist_temp.lt.dist_init) then
3329             dist_init=dist_temp
3330             xj_temp=xj
3331             yj_temp=yj
3332             zj_temp=zj
3333             isubchap=1
3334           endif
3335        enddo
3336        enddo
3337        enddo
3338        if (isubchap.eq.1) then
3339           xj=xj_temp-xmedi
3340           yj=yj_temp-ymedi
3341           zj=zj_temp-zmedi
3342        else
3343           xj=xj_safe-xmedi
3344           yj=yj_safe-ymedi
3345           zj=zj_safe-zmedi
3346        endif
3347 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3348 c  174   continue
3349 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3350 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3351 C Condition for being inside the proper box
3352 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3353 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3354 c        go to 174
3355 c        endif
3356 c  175   continue
3357 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3358 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3359 C Condition for being inside the proper box
3360 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3361 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3362 c        go to 175
3363 c        endif
3364 c  176   continue
3365 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3366 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3367 C Condition for being inside the proper box
3368 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3369 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3370 c        go to 176
3371 c        endif
3372 C        endif !endPBC condintion
3373 C        xj=xj-xmedi
3374 C        yj=yj-ymedi
3375 C        zj=zj-zmedi
3376           rij=xj*xj+yj*yj+zj*zj
3377
3378             sss=sscale(sqrt(rij))
3379             sssgrad=sscagrad(sqrt(rij))
3380 c            if (sss.gt.0.0d0) then
3381           rrmij=1.0D0/rij
3382           rij=dsqrt(rij)
3383           rmij=1.0D0/rij
3384           r3ij=rrmij*rmij
3385           r6ij=r3ij*r3ij
3386           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3387           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3388           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3389           fac=cosa-3.0D0*cosb*cosg
3390           ev1=aaa*r6ij*r6ij
3391 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3392           if (j.eq.i+2) ev1=scal_el*ev1
3393           ev2=bbb*r6ij
3394           fac3=ael6i*r6ij
3395           fac4=ael3i*r3ij
3396           evdwij=(ev1+ev2)
3397           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3398           el2=fac4*fac
3399 C MARYSIA
3400           eesij=(el1+el2)
3401 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3402           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3403           ees=ees+eesij
3404           evdw1=evdw1+evdwij*sss
3405 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3406 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3407 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3408 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3409
3410           if (energy_dec) then
3411               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3412      &'evdw1',i,j,evdwij
3413      &,iteli,itelj,aaa,evdw1
3414               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3415           endif
3416
3417 C
3418 C Calculate contributions to the Cartesian gradient.
3419 C
3420 #ifdef SPLITELE
3421           facvdw=-6*rrmij*(ev1+evdwij)*sss
3422           facel=-3*rrmij*(el1+eesij)
3423           fac1=fac
3424           erij(1)=xj*rmij
3425           erij(2)=yj*rmij
3426           erij(3)=zj*rmij
3427 *
3428 * Radial derivatives. First process both termini of the fragment (i,j)
3429 *
3430           ggg(1)=facel*xj
3431           ggg(2)=facel*yj
3432           ggg(3)=facel*zj
3433 c          do k=1,3
3434 c            ghalf=0.5D0*ggg(k)
3435 c            gelc(k,i)=gelc(k,i)+ghalf
3436 c            gelc(k,j)=gelc(k,j)+ghalf
3437 c          enddo
3438 c 9/28/08 AL Gradient compotents will be summed only at the end
3439           do k=1,3
3440             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3441             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3442           enddo
3443 *
3444 * Loop over residues i+1 thru j-1.
3445 *
3446 cgrad          do k=i+1,j-1
3447 cgrad            do l=1,3
3448 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3449 cgrad            enddo
3450 cgrad          enddo
3451           if (sss.gt.0.0) then
3452           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3453           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3454           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3455           else
3456           ggg(1)=0.0
3457           ggg(2)=0.0
3458           ggg(3)=0.0
3459           endif
3460 c          do k=1,3
3461 c            ghalf=0.5D0*ggg(k)
3462 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3463 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3464 c          enddo
3465 c 9/28/08 AL Gradient compotents will be summed only at the end
3466           do k=1,3
3467             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3468             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3469           enddo
3470 *
3471 * Loop over residues i+1 thru j-1.
3472 *
3473 cgrad          do k=i+1,j-1
3474 cgrad            do l=1,3
3475 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3476 cgrad            enddo
3477 cgrad          enddo
3478 #else
3479 C MARYSIA
3480           facvdw=(ev1+evdwij)*sss
3481           facel=(el1+eesij)
3482           fac1=fac
3483           fac=-3*rrmij*(facvdw+facvdw+facel)
3484           erij(1)=xj*rmij
3485           erij(2)=yj*rmij
3486           erij(3)=zj*rmij
3487 *
3488 * Radial derivatives. First process both termini of the fragment (i,j)
3489 *
3490           ggg(1)=fac*xj
3491           ggg(2)=fac*yj
3492           ggg(3)=fac*zj
3493 c          do k=1,3
3494 c            ghalf=0.5D0*ggg(k)
3495 c            gelc(k,i)=gelc(k,i)+ghalf
3496 c            gelc(k,j)=gelc(k,j)+ghalf
3497 c          enddo
3498 c 9/28/08 AL Gradient compotents will be summed only at the end
3499           do k=1,3
3500             gelc_long(k,j)=gelc(k,j)+ggg(k)
3501             gelc_long(k,i)=gelc(k,i)-ggg(k)
3502           enddo
3503 *
3504 * Loop over residues i+1 thru j-1.
3505 *
3506 cgrad          do k=i+1,j-1
3507 cgrad            do l=1,3
3508 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3509 cgrad            enddo
3510 cgrad          enddo
3511 c 9/28/08 AL Gradient compotents will be summed only at the end
3512           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3513           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3514           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3515           do k=1,3
3516             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3517             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3518           enddo
3519 #endif
3520 *
3521 * Angular part
3522 *
3523           ecosa=2.0D0*fac3*fac1+fac4
3524           fac4=-3.0D0*fac4
3525           fac3=-6.0D0*fac3
3526           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3527           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3528           do k=1,3
3529             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3530             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3531           enddo
3532 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3533 cd   &          (dcosg(k),k=1,3)
3534           do k=1,3
3535             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3536           enddo
3537 c          do k=1,3
3538 c            ghalf=0.5D0*ggg(k)
3539 c            gelc(k,i)=gelc(k,i)+ghalf
3540 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3541 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3542 c            gelc(k,j)=gelc(k,j)+ghalf
3543 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3544 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3545 c          enddo
3546 cgrad          do k=i+1,j-1
3547 cgrad            do l=1,3
3548 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3549 cgrad            enddo
3550 cgrad          enddo
3551           do k=1,3
3552             gelc(k,i)=gelc(k,i)
3553      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3554      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3555             gelc(k,j)=gelc(k,j)
3556      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3557      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3558             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3559             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3560           enddo
3561 C MARYSIA
3562 c          endif !sscale
3563           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3564      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3565      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3566 C
3567 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3568 C   energy of a peptide unit is assumed in the form of a second-order
3569 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3570 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3571 C   are computed for EVERY pair of non-contiguous peptide groups.
3572 C
3573
3574           if (j.lt.nres-1) then
3575             j1=j+1
3576             j2=j-1
3577           else
3578             j1=j-1
3579             j2=j-2
3580           endif
3581           kkk=0
3582           lll=0
3583           do k=1,2
3584             do l=1,2
3585               kkk=kkk+1
3586               muij(kkk)=mu(k,i)*mu(l,j)
3587 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3588 #ifdef NEWCORR
3589              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3590 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3591              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3592              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3593 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3594              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3595 #endif
3596             enddo
3597           enddo
3598 cd         write (iout,*) 'EELEC: i',i,' j',j
3599 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3600 cd          write(iout,*) 'muij',muij
3601           ury=scalar(uy(1,i),erij)
3602           urz=scalar(uz(1,i),erij)
3603           vry=scalar(uy(1,j),erij)
3604           vrz=scalar(uz(1,j),erij)
3605           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3606           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3607           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3608           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3609           fac=dsqrt(-ael6i)*r3ij
3610           a22=a22*fac
3611           a23=a23*fac
3612           a32=a32*fac
3613           a33=a33*fac
3614 cd          write (iout,'(4i5,4f10.5)')
3615 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3616 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3617 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3618 cd     &      uy(:,j),uz(:,j)
3619 cd          write (iout,'(4f10.5)')
3620 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3621 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3622 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3623 cd           write (iout,'(9f10.5/)')
3624 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3625 C Derivatives of the elements of A in virtual-bond vectors
3626           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3627           do k=1,3
3628             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3629             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3630             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3631             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3632             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3633             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3634             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3635             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3636             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3637             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3638             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3639             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3640           enddo
3641 C Compute radial contributions to the gradient
3642           facr=-3.0d0*rrmij
3643           a22der=a22*facr
3644           a23der=a23*facr
3645           a32der=a32*facr
3646           a33der=a33*facr
3647           agg(1,1)=a22der*xj
3648           agg(2,1)=a22der*yj
3649           agg(3,1)=a22der*zj
3650           agg(1,2)=a23der*xj
3651           agg(2,2)=a23der*yj
3652           agg(3,2)=a23der*zj
3653           agg(1,3)=a32der*xj
3654           agg(2,3)=a32der*yj
3655           agg(3,3)=a32der*zj
3656           agg(1,4)=a33der*xj
3657           agg(2,4)=a33der*yj
3658           agg(3,4)=a33der*zj
3659 C Add the contributions coming from er
3660           fac3=-3.0d0*fac
3661           do k=1,3
3662             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3663             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3664             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3665             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3666           enddo
3667           do k=1,3
3668 C Derivatives in DC(i)
3669 cgrad            ghalf1=0.5d0*agg(k,1)
3670 cgrad            ghalf2=0.5d0*agg(k,2)
3671 cgrad            ghalf3=0.5d0*agg(k,3)
3672 cgrad            ghalf4=0.5d0*agg(k,4)
3673             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3674      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3675             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3676      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3677             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3678      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3679             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3680      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3681 C Derivatives in DC(i+1)
3682             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3683      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3684             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3685      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3686             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3687      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3688             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3689      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3690 C Derivatives in DC(j)
3691             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3692      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3693             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3694      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3695             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3696      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3697             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3698      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3699 C Derivatives in DC(j+1) or DC(nres-1)
3700             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3701      &      -3.0d0*vryg(k,3)*ury)
3702             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3703      &      -3.0d0*vrzg(k,3)*ury)
3704             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3705      &      -3.0d0*vryg(k,3)*urz)
3706             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3707      &      -3.0d0*vrzg(k,3)*urz)
3708 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3709 cgrad              do l=1,4
3710 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3711 cgrad              enddo
3712 cgrad            endif
3713           enddo
3714           acipa(1,1)=a22
3715           acipa(1,2)=a23
3716           acipa(2,1)=a32
3717           acipa(2,2)=a33
3718           a22=-a22
3719           a23=-a23
3720           do l=1,2
3721             do k=1,3
3722               agg(k,l)=-agg(k,l)
3723               aggi(k,l)=-aggi(k,l)
3724               aggi1(k,l)=-aggi1(k,l)
3725               aggj(k,l)=-aggj(k,l)
3726               aggj1(k,l)=-aggj1(k,l)
3727             enddo
3728           enddo
3729           if (j.lt.nres-1) then
3730             a22=-a22
3731             a32=-a32
3732             do l=1,3,2
3733               do k=1,3
3734                 agg(k,l)=-agg(k,l)
3735                 aggi(k,l)=-aggi(k,l)
3736                 aggi1(k,l)=-aggi1(k,l)
3737                 aggj(k,l)=-aggj(k,l)
3738                 aggj1(k,l)=-aggj1(k,l)
3739               enddo
3740             enddo
3741           else
3742             a22=-a22
3743             a23=-a23
3744             a32=-a32
3745             a33=-a33
3746             do l=1,4
3747               do k=1,3
3748                 agg(k,l)=-agg(k,l)
3749                 aggi(k,l)=-aggi(k,l)
3750                 aggi1(k,l)=-aggi1(k,l)
3751                 aggj(k,l)=-aggj(k,l)
3752                 aggj1(k,l)=-aggj1(k,l)
3753               enddo
3754             enddo
3755           endif
3756           ENDIF ! WCORR
3757           IF (wel_loc.gt.0.0d0) THEN
3758 C Contribution to the local-electrostatic energy coming from the i-j pair
3759           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3760      &     +a33*muij(4)
3761 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3762 c     &                     ' eel_loc_ij',eel_loc_ij
3763 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3764 C Calculate patrial derivative for theta angle
3765 #ifdef NEWCORR
3766          geel_loc_ij=a22*gmuij1(1)
3767      &     +a23*gmuij1(2)
3768      &     +a32*gmuij1(3)
3769      &     +a33*gmuij1(4)
3770 c         write(iout,*) "derivative over thatai"
3771 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3772 c     &   a33*gmuij1(4)
3773          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3774      &      geel_loc_ij*wel_loc
3775 c         write(iout,*) "derivative over thatai-1"
3776 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3777 c     &   a33*gmuij2(4)
3778          geel_loc_ij=
3779      &     a22*gmuij2(1)
3780      &     +a23*gmuij2(2)
3781      &     +a32*gmuij2(3)
3782      &     +a33*gmuij2(4)
3783          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3784      &      geel_loc_ij*wel_loc
3785 c  Derivative over j residue
3786          geel_loc_ji=a22*gmuji1(1)
3787      &     +a23*gmuji1(2)
3788      &     +a32*gmuji1(3)
3789      &     +a33*gmuji1(4)
3790 c         write(iout,*) "derivative over thataj"
3791 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3792 c     &   a33*gmuji1(4)
3793
3794         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3795      &      geel_loc_ji*wel_loc
3796          geel_loc_ji=
3797      &     +a22*gmuji2(1)
3798      &     +a23*gmuji2(2)
3799      &     +a32*gmuji2(3)
3800      &     +a33*gmuji2(4)
3801 c         write(iout,*) "derivative over thataj-1"
3802 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3803 c     &   a33*gmuji2(4)
3804          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3805      &      geel_loc_ji*wel_loc
3806 #endif
3807 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3808
3809           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3810      &            'eelloc',i,j,eel_loc_ij
3811 c           if (eel_loc_ij.ne.0)
3812 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3813 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3814
3815           eel_loc=eel_loc+eel_loc_ij
3816 C Partial derivatives in virtual-bond dihedral angles gamma
3817           if (i.gt.1)
3818      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3819      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3820      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3821           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3822      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3823      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3824 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3825           do l=1,3
3826             ggg(l)=agg(l,1)*muij(1)+
3827      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3828             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3829             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3830 cgrad            ghalf=0.5d0*ggg(l)
3831 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3832 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3833           enddo
3834 cgrad          do k=i+1,j2
3835 cgrad            do l=1,3
3836 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3837 cgrad            enddo
3838 cgrad          enddo
3839 C Remaining derivatives of eello
3840           do l=1,3
3841             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3842      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3843             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3844      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3845             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3846      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3847             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3848      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3849           enddo
3850           ENDIF
3851 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3852 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3853           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3854      &       .and. num_conti.le.maxconts) then
3855 c            write (iout,*) i,j," entered corr"
3856 C
3857 C Calculate the contact function. The ith column of the array JCONT will
3858 C contain the numbers of atoms that make contacts with the atom I (of numbers
3859 C greater than I). The arrays FACONT and GACONT will contain the values of
3860 C the contact function and its derivative.
3861 c           r0ij=1.02D0*rpp(iteli,itelj)
3862 c           r0ij=1.11D0*rpp(iteli,itelj)
3863             r0ij=2.20D0*rpp(iteli,itelj)
3864 c           r0ij=1.55D0*rpp(iteli,itelj)
3865             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3866             if (fcont.gt.0.0D0) then
3867               num_conti=num_conti+1
3868               if (num_conti.gt.maxconts) then
3869                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3870      &                         ' will skip next contacts for this conf.'
3871               else
3872                 jcont_hb(num_conti,i)=j
3873 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3874 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3875                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3876      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3877 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3878 C  terms.
3879                 d_cont(num_conti,i)=rij
3880 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3881 C     --- Electrostatic-interaction matrix ---
3882                 a_chuj(1,1,num_conti,i)=a22
3883                 a_chuj(1,2,num_conti,i)=a23
3884                 a_chuj(2,1,num_conti,i)=a32
3885                 a_chuj(2,2,num_conti,i)=a33
3886 C     --- Gradient of rij
3887                 do kkk=1,3
3888                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3889                 enddo
3890                 kkll=0
3891                 do k=1,2
3892                   do l=1,2
3893                     kkll=kkll+1
3894                     do m=1,3
3895                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3896                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3897                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3898                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3899                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3900                     enddo
3901                   enddo
3902                 enddo
3903                 ENDIF
3904                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3905 C Calculate contact energies
3906                 cosa4=4.0D0*cosa
3907                 wij=cosa-3.0D0*cosb*cosg
3908                 cosbg1=cosb+cosg
3909                 cosbg2=cosb-cosg
3910 c               fac3=dsqrt(-ael6i)/r0ij**3
3911                 fac3=dsqrt(-ael6i)*r3ij
3912 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3913                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3914                 if (ees0tmp.gt.0) then
3915                   ees0pij=dsqrt(ees0tmp)
3916                 else
3917                   ees0pij=0
3918                 endif
3919 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3920                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3921                 if (ees0tmp.gt.0) then
3922                   ees0mij=dsqrt(ees0tmp)
3923                 else
3924                   ees0mij=0
3925                 endif
3926 c               ees0mij=0.0D0
3927                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3928                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3929 C Diagnostics. Comment out or remove after debugging!
3930 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3931 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3932 c               ees0m(num_conti,i)=0.0D0
3933 C End diagnostics.
3934 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3935 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3936 C Angular derivatives of the contact function
3937                 ees0pij1=fac3/ees0pij
3938                 ees0mij1=fac3/ees0mij
3939                 fac3p=-3.0D0*fac3*rrmij
3940                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3941                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3942 c               ees0mij1=0.0D0
3943                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3944                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3945                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3946                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3947                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3948                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3949                 ecosap=ecosa1+ecosa2
3950                 ecosbp=ecosb1+ecosb2
3951                 ecosgp=ecosg1+ecosg2
3952                 ecosam=ecosa1-ecosa2
3953                 ecosbm=ecosb1-ecosb2
3954                 ecosgm=ecosg1-ecosg2
3955 C Diagnostics
3956 c               ecosap=ecosa1
3957 c               ecosbp=ecosb1
3958 c               ecosgp=ecosg1
3959 c               ecosam=0.0D0
3960 c               ecosbm=0.0D0
3961 c               ecosgm=0.0D0
3962 C End diagnostics
3963                 facont_hb(num_conti,i)=fcont
3964                 fprimcont=fprimcont/rij
3965 cd              facont_hb(num_conti,i)=1.0D0
3966 C Following line is for diagnostics.
3967 cd              fprimcont=0.0D0
3968                 do k=1,3
3969                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3970                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3971                 enddo
3972                 do k=1,3
3973                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3974                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3975                 enddo
3976                 gggp(1)=gggp(1)+ees0pijp*xj
3977                 gggp(2)=gggp(2)+ees0pijp*yj
3978                 gggp(3)=gggp(3)+ees0pijp*zj
3979                 gggm(1)=gggm(1)+ees0mijp*xj
3980                 gggm(2)=gggm(2)+ees0mijp*yj
3981                 gggm(3)=gggm(3)+ees0mijp*zj
3982 C Derivatives due to the contact function
3983                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3984                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3985                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3986                 do k=1,3
3987 c
3988 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3989 c          following the change of gradient-summation algorithm.
3990 c
3991 cgrad                  ghalfp=0.5D0*gggp(k)
3992 cgrad                  ghalfm=0.5D0*gggm(k)
3993                   gacontp_hb1(k,num_conti,i)=!ghalfp
3994      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3995      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3996                   gacontp_hb2(k,num_conti,i)=!ghalfp
3997      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3998      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3999                   gacontp_hb3(k,num_conti,i)=gggp(k)
4000                   gacontm_hb1(k,num_conti,i)=!ghalfm
4001      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4002      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4003                   gacontm_hb2(k,num_conti,i)=!ghalfm
4004      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4005      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4006                   gacontm_hb3(k,num_conti,i)=gggm(k)
4007                 enddo
4008 C Diagnostics. Comment out or remove after debugging!
4009 cdiag           do k=1,3
4010 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4011 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4012 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4013 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4014 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4015 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4016 cdiag           enddo
4017               ENDIF ! wcorr
4018               endif  ! num_conti.le.maxconts
4019             endif  ! fcont.gt.0
4020           endif    ! j.gt.i+1
4021           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4022             do k=1,4
4023               do l=1,3
4024                 ghalf=0.5d0*agg(l,k)
4025                 aggi(l,k)=aggi(l,k)+ghalf
4026                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4027                 aggj(l,k)=aggj(l,k)+ghalf
4028               enddo
4029             enddo
4030             if (j.eq.nres-1 .and. i.lt.j-2) then
4031               do k=1,4
4032                 do l=1,3
4033                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4034                 enddo
4035               enddo
4036             endif
4037           endif
4038 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4039       return
4040       end
4041 C-----------------------------------------------------------------------------
4042       subroutine eturn3(i,eello_turn3)
4043 C Third- and fourth-order contributions from turns
4044       implicit real*8 (a-h,o-z)
4045       include 'DIMENSIONS'
4046       include 'COMMON.IOUNITS'
4047       include 'COMMON.GEO'
4048       include 'COMMON.VAR'
4049       include 'COMMON.LOCAL'
4050       include 'COMMON.CHAIN'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.INTERACT'
4053       include 'COMMON.CONTACTS'
4054       include 'COMMON.TORSION'
4055       include 'COMMON.VECTORS'
4056       include 'COMMON.FFIELD'
4057       include 'COMMON.CONTROL'
4058       dimension ggg(3)
4059       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4060      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4061      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4062      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4063      &  auxgmat2(2,2),auxgmatt2(2,2)
4064       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4065      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4066       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4067      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4068      &    num_conti,j1,j2
4069       j=i+2
4070 c      write (iout,*) "eturn3",i,j,j1,j2
4071       a_temp(1,1)=a22
4072       a_temp(1,2)=a23
4073       a_temp(2,1)=a32
4074       a_temp(2,2)=a33
4075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4076 C
4077 C               Third-order contributions
4078 C
4079 C                 (i+2)o----(i+3)
4080 C                      | |
4081 C                      | |
4082 C                 (i+1)o----i
4083 C
4084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4085 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4086         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4087 c auxalary matices for theta gradient
4088 c auxalary matrix for i+1 and constant i+2
4089         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4090 c auxalary matrix for i+2 and constant i+1
4091         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4092         call transpose2(auxmat(1,1),auxmat1(1,1))
4093         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4094         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4095         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4096         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4097         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4098         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4099 C Derivatives in theta
4100         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4101      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4102         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4103      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4104
4105         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4106      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4107 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4108 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4109 cd     &    ' eello_turn3_num',4*eello_turn3_num
4110 C Derivatives in gamma(i)
4111         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4112         call transpose2(auxmat2(1,1),auxmat3(1,1))
4113         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4114         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4115 C Derivatives in gamma(i+1)
4116         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4117         call transpose2(auxmat2(1,1),auxmat3(1,1))
4118         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4119         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4120      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4121 C Cartesian derivatives
4122         do l=1,3
4123 c            ghalf1=0.5d0*agg(l,1)
4124 c            ghalf2=0.5d0*agg(l,2)
4125 c            ghalf3=0.5d0*agg(l,3)
4126 c            ghalf4=0.5d0*agg(l,4)
4127           a_temp(1,1)=aggi(l,1)!+ghalf1
4128           a_temp(1,2)=aggi(l,2)!+ghalf2
4129           a_temp(2,1)=aggi(l,3)!+ghalf3
4130           a_temp(2,2)=aggi(l,4)!+ghalf4
4131           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4132           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4133      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4134           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4135           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4136           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4137           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4138           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4139           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4140      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4141           a_temp(1,1)=aggj(l,1)!+ghalf1
4142           a_temp(1,2)=aggj(l,2)!+ghalf2
4143           a_temp(2,1)=aggj(l,3)!+ghalf3
4144           a_temp(2,2)=aggj(l,4)!+ghalf4
4145           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4146           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4147      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4148           a_temp(1,1)=aggj1(l,1)
4149           a_temp(1,2)=aggj1(l,2)
4150           a_temp(2,1)=aggj1(l,3)
4151           a_temp(2,2)=aggj1(l,4)
4152           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4153           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4154      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4155         enddo
4156       return
4157       end
4158 C-------------------------------------------------------------------------------
4159       subroutine eturn4(i,eello_turn4)
4160 C Third- and fourth-order contributions from turns
4161       implicit real*8 (a-h,o-z)
4162       include 'DIMENSIONS'
4163       include 'COMMON.IOUNITS'
4164       include 'COMMON.GEO'
4165       include 'COMMON.VAR'
4166       include 'COMMON.LOCAL'
4167       include 'COMMON.CHAIN'
4168       include 'COMMON.DERIV'
4169       include 'COMMON.INTERACT'
4170       include 'COMMON.CONTACTS'
4171       include 'COMMON.TORSION'
4172       include 'COMMON.VECTORS'
4173       include 'COMMON.FFIELD'
4174       include 'COMMON.CONTROL'
4175       dimension ggg(3)
4176       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4177      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4178      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4179      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4180      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4181      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4182      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4183       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4184      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4185       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4186      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4187      &    num_conti,j1,j2
4188       j=i+3
4189 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4190 C
4191 C               Fourth-order contributions
4192 C
4193 C                 (i+3)o----(i+4)
4194 C                     /  |
4195 C               (i+2)o   |
4196 C                     \  |
4197 C                 (i+1)o----i
4198 C
4199 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4200 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4201 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4202 c        write(iout,*)"WCHODZE W PROGRAM"
4203         a_temp(1,1)=a22
4204         a_temp(1,2)=a23
4205         a_temp(2,1)=a32
4206         a_temp(2,2)=a33
4207         iti1=itortyp(itype(i+1))
4208         iti2=itortyp(itype(i+2))
4209         iti3=itortyp(itype(i+3))
4210 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4211         call transpose2(EUg(1,1,i+1),e1t(1,1))
4212         call transpose2(Eug(1,1,i+2),e2t(1,1))
4213         call transpose2(Eug(1,1,i+3),e3t(1,1))
4214 C Ematrix derivative in theta
4215         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4216         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4217         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4218         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4219 c       eta1 in derivative theta
4220         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4221         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4222 c       auxgvec is derivative of Ub2 so i+3 theta
4223         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4224 c       auxalary matrix of E i+1
4225         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4226 c        s1=0.0
4227 c        gs1=0.0
4228         s1=scalar2(b1(1,i+2),auxvec(1))
4229 c derivative of theta i+2 with constant i+3
4230         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4231 c derivative of theta i+2 with constant i+2
4232         gs32=scalar2(b1(1,i+2),auxgvec(1))
4233 c derivative of E matix in theta of i+1
4234         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4235
4236         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4237 c       ea31 in derivative theta
4238         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4239         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4240 c auxilary matrix auxgvec of Ub2 with constant E matirx
4241         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4242 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4243         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4244
4245 c        s2=0.0
4246 c        gs2=0.0
4247         s2=scalar2(b1(1,i+1),auxvec(1))
4248 c derivative of theta i+1 with constant i+3
4249         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4250 c derivative of theta i+2 with constant i+1
4251         gs21=scalar2(b1(1,i+1),auxgvec(1))
4252 c derivative of theta i+3 with constant i+1
4253         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4254 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4255 c     &  gtb1(1,i+1)
4256         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4257 c two derivatives over diffetent matrices
4258 c gtae3e2 is derivative over i+3
4259         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4260 c ae3gte2 is derivative over i+2
4261         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4262         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4263 c three possible derivative over theta E matices
4264 c i+1
4265         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4266 c i+2
4267         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4268 c i+3
4269         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4270         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4271
4272         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4273         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4274         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4275
4276         eello_turn4=eello_turn4-(s1+s2+s3)
4277 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4278         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4279      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4280 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4281 cd     &    ' eello_turn4_num',8*eello_turn4_num
4282 #ifdef NEWCORR
4283         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4284      &                  -(gs13+gsE13+gsEE1)*wturn4
4285         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4286      &                    -(gs23+gs21+gsEE2)*wturn4
4287         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4288      &                    -(gs32+gsE31+gsEE3)*wturn4
4289 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4290 c     &   gs2
4291 #endif
4292         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4293      &      'eturn4',i,j,-(s1+s2+s3)
4294 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4295 c     &    ' eello_turn4_num',8*eello_turn4_num
4296 C Derivatives in gamma(i)
4297         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4298         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4299         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4300         s1=scalar2(b1(1,i+2),auxvec(1))
4301         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4302         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4303         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4304 C Derivatives in gamma(i+1)
4305         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4306         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4307         s2=scalar2(b1(1,i+1),auxvec(1))
4308         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4309         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4310         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4311         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4312 C Derivatives in gamma(i+2)
4313         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4314         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4315         s1=scalar2(b1(1,i+2),auxvec(1))
4316         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4317         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4318         s2=scalar2(b1(1,i+1),auxvec(1))
4319         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4320         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4321         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4322         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4323 C Cartesian derivatives
4324 C Derivatives of this turn contributions in DC(i+2)
4325         if (j.lt.nres-1) then
4326           do l=1,3
4327             a_temp(1,1)=agg(l,1)
4328             a_temp(1,2)=agg(l,2)
4329             a_temp(2,1)=agg(l,3)
4330             a_temp(2,2)=agg(l,4)
4331             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4332             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4333             s1=scalar2(b1(1,i+2),auxvec(1))
4334             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4335             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4336             s2=scalar2(b1(1,i+1),auxvec(1))
4337             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4338             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4339             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4340             ggg(l)=-(s1+s2+s3)
4341             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4342           enddo
4343         endif
4344 C Remaining derivatives of this turn contribution
4345         do l=1,3
4346           a_temp(1,1)=aggi(l,1)
4347           a_temp(1,2)=aggi(l,2)
4348           a_temp(2,1)=aggi(l,3)
4349           a_temp(2,2)=aggi(l,4)
4350           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4351           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4352           s1=scalar2(b1(1,i+2),auxvec(1))
4353           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4354           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4355           s2=scalar2(b1(1,i+1),auxvec(1))
4356           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4357           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4358           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4359           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4360           a_temp(1,1)=aggi1(l,1)
4361           a_temp(1,2)=aggi1(l,2)
4362           a_temp(2,1)=aggi1(l,3)
4363           a_temp(2,2)=aggi1(l,4)
4364           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4365           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4366           s1=scalar2(b1(1,i+2),auxvec(1))
4367           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4368           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4369           s2=scalar2(b1(1,i+1),auxvec(1))
4370           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4371           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4372           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4373           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4374           a_temp(1,1)=aggj(l,1)
4375           a_temp(1,2)=aggj(l,2)
4376           a_temp(2,1)=aggj(l,3)
4377           a_temp(2,2)=aggj(l,4)
4378           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4379           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4380           s1=scalar2(b1(1,i+2),auxvec(1))
4381           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4382           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4383           s2=scalar2(b1(1,i+1),auxvec(1))
4384           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4385           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4386           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4387           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4388           a_temp(1,1)=aggj1(l,1)
4389           a_temp(1,2)=aggj1(l,2)
4390           a_temp(2,1)=aggj1(l,3)
4391           a_temp(2,2)=aggj1(l,4)
4392           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4393           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4394           s1=scalar2(b1(1,i+2),auxvec(1))
4395           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4396           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4397           s2=scalar2(b1(1,i+1),auxvec(1))
4398           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4399           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4400           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4401 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4402           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4403         enddo
4404       return
4405       end
4406 C-----------------------------------------------------------------------------
4407       subroutine vecpr(u,v,w)
4408       implicit real*8(a-h,o-z)
4409       dimension u(3),v(3),w(3)
4410       w(1)=u(2)*v(3)-u(3)*v(2)
4411       w(2)=-u(1)*v(3)+u(3)*v(1)
4412       w(3)=u(1)*v(2)-u(2)*v(1)
4413       return
4414       end
4415 C-----------------------------------------------------------------------------
4416       subroutine unormderiv(u,ugrad,unorm,ungrad)
4417 C This subroutine computes the derivatives of a normalized vector u, given
4418 C the derivatives computed without normalization conditions, ugrad. Returns
4419 C ungrad.
4420       implicit none
4421       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4422       double precision vec(3)
4423       double precision scalar
4424       integer i,j
4425 c      write (2,*) 'ugrad',ugrad
4426 c      write (2,*) 'u',u
4427       do i=1,3
4428         vec(i)=scalar(ugrad(1,i),u(1))
4429       enddo
4430 c      write (2,*) 'vec',vec
4431       do i=1,3
4432         do j=1,3
4433           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4434         enddo
4435       enddo
4436 c      write (2,*) 'ungrad',ungrad
4437       return
4438       end
4439 C-----------------------------------------------------------------------------
4440       subroutine escp_soft_sphere(evdw2,evdw2_14)
4441 C
4442 C This subroutine calculates the excluded-volume interaction energy between
4443 C peptide-group centers and side chains and its gradient in virtual-bond and
4444 C side-chain vectors.
4445 C
4446       implicit real*8 (a-h,o-z)
4447       include 'DIMENSIONS'
4448       include 'COMMON.GEO'
4449       include 'COMMON.VAR'
4450       include 'COMMON.LOCAL'
4451       include 'COMMON.CHAIN'
4452       include 'COMMON.DERIV'
4453       include 'COMMON.INTERACT'
4454       include 'COMMON.FFIELD'
4455       include 'COMMON.IOUNITS'
4456       include 'COMMON.CONTROL'
4457       dimension ggg(3)
4458       evdw2=0.0D0
4459       evdw2_14=0.0d0
4460       r0_scp=4.5d0
4461 cd    print '(a)','Enter ESCP'
4462 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4463 C      do xshift=-1,1
4464 C      do yshift=-1,1
4465 C      do zshift=-1,1
4466       do i=iatscp_s,iatscp_e
4467         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4468         iteli=itel(i)
4469         xi=0.5D0*(c(1,i)+c(1,i+1))
4470         yi=0.5D0*(c(2,i)+c(2,i+1))
4471         zi=0.5D0*(c(3,i)+c(3,i+1))
4472 C Return atom into box, boxxsize is size of box in x dimension
4473 c  134   continue
4474 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4475 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4476 C Condition for being inside the proper box
4477 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4478 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4479 c        go to 134
4480 c        endif
4481 c  135   continue
4482 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4483 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4484 C Condition for being inside the proper box
4485 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4486 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4487 c        go to 135
4488 c c       endif
4489 c  136   continue
4490 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4491 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4492 cC Condition for being inside the proper box
4493 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4494 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4495 c        go to 136
4496 c        endif
4497           xi=mod(xi,boxxsize)
4498           if (xi.lt.0) xi=xi+boxxsize
4499           yi=mod(yi,boxysize)
4500           if (yi.lt.0) yi=yi+boxysize
4501           zi=mod(zi,boxzsize)
4502           if (zi.lt.0) zi=zi+boxzsize
4503 C          xi=xi+xshift*boxxsize
4504 C          yi=yi+yshift*boxysize
4505 C          zi=zi+zshift*boxzsize
4506         do iint=1,nscp_gr(i)
4507
4508         do j=iscpstart(i,iint),iscpend(i,iint)
4509           if (itype(j).eq.ntyp1) cycle
4510           itypj=iabs(itype(j))
4511 C Uncomment following three lines for SC-p interactions
4512 c         xj=c(1,nres+j)-xi
4513 c         yj=c(2,nres+j)-yi
4514 c         zj=c(3,nres+j)-zi
4515 C Uncomment following three lines for Ca-p interactions
4516           xj=c(1,j)
4517           yj=c(2,j)
4518           zj=c(3,j)
4519 c  174   continue
4520 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4521 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4522 C Condition for being inside the proper box
4523 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4524 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4525 c        go to 174
4526 c        endif
4527 c  175   continue
4528 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4529 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4530 cC Condition for being inside the proper box
4531 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4532 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4533 c        go to 175
4534 c        endif
4535 c  176   continue
4536 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4537 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4538 C Condition for being inside the proper box
4539 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4540 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4541 c        go to 176
4542           xj=mod(xj,boxxsize)
4543           if (xj.lt.0) xj=xj+boxxsize
4544           yj=mod(yj,boxysize)
4545           if (yj.lt.0) yj=yj+boxysize
4546           zj=mod(zj,boxzsize)
4547           if (zj.lt.0) zj=zj+boxzsize
4548       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4549       xj_safe=xj
4550       yj_safe=yj
4551       zj_safe=zj
4552       subchap=0
4553       do xshift=-1,1
4554       do yshift=-1,1
4555       do zshift=-1,1
4556           xj=xj_safe+xshift*boxxsize
4557           yj=yj_safe+yshift*boxysize
4558           zj=zj_safe+zshift*boxzsize
4559           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4560           if(dist_temp.lt.dist_init) then
4561             dist_init=dist_temp
4562             xj_temp=xj
4563             yj_temp=yj
4564             zj_temp=zj
4565             subchap=1
4566           endif
4567        enddo
4568        enddo
4569        enddo
4570        if (subchap.eq.1) then
4571           xj=xj_temp-xi
4572           yj=yj_temp-yi
4573           zj=zj_temp-zi
4574        else
4575           xj=xj_safe-xi
4576           yj=yj_safe-yi
4577           zj=zj_safe-zi
4578        endif
4579 c c       endif
4580 C          xj=xj-xi
4581 C          yj=yj-yi
4582 C          zj=zj-zi
4583           rij=xj*xj+yj*yj+zj*zj
4584
4585           r0ij=r0_scp
4586           r0ijsq=r0ij*r0ij
4587           if (rij.lt.r0ijsq) then
4588             evdwij=0.25d0*(rij-r0ijsq)**2
4589             fac=rij-r0ijsq
4590           else
4591             evdwij=0.0d0
4592             fac=0.0d0
4593           endif
4594           evdw2=evdw2+evdwij
4595 C
4596 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4597 C
4598           ggg(1)=xj*fac
4599           ggg(2)=yj*fac
4600           ggg(3)=zj*fac
4601 cgrad          if (j.lt.i) then
4602 cd          write (iout,*) 'j<i'
4603 C Uncomment following three lines for SC-p interactions
4604 c           do k=1,3
4605 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4606 c           enddo
4607 cgrad          else
4608 cd          write (iout,*) 'j>i'
4609 cgrad            do k=1,3
4610 cgrad              ggg(k)=-ggg(k)
4611 C Uncomment following line for SC-p interactions
4612 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4613 cgrad            enddo
4614 cgrad          endif
4615 cgrad          do k=1,3
4616 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4617 cgrad          enddo
4618 cgrad          kstart=min0(i+1,j)
4619 cgrad          kend=max0(i-1,j-1)
4620 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4621 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4622 cgrad          do k=kstart,kend
4623 cgrad            do l=1,3
4624 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4625 cgrad            enddo
4626 cgrad          enddo
4627           do k=1,3
4628             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4629             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4630           enddo
4631         enddo
4632
4633         enddo ! iint
4634       enddo ! i
4635 C      enddo !zshift
4636 C      enddo !yshift
4637 C      enddo !xshift
4638       return
4639       end
4640 C-----------------------------------------------------------------------------
4641       subroutine escp(evdw2,evdw2_14)
4642 C
4643 C This subroutine calculates the excluded-volume interaction energy between
4644 C peptide-group centers and side chains and its gradient in virtual-bond and
4645 C side-chain vectors.
4646 C
4647       implicit real*8 (a-h,o-z)
4648       include 'DIMENSIONS'
4649       include 'COMMON.GEO'
4650       include 'COMMON.VAR'
4651       include 'COMMON.LOCAL'
4652       include 'COMMON.CHAIN'
4653       include 'COMMON.DERIV'
4654       include 'COMMON.INTERACT'
4655       include 'COMMON.FFIELD'
4656       include 'COMMON.IOUNITS'
4657       include 'COMMON.CONTROL'
4658       include 'COMMON.SPLITELE'
4659       dimension ggg(3)
4660       evdw2=0.0D0
4661       evdw2_14=0.0d0
4662 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4663 cd    print '(a)','Enter ESCP'
4664 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4665 C      do xshift=-1,1
4666 C      do yshift=-1,1
4667 C      do zshift=-1,1
4668       do i=iatscp_s,iatscp_e
4669         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4670         iteli=itel(i)
4671         xi=0.5D0*(c(1,i)+c(1,i+1))
4672         yi=0.5D0*(c(2,i)+c(2,i+1))
4673         zi=0.5D0*(c(3,i)+c(3,i+1))
4674           xi=mod(xi,boxxsize)
4675           if (xi.lt.0) xi=xi+boxxsize
4676           yi=mod(yi,boxysize)
4677           if (yi.lt.0) yi=yi+boxysize
4678           zi=mod(zi,boxzsize)
4679           if (zi.lt.0) zi=zi+boxzsize
4680 c          xi=xi+xshift*boxxsize
4681 c          yi=yi+yshift*boxysize
4682 c          zi=zi+zshift*boxzsize
4683 c        print *,xi,yi,zi,'polozenie i'
4684 C Return atom into box, boxxsize is size of box in x dimension
4685 c  134   continue
4686 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4687 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4688 C Condition for being inside the proper box
4689 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4690 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4691 c        go to 134
4692 c        endif
4693 c  135   continue
4694 c          print *,xi,boxxsize,"pierwszy"
4695
4696 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4697 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4698 C Condition for being inside the proper box
4699 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4700 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4701 c        go to 135
4702 c        endif
4703 c  136   continue
4704 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4705 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4706 C Condition for being inside the proper box
4707 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4708 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4709 c        go to 136
4710 c        endif
4711         do iint=1,nscp_gr(i)
4712
4713         do j=iscpstart(i,iint),iscpend(i,iint)
4714           itypj=iabs(itype(j))
4715           if (itypj.eq.ntyp1) cycle
4716 C Uncomment following three lines for SC-p interactions
4717 c         xj=c(1,nres+j)-xi
4718 c         yj=c(2,nres+j)-yi
4719 c         zj=c(3,nres+j)-zi
4720 C Uncomment following three lines for Ca-p interactions
4721           xj=c(1,j)
4722           yj=c(2,j)
4723           zj=c(3,j)
4724           xj=mod(xj,boxxsize)
4725           if (xj.lt.0) xj=xj+boxxsize
4726           yj=mod(yj,boxysize)
4727           if (yj.lt.0) yj=yj+boxysize
4728           zj=mod(zj,boxzsize)
4729           if (zj.lt.0) zj=zj+boxzsize
4730 c  174   continue
4731 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4732 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4733 C Condition for being inside the proper box
4734 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4735 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4736 c        go to 174
4737 c        endif
4738 c  175   continue
4739 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4740 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4741 cC Condition for being inside the proper box
4742 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4743 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4744 c        go to 175
4745 c        endif
4746 c  176   continue
4747 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4748 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4749 C Condition for being inside the proper box
4750 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4751 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4752 c        go to 176
4753 c        endif
4754 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4755       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4756       xj_safe=xj
4757       yj_safe=yj
4758       zj_safe=zj
4759       subchap=0
4760       do xshift=-1,1
4761       do yshift=-1,1
4762       do zshift=-1,1
4763           xj=xj_safe+xshift*boxxsize
4764           yj=yj_safe+yshift*boxysize
4765           zj=zj_safe+zshift*boxzsize
4766           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4767           if(dist_temp.lt.dist_init) then
4768             dist_init=dist_temp
4769             xj_temp=xj
4770             yj_temp=yj
4771             zj_temp=zj
4772             subchap=1
4773           endif
4774        enddo
4775        enddo
4776        enddo
4777        if (subchap.eq.1) then
4778           xj=xj_temp-xi
4779           yj=yj_temp-yi
4780           zj=zj_temp-zi
4781        else
4782           xj=xj_safe-xi
4783           yj=yj_safe-yi
4784           zj=zj_safe-zi
4785        endif
4786 c          print *,xj,yj,zj,'polozenie j'
4787           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4788 c          print *,rrij
4789           sss=sscale(1.0d0/(dsqrt(rrij)))
4790 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4791 c          if (sss.eq.0) print *,'czasem jest OK'
4792           if (sss.le.0.0d0) cycle
4793           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4794           fac=rrij**expon2
4795           e1=fac*fac*aad(itypj,iteli)
4796           e2=fac*bad(itypj,iteli)
4797           if (iabs(j-i) .le. 2) then
4798             e1=scal14*e1
4799             e2=scal14*e2
4800             evdw2_14=evdw2_14+(e1+e2)*sss
4801           endif
4802           evdwij=e1+e2
4803           evdw2=evdw2+evdwij*sss
4804           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4805      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4806      &       bad(itypj,iteli)
4807 C
4808 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4809 C
4810           fac=-(evdwij+e1)*rrij*sss
4811           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4812           ggg(1)=xj*fac
4813           ggg(2)=yj*fac
4814           ggg(3)=zj*fac
4815 cgrad          if (j.lt.i) then
4816 cd          write (iout,*) 'j<i'
4817 C Uncomment following three lines for SC-p interactions
4818 c           do k=1,3
4819 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4820 c           enddo
4821 cgrad          else
4822 cd          write (iout,*) 'j>i'
4823 cgrad            do k=1,3
4824 cgrad              ggg(k)=-ggg(k)
4825 C Uncomment following line for SC-p interactions
4826 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4827 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4828 cgrad            enddo
4829 cgrad          endif
4830 cgrad          do k=1,3
4831 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4832 cgrad          enddo
4833 cgrad          kstart=min0(i+1,j)
4834 cgrad          kend=max0(i-1,j-1)
4835 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4836 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4837 cgrad          do k=kstart,kend
4838 cgrad            do l=1,3
4839 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4840 cgrad            enddo
4841 cgrad          enddo
4842           do k=1,3
4843             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4844             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4845           enddo
4846 c        endif !endif for sscale cutoff
4847         enddo ! j
4848
4849         enddo ! iint
4850       enddo ! i
4851 c      enddo !zshift
4852 c      enddo !yshift
4853 c      enddo !xshift
4854       do i=1,nct
4855         do j=1,3
4856           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4857           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4858           gradx_scp(j,i)=expon*gradx_scp(j,i)
4859         enddo
4860       enddo
4861 C******************************************************************************
4862 C
4863 C                              N O T E !!!
4864 C
4865 C To save time the factor EXPON has been extracted from ALL components
4866 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4867 C use!
4868 C
4869 C******************************************************************************
4870       return
4871       end
4872 C--------------------------------------------------------------------------
4873       subroutine edis(ehpb)
4874 C
4875 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4876 C
4877       implicit real*8 (a-h,o-z)
4878       include 'DIMENSIONS'
4879       include 'COMMON.SBRIDGE'
4880       include 'COMMON.CHAIN'
4881       include 'COMMON.DERIV'
4882       include 'COMMON.VAR'
4883       include 'COMMON.INTERACT'
4884       include 'COMMON.IOUNITS'
4885       dimension ggg(3)
4886       ehpb=0.0D0
4887 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4888 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4889       if (link_end.eq.0) return
4890       do i=link_start,link_end
4891 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4892 C CA-CA distance used in regularization of structure.
4893         ii=ihpb(i)
4894         jj=jhpb(i)
4895 C iii and jjj point to the residues for which the distance is assigned.
4896         if (ii.gt.nres) then
4897           iii=ii-nres
4898           jjj=jj-nres
4899         else
4900           iii=ii
4901           jjj=jj
4902         endif
4903 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4904 c     &    dhpb(i),dhpb1(i),forcon(i)
4905 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4906 C    distance and angle dependent SS bond potential.
4907         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4908      & iabs(itype(jjj)).eq.1) then
4909 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4910 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4911         if (.not.dyn_ss .and. i.le.nss) then
4912 C 15/02/13 CC dynamic SSbond - additional check
4913          if (ii.gt.nres
4914      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4915           call ssbond_ene(iii,jjj,eij)
4916           ehpb=ehpb+2*eij
4917          endif
4918 cd          write (iout,*) "eij",eij
4919         else
4920 C Calculate the distance between the two points and its difference from the
4921 C target distance.
4922           dd=dist(ii,jj)
4923             rdis=dd-dhpb(i)
4924 C Get the force constant corresponding to this distance.
4925             waga=forcon(i)
4926 C Calculate the contribution to energy.
4927             ehpb=ehpb+waga*rdis*rdis
4928 C
4929 C Evaluate gradient.
4930 C
4931             fac=waga*rdis/dd
4932 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4933 cd   &   ' waga=',waga,' fac=',fac
4934             do j=1,3
4935               ggg(j)=fac*(c(j,jj)-c(j,ii))
4936             enddo
4937 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4938 C If this is a SC-SC distance, we need to calculate the contributions to the
4939 C Cartesian gradient in the SC vectors (ghpbx).
4940           if (iii.lt.ii) then
4941           do j=1,3
4942             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4943             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4944           enddo
4945           endif
4946 cgrad        do j=iii,jjj-1
4947 cgrad          do k=1,3
4948 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4949 cgrad          enddo
4950 cgrad        enddo
4951           do k=1,3
4952             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4953             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4954           enddo
4955         endif
4956        endif
4957       enddo
4958       ehpb=0.5D0*ehpb
4959       return
4960       end
4961 C--------------------------------------------------------------------------
4962       subroutine ssbond_ene(i,j,eij)
4963 C
4964 C Calculate the distance and angle dependent SS-bond potential energy
4965 C using a free-energy function derived based on RHF/6-31G** ab initio
4966 C calculations of diethyl disulfide.
4967 C
4968 C A. Liwo and U. Kozlowska, 11/24/03
4969 C
4970       implicit real*8 (a-h,o-z)
4971       include 'DIMENSIONS'
4972       include 'COMMON.SBRIDGE'
4973       include 'COMMON.CHAIN'
4974       include 'COMMON.DERIV'
4975       include 'COMMON.LOCAL'
4976       include 'COMMON.INTERACT'
4977       include 'COMMON.VAR'
4978       include 'COMMON.IOUNITS'
4979       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4980       itypi=iabs(itype(i))
4981       xi=c(1,nres+i)
4982       yi=c(2,nres+i)
4983       zi=c(3,nres+i)
4984       dxi=dc_norm(1,nres+i)
4985       dyi=dc_norm(2,nres+i)
4986       dzi=dc_norm(3,nres+i)
4987 c      dsci_inv=dsc_inv(itypi)
4988       dsci_inv=vbld_inv(nres+i)
4989       itypj=iabs(itype(j))
4990 c      dscj_inv=dsc_inv(itypj)
4991       dscj_inv=vbld_inv(nres+j)
4992       xj=c(1,nres+j)-xi
4993       yj=c(2,nres+j)-yi
4994       zj=c(3,nres+j)-zi
4995       dxj=dc_norm(1,nres+j)
4996       dyj=dc_norm(2,nres+j)
4997       dzj=dc_norm(3,nres+j)
4998       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4999       rij=dsqrt(rrij)
5000       erij(1)=xj*rij
5001       erij(2)=yj*rij
5002       erij(3)=zj*rij
5003       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5004       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5005       om12=dxi*dxj+dyi*dyj+dzi*dzj
5006       do k=1,3
5007         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5008         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5009       enddo
5010       rij=1.0d0/rij
5011       deltad=rij-d0cm
5012       deltat1=1.0d0-om1
5013       deltat2=1.0d0+om2
5014       deltat12=om2-om1+2.0d0
5015       cosphi=om12-om1*om2
5016       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5017      &  +akct*deltad*deltat12
5018      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5019 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5020 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5021 c     &  " deltat12",deltat12," eij",eij
5022       ed=2*akcm*deltad+akct*deltat12
5023       pom1=akct*deltad
5024       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5025       eom1=-2*akth*deltat1-pom1-om2*pom2
5026       eom2= 2*akth*deltat2+pom1-om1*pom2
5027       eom12=pom2
5028       do k=1,3
5029         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5030         ghpbx(k,i)=ghpbx(k,i)-ggk
5031      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5032      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5033         ghpbx(k,j)=ghpbx(k,j)+ggk
5034      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5035      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5036         ghpbc(k,i)=ghpbc(k,i)-ggk
5037         ghpbc(k,j)=ghpbc(k,j)+ggk
5038       enddo
5039 C
5040 C Calculate the components of the gradient in DC and X
5041 C
5042 cgrad      do k=i,j-1
5043 cgrad        do l=1,3
5044 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5045 cgrad        enddo
5046 cgrad      enddo
5047       return
5048       end
5049 C--------------------------------------------------------------------------
5050       subroutine ebond(estr)
5051 c
5052 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5053 c
5054       implicit real*8 (a-h,o-z)
5055       include 'DIMENSIONS'
5056       include 'COMMON.LOCAL'
5057       include 'COMMON.GEO'
5058       include 'COMMON.INTERACT'
5059       include 'COMMON.DERIV'
5060       include 'COMMON.VAR'
5061       include 'COMMON.CHAIN'
5062       include 'COMMON.IOUNITS'
5063       include 'COMMON.NAMES'
5064       include 'COMMON.FFIELD'
5065       include 'COMMON.CONTROL'
5066       include 'COMMON.SETUP'
5067       double precision u(3),ud(3)
5068       estr=0.0d0
5069       estr1=0.0d0
5070       do i=ibondp_start,ibondp_end
5071         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5072 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5073 c          do j=1,3
5074 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5075 c     &      *dc(j,i-1)/vbld(i)
5076 c          enddo
5077 c          if (energy_dec) write(iout,*)
5078 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5079 c        else
5080 C       Checking if it involves dummy (NH3+ or COO-) group
5081          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5082 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5083         diff = vbld(i)-vbldpDUM
5084          else
5085 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5086         diff = vbld(i)-vbldp0
5087          endif
5088         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5089      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5090         estr=estr+diff*diff
5091         do j=1,3
5092           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5093         enddo
5094 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5095 c        endif
5096       enddo
5097       estr=0.5d0*AKP*estr+estr1
5098 c
5099 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5100 c
5101       do i=ibond_start,ibond_end
5102         iti=iabs(itype(i))
5103         if (iti.ne.10 .and. iti.ne.ntyp1) then
5104           nbi=nbondterm(iti)
5105           if (nbi.eq.1) then
5106             diff=vbld(i+nres)-vbldsc0(1,iti)
5107             if (energy_dec)  write (iout,*)
5108      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5109      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5110             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5111             do j=1,3
5112               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5113             enddo
5114           else
5115             do j=1,nbi
5116               diff=vbld(i+nres)-vbldsc0(j,iti)
5117               ud(j)=aksc(j,iti)*diff
5118               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5119             enddo
5120             uprod=u(1)
5121             do j=2,nbi
5122               uprod=uprod*u(j)
5123             enddo
5124             usum=0.0d0
5125             usumsqder=0.0d0
5126             do j=1,nbi
5127               uprod1=1.0d0
5128               uprod2=1.0d0
5129               do k=1,nbi
5130                 if (k.ne.j) then
5131                   uprod1=uprod1*u(k)
5132                   uprod2=uprod2*u(k)*u(k)
5133                 endif
5134               enddo
5135               usum=usum+uprod1
5136               usumsqder=usumsqder+ud(j)*uprod2
5137             enddo
5138             estr=estr+uprod/usum
5139             do j=1,3
5140              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5141             enddo
5142           endif
5143         endif
5144       enddo
5145       return
5146       end
5147 #ifdef CRYST_THETA
5148 C--------------------------------------------------------------------------
5149       subroutine ebend(etheta)
5150 C
5151 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5152 C angles gamma and its derivatives in consecutive thetas and gammas.
5153 C
5154       implicit real*8 (a-h,o-z)
5155       include 'DIMENSIONS'
5156       include 'COMMON.LOCAL'
5157       include 'COMMON.GEO'
5158       include 'COMMON.INTERACT'
5159       include 'COMMON.DERIV'
5160       include 'COMMON.VAR'
5161       include 'COMMON.CHAIN'
5162       include 'COMMON.IOUNITS'
5163       include 'COMMON.NAMES'
5164       include 'COMMON.FFIELD'
5165       include 'COMMON.CONTROL'
5166       common /calcthet/ term1,term2,termm,diffak,ratak,
5167      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5168      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5169       double precision y(2),z(2)
5170       delta=0.02d0*pi
5171 c      time11=dexp(-2*time)
5172 c      time12=1.0d0
5173       etheta=0.0D0
5174 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5175       do i=ithet_start,ithet_end
5176         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5177      &  .or.itype(i).eq.ntyp1) cycle
5178 C Zero the energy function and its derivative at 0 or pi.
5179         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5180         it=itype(i-1)
5181         ichir1=isign(1,itype(i-2))
5182         ichir2=isign(1,itype(i))
5183          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5184          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5185          if (itype(i-1).eq.10) then
5186           itype1=isign(10,itype(i-2))
5187           ichir11=isign(1,itype(i-2))
5188           ichir12=isign(1,itype(i-2))
5189           itype2=isign(10,itype(i))
5190           ichir21=isign(1,itype(i))
5191           ichir22=isign(1,itype(i))
5192          endif
5193
5194         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5195 #ifdef OSF
5196           phii=phi(i)
5197           if (phii.ne.phii) phii=150.0
5198 #else
5199           phii=phi(i)
5200 #endif
5201           y(1)=dcos(phii)
5202           y(2)=dsin(phii)
5203         else
5204           y(1)=0.0D0
5205           y(2)=0.0D0
5206         endif
5207         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5208 #ifdef OSF
5209           phii1=phi(i+1)
5210           if (phii1.ne.phii1) phii1=150.0
5211           phii1=pinorm(phii1)
5212           z(1)=cos(phii1)
5213 #else
5214           phii1=phi(i+1)
5215 #endif
5216           z(1)=dcos(phii1)
5217           z(2)=dsin(phii1)
5218         else
5219           z(1)=0.0D0
5220           z(2)=0.0D0
5221         endif
5222 C Calculate the "mean" value of theta from the part of the distribution
5223 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5224 C In following comments this theta will be referred to as t_c.
5225         thet_pred_mean=0.0d0
5226         do k=1,2
5227             athetk=athet(k,it,ichir1,ichir2)
5228             bthetk=bthet(k,it,ichir1,ichir2)
5229           if (it.eq.10) then
5230              athetk=athet(k,itype1,ichir11,ichir12)
5231              bthetk=bthet(k,itype2,ichir21,ichir22)
5232           endif
5233          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5234 c         write(iout,*) 'chuj tu', y(k),z(k)
5235         enddo
5236         dthett=thet_pred_mean*ssd
5237         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5238 C Derivatives of the "mean" values in gamma1 and gamma2.
5239         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5240      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5241          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5242      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5243          if (it.eq.10) then
5244       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5245      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5246         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5247      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5248          endif
5249         if (theta(i).gt.pi-delta) then
5250           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5251      &         E_tc0)
5252           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5253           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5254           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5255      &        E_theta)
5256           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5257      &        E_tc)
5258         else if (theta(i).lt.delta) then
5259           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5260           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5261           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5262      &        E_theta)
5263           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5264           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5265      &        E_tc)
5266         else
5267           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5268      &        E_theta,E_tc)
5269         endif
5270         etheta=etheta+ethetai
5271         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5272      &      'ebend',i,ethetai,theta(i),itype(i)
5273         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5274         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5275         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5276       enddo
5277 C Ufff.... We've done all this!!!
5278       return
5279       end
5280 C---------------------------------------------------------------------------
5281       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5282      &     E_tc)
5283       implicit real*8 (a-h,o-z)
5284       include 'DIMENSIONS'
5285       include 'COMMON.LOCAL'
5286       include 'COMMON.IOUNITS'
5287       common /calcthet/ term1,term2,termm,diffak,ratak,
5288      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5289      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5290 C Calculate the contributions to both Gaussian lobes.
5291 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5292 C The "polynomial part" of the "standard deviation" of this part of
5293 C the distributioni.
5294 ccc        write (iout,*) thetai,thet_pred_mean
5295         sig=polthet(3,it)
5296         do j=2,0,-1
5297           sig=sig*thet_pred_mean+polthet(j,it)
5298         enddo
5299 C Derivative of the "interior part" of the "standard deviation of the"
5300 C gamma-dependent Gaussian lobe in t_c.
5301         sigtc=3*polthet(3,it)
5302         do j=2,1,-1
5303           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5304         enddo
5305         sigtc=sig*sigtc
5306 C Set the parameters of both Gaussian lobes of the distribution.
5307 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5308         fac=sig*sig+sigc0(it)
5309         sigcsq=fac+fac
5310         sigc=1.0D0/sigcsq
5311 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5312         sigsqtc=-4.0D0*sigcsq*sigtc
5313 c       print *,i,sig,sigtc,sigsqtc
5314 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5315         sigtc=-sigtc/(fac*fac)
5316 C Following variable is sigma(t_c)**(-2)
5317         sigcsq=sigcsq*sigcsq
5318         sig0i=sig0(it)
5319         sig0inv=1.0D0/sig0i**2
5320         delthec=thetai-thet_pred_mean
5321         delthe0=thetai-theta0i
5322         term1=-0.5D0*sigcsq*delthec*delthec
5323         term2=-0.5D0*sig0inv*delthe0*delthe0
5324 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5325 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5326 C NaNs in taking the logarithm. We extract the largest exponent which is added
5327 C to the energy (this being the log of the distribution) at the end of energy
5328 C term evaluation for this virtual-bond angle.
5329         if (term1.gt.term2) then
5330           termm=term1
5331           term2=dexp(term2-termm)
5332           term1=1.0d0
5333         else
5334           termm=term2
5335           term1=dexp(term1-termm)
5336           term2=1.0d0
5337         endif
5338 C The ratio between the gamma-independent and gamma-dependent lobes of
5339 C the distribution is a Gaussian function of thet_pred_mean too.
5340         diffak=gthet(2,it)-thet_pred_mean
5341         ratak=diffak/gthet(3,it)**2
5342         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5343 C Let's differentiate it in thet_pred_mean NOW.
5344         aktc=ak*ratak
5345 C Now put together the distribution terms to make complete distribution.
5346         termexp=term1+ak*term2
5347         termpre=sigc+ak*sig0i
5348 C Contribution of the bending energy from this theta is just the -log of
5349 C the sum of the contributions from the two lobes and the pre-exponential
5350 C factor. Simple enough, isn't it?
5351         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5352 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5353 C NOW the derivatives!!!
5354 C 6/6/97 Take into account the deformation.
5355         E_theta=(delthec*sigcsq*term1
5356      &       +ak*delthe0*sig0inv*term2)/termexp
5357         E_tc=((sigtc+aktc*sig0i)/termpre
5358      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5359      &       aktc*term2)/termexp)
5360       return
5361       end
5362 c-----------------------------------------------------------------------------
5363       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5364       implicit real*8 (a-h,o-z)
5365       include 'DIMENSIONS'
5366       include 'COMMON.LOCAL'
5367       include 'COMMON.IOUNITS'
5368       common /calcthet/ term1,term2,termm,diffak,ratak,
5369      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5370      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5371       delthec=thetai-thet_pred_mean
5372       delthe0=thetai-theta0i
5373 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5374       t3 = thetai-thet_pred_mean
5375       t6 = t3**2
5376       t9 = term1
5377       t12 = t3*sigcsq
5378       t14 = t12+t6*sigsqtc
5379       t16 = 1.0d0
5380       t21 = thetai-theta0i
5381       t23 = t21**2
5382       t26 = term2
5383       t27 = t21*t26
5384       t32 = termexp
5385       t40 = t32**2
5386       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5387      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5388      & *(-t12*t9-ak*sig0inv*t27)
5389       return
5390       end
5391 #else
5392 C--------------------------------------------------------------------------
5393       subroutine ebend(etheta)
5394 C
5395 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5396 C angles gamma and its derivatives in consecutive thetas and gammas.
5397 C ab initio-derived potentials from
5398 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5399 C
5400       implicit real*8 (a-h,o-z)
5401       include 'DIMENSIONS'
5402       include 'COMMON.LOCAL'
5403       include 'COMMON.GEO'
5404       include 'COMMON.INTERACT'
5405       include 'COMMON.DERIV'
5406       include 'COMMON.VAR'
5407       include 'COMMON.CHAIN'
5408       include 'COMMON.IOUNITS'
5409       include 'COMMON.NAMES'
5410       include 'COMMON.FFIELD'
5411       include 'COMMON.CONTROL'
5412       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5413      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5414      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5415      & sinph1ph2(maxdouble,maxdouble)
5416       logical lprn /.false./, lprn1 /.false./
5417       etheta=0.0D0
5418       do i=ithet_start,ithet_end
5419 c        print *,i,itype(i-1),itype(i),itype(i-2)
5420         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5421      &  .or.itype(i).eq.ntyp1) cycle
5422 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5423
5424         if (iabs(itype(i+1)).eq.20) iblock=2
5425         if (iabs(itype(i+1)).ne.20) iblock=1
5426         dethetai=0.0d0
5427         dephii=0.0d0
5428         dephii1=0.0d0
5429         theti2=0.5d0*theta(i)
5430         ityp2=ithetyp((itype(i-1)))
5431         do k=1,nntheterm
5432           coskt(k)=dcos(k*theti2)
5433           sinkt(k)=dsin(k*theti2)
5434         enddo
5435         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5436 #ifdef OSF
5437           phii=phi(i)
5438           if (phii.ne.phii) phii=150.0
5439 #else
5440           phii=phi(i)
5441 #endif
5442           ityp1=ithetyp((itype(i-2)))
5443 C propagation of chirality for glycine type
5444           do k=1,nsingle
5445             cosph1(k)=dcos(k*phii)
5446             sinph1(k)=dsin(k*phii)
5447           enddo
5448         else
5449           phii=0.0d0
5450           ityp1=nthetyp+1
5451           do k=1,nsingle
5452             cosph1(k)=0.0d0
5453             sinph1(k)=0.0d0
5454           enddo
5455         endif
5456         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5457 #ifdef OSF
5458           phii1=phi(i+1)
5459           if (phii1.ne.phii1) phii1=150.0
5460           phii1=pinorm(phii1)
5461 #else
5462           phii1=phi(i+1)
5463 #endif
5464           ityp3=ithetyp((itype(i)))
5465           do k=1,nsingle
5466             cosph2(k)=dcos(k*phii1)
5467             sinph2(k)=dsin(k*phii1)
5468           enddo
5469         else
5470           phii1=0.0d0
5471           ityp3=nthetyp+1
5472           do k=1,nsingle
5473             cosph2(k)=0.0d0
5474             sinph2(k)=0.0d0
5475           enddo
5476         endif
5477         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5478         do k=1,ndouble
5479           do l=1,k-1
5480             ccl=cosph1(l)*cosph2(k-l)
5481             ssl=sinph1(l)*sinph2(k-l)
5482             scl=sinph1(l)*cosph2(k-l)
5483             csl=cosph1(l)*sinph2(k-l)
5484             cosph1ph2(l,k)=ccl-ssl
5485             cosph1ph2(k,l)=ccl+ssl
5486             sinph1ph2(l,k)=scl+csl
5487             sinph1ph2(k,l)=scl-csl
5488           enddo
5489         enddo
5490         if (lprn) then
5491         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5492      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5493         write (iout,*) "coskt and sinkt"
5494         do k=1,nntheterm
5495           write (iout,*) k,coskt(k),sinkt(k)
5496         enddo
5497         endif
5498         do k=1,ntheterm
5499           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5500           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5501      &      *coskt(k)
5502           if (lprn)
5503      &    write (iout,*) "k",k,"
5504      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5505      &     " ethetai",ethetai
5506         enddo
5507         if (lprn) then
5508         write (iout,*) "cosph and sinph"
5509         do k=1,nsingle
5510           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5511         enddo
5512         write (iout,*) "cosph1ph2 and sinph2ph2"
5513         do k=2,ndouble
5514           do l=1,k-1
5515             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5516      &         sinph1ph2(l,k),sinph1ph2(k,l)
5517           enddo
5518         enddo
5519         write(iout,*) "ethetai",ethetai
5520         endif
5521         do m=1,ntheterm2
5522           do k=1,nsingle
5523             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5524      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5525      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5526      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5527             ethetai=ethetai+sinkt(m)*aux
5528             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5529             dephii=dephii+k*sinkt(m)*(
5530      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5531      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5532             dephii1=dephii1+k*sinkt(m)*(
5533      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5534      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5535             if (lprn)
5536      &      write (iout,*) "m",m," k",k," bbthet",
5537      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5538      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5539      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5540      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5541           enddo
5542         enddo
5543         if (lprn)
5544      &  write(iout,*) "ethetai",ethetai
5545         do m=1,ntheterm3
5546           do k=2,ndouble
5547             do l=1,k-1
5548               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5549      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5550      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5551      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5552               ethetai=ethetai+sinkt(m)*aux
5553               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5554               dephii=dephii+l*sinkt(m)*(
5555      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5556      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5557      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5558      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5559               dephii1=dephii1+(k-l)*sinkt(m)*(
5560      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5561      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5562      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5563      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5564               if (lprn) then
5565               write (iout,*) "m",m," k",k," l",l," ffthet",
5566      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5567      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5568      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5569      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5570      &            " ethetai",ethetai
5571               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5572      &            cosph1ph2(k,l)*sinkt(m),
5573      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5574               endif
5575             enddo
5576           enddo
5577         enddo
5578 10      continue
5579 c        lprn1=.true.
5580         if (lprn1)
5581      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5582      &   i,theta(i)*rad2deg,phii*rad2deg,
5583      &   phii1*rad2deg,ethetai
5584 c        lprn1=.false.
5585         etheta=etheta+ethetai
5586         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5587         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5588         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5589       enddo
5590       return
5591       end
5592 #endif
5593 #ifdef CRYST_SC
5594 c-----------------------------------------------------------------------------
5595       subroutine esc(escloc)
5596 C Calculate the local energy of a side chain and its derivatives in the
5597 C corresponding virtual-bond valence angles THETA and the spherical angles
5598 C ALPHA and OMEGA.
5599       implicit real*8 (a-h,o-z)
5600       include 'DIMENSIONS'
5601       include 'COMMON.GEO'
5602       include 'COMMON.LOCAL'
5603       include 'COMMON.VAR'
5604       include 'COMMON.INTERACT'
5605       include 'COMMON.DERIV'
5606       include 'COMMON.CHAIN'
5607       include 'COMMON.IOUNITS'
5608       include 'COMMON.NAMES'
5609       include 'COMMON.FFIELD'
5610       include 'COMMON.CONTROL'
5611       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5612      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5613       common /sccalc/ time11,time12,time112,theti,it,nlobit
5614       delta=0.02d0*pi
5615       escloc=0.0D0
5616 c     write (iout,'(a)') 'ESC'
5617       do i=loc_start,loc_end
5618         it=itype(i)
5619         if (it.eq.ntyp1) cycle
5620         if (it.eq.10) goto 1
5621         nlobit=nlob(iabs(it))
5622 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5623 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5624         theti=theta(i+1)-pipol
5625         x(1)=dtan(theti)
5626         x(2)=alph(i)
5627         x(3)=omeg(i)
5628
5629         if (x(2).gt.pi-delta) then
5630           xtemp(1)=x(1)
5631           xtemp(2)=pi-delta
5632           xtemp(3)=x(3)
5633           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5634           xtemp(2)=pi
5635           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5636           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5637      &        escloci,dersc(2))
5638           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5639      &        ddersc0(1),dersc(1))
5640           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5641      &        ddersc0(3),dersc(3))
5642           xtemp(2)=pi-delta
5643           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5644           xtemp(2)=pi
5645           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5646           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5647      &            dersc0(2),esclocbi,dersc02)
5648           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5649      &            dersc12,dersc01)
5650           call splinthet(x(2),0.5d0*delta,ss,ssd)
5651           dersc0(1)=dersc01
5652           dersc0(2)=dersc02
5653           dersc0(3)=0.0d0
5654           do k=1,3
5655             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5656           enddo
5657           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5658 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5659 c    &             esclocbi,ss,ssd
5660           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5661 c         escloci=esclocbi
5662 c         write (iout,*) escloci
5663         else if (x(2).lt.delta) then
5664           xtemp(1)=x(1)
5665           xtemp(2)=delta
5666           xtemp(3)=x(3)
5667           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5668           xtemp(2)=0.0d0
5669           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5670           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5671      &        escloci,dersc(2))
5672           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5673      &        ddersc0(1),dersc(1))
5674           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5675      &        ddersc0(3),dersc(3))
5676           xtemp(2)=delta
5677           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5678           xtemp(2)=0.0d0
5679           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5680           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5681      &            dersc0(2),esclocbi,dersc02)
5682           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5683      &            dersc12,dersc01)
5684           dersc0(1)=dersc01
5685           dersc0(2)=dersc02
5686           dersc0(3)=0.0d0
5687           call splinthet(x(2),0.5d0*delta,ss,ssd)
5688           do k=1,3
5689             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5690           enddo
5691           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5692 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5693 c    &             esclocbi,ss,ssd
5694           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5695 c         write (iout,*) escloci
5696         else
5697           call enesc(x,escloci,dersc,ddummy,.false.)
5698         endif
5699
5700         escloc=escloc+escloci
5701         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5702      &     'escloc',i,escloci
5703 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5704
5705         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5706      &   wscloc*dersc(1)
5707         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5708         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5709     1   continue
5710       enddo
5711       return
5712       end
5713 C---------------------------------------------------------------------------
5714       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5715       implicit real*8 (a-h,o-z)
5716       include 'DIMENSIONS'
5717       include 'COMMON.GEO'
5718       include 'COMMON.LOCAL'
5719       include 'COMMON.IOUNITS'
5720       common /sccalc/ time11,time12,time112,theti,it,nlobit
5721       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5722       double precision contr(maxlob,-1:1)
5723       logical mixed
5724 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5725         escloc_i=0.0D0
5726         do j=1,3
5727           dersc(j)=0.0D0
5728           if (mixed) ddersc(j)=0.0d0
5729         enddo
5730         x3=x(3)
5731
5732 C Because of periodicity of the dependence of the SC energy in omega we have
5733 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5734 C To avoid underflows, first compute & store the exponents.
5735
5736         do iii=-1,1
5737
5738           x(3)=x3+iii*dwapi
5739
5740           do j=1,nlobit
5741             do k=1,3
5742               z(k)=x(k)-censc(k,j,it)
5743             enddo
5744             do k=1,3
5745               Axk=0.0D0
5746               do l=1,3
5747                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5748               enddo
5749               Ax(k,j,iii)=Axk
5750             enddo
5751             expfac=0.0D0
5752             do k=1,3
5753               expfac=expfac+Ax(k,j,iii)*z(k)
5754             enddo
5755             contr(j,iii)=expfac
5756           enddo ! j
5757
5758         enddo ! iii
5759
5760         x(3)=x3
5761 C As in the case of ebend, we want to avoid underflows in exponentiation and
5762 C subsequent NaNs and INFs in energy calculation.
5763 C Find the largest exponent
5764         emin=contr(1,-1)
5765         do iii=-1,1
5766           do j=1,nlobit
5767             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5768           enddo
5769         enddo
5770         emin=0.5D0*emin
5771 cd      print *,'it=',it,' emin=',emin
5772
5773 C Compute the contribution to SC energy and derivatives
5774         do iii=-1,1
5775
5776           do j=1,nlobit
5777 #ifdef OSF
5778             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5779             if(adexp.ne.adexp) adexp=1.0
5780             expfac=dexp(adexp)
5781 #else
5782             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5783 #endif
5784 cd          print *,'j=',j,' expfac=',expfac
5785             escloc_i=escloc_i+expfac
5786             do k=1,3
5787               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5788             enddo
5789             if (mixed) then
5790               do k=1,3,2
5791                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5792      &            +gaussc(k,2,j,it))*expfac
5793               enddo
5794             endif
5795           enddo
5796
5797         enddo ! iii
5798
5799         dersc(1)=dersc(1)/cos(theti)**2
5800         ddersc(1)=ddersc(1)/cos(theti)**2
5801         ddersc(3)=ddersc(3)
5802
5803         escloci=-(dlog(escloc_i)-emin)
5804         do j=1,3
5805           dersc(j)=dersc(j)/escloc_i
5806         enddo
5807         if (mixed) then
5808           do j=1,3,2
5809             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5810           enddo
5811         endif
5812       return
5813       end
5814 C------------------------------------------------------------------------------
5815       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5816       implicit real*8 (a-h,o-z)
5817       include 'DIMENSIONS'
5818       include 'COMMON.GEO'
5819       include 'COMMON.LOCAL'
5820       include 'COMMON.IOUNITS'
5821       common /sccalc/ time11,time12,time112,theti,it,nlobit
5822       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5823       double precision contr(maxlob)
5824       logical mixed
5825
5826       escloc_i=0.0D0
5827
5828       do j=1,3
5829         dersc(j)=0.0D0
5830       enddo
5831
5832       do j=1,nlobit
5833         do k=1,2
5834           z(k)=x(k)-censc(k,j,it)
5835         enddo
5836         z(3)=dwapi
5837         do k=1,3
5838           Axk=0.0D0
5839           do l=1,3
5840             Axk=Axk+gaussc(l,k,j,it)*z(l)
5841           enddo
5842           Ax(k,j)=Axk
5843         enddo
5844         expfac=0.0D0
5845         do k=1,3
5846           expfac=expfac+Ax(k,j)*z(k)
5847         enddo
5848         contr(j)=expfac
5849       enddo ! j
5850
5851 C As in the case of ebend, we want to avoid underflows in exponentiation and
5852 C subsequent NaNs and INFs in energy calculation.
5853 C Find the largest exponent
5854       emin=contr(1)
5855       do j=1,nlobit
5856         if (emin.gt.contr(j)) emin=contr(j)
5857       enddo
5858       emin=0.5D0*emin
5859
5860 C Compute the contribution to SC energy and derivatives
5861
5862       dersc12=0.0d0
5863       do j=1,nlobit
5864         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5865         escloc_i=escloc_i+expfac
5866         do k=1,2
5867           dersc(k)=dersc(k)+Ax(k,j)*expfac
5868         enddo
5869         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5870      &            +gaussc(1,2,j,it))*expfac
5871         dersc(3)=0.0d0
5872       enddo
5873
5874       dersc(1)=dersc(1)/cos(theti)**2
5875       dersc12=dersc12/cos(theti)**2
5876       escloci=-(dlog(escloc_i)-emin)
5877       do j=1,2
5878         dersc(j)=dersc(j)/escloc_i
5879       enddo
5880       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5881       return
5882       end
5883 #else
5884 c----------------------------------------------------------------------------------
5885       subroutine esc(escloc)
5886 C Calculate the local energy of a side chain and its derivatives in the
5887 C corresponding virtual-bond valence angles THETA and the spherical angles
5888 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5889 C added by Urszula Kozlowska. 07/11/2007
5890 C
5891       implicit real*8 (a-h,o-z)
5892       include 'DIMENSIONS'
5893       include 'COMMON.GEO'
5894       include 'COMMON.LOCAL'
5895       include 'COMMON.VAR'
5896       include 'COMMON.SCROT'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.CHAIN'
5900       include 'COMMON.IOUNITS'
5901       include 'COMMON.NAMES'
5902       include 'COMMON.FFIELD'
5903       include 'COMMON.CONTROL'
5904       include 'COMMON.VECTORS'
5905       double precision x_prime(3),y_prime(3),z_prime(3)
5906      &    , sumene,dsc_i,dp2_i,x(65),
5907      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5908      &    de_dxx,de_dyy,de_dzz,de_dt
5909       double precision s1_t,s1_6_t,s2_t,s2_6_t
5910       double precision
5911      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5912      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5913      & dt_dCi(3),dt_dCi1(3)
5914       common /sccalc/ time11,time12,time112,theti,it,nlobit
5915       delta=0.02d0*pi
5916       escloc=0.0D0
5917       do i=loc_start,loc_end
5918         if (itype(i).eq.ntyp1) cycle
5919         costtab(i+1) =dcos(theta(i+1))
5920         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5921         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5922         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5923         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5924         cosfac=dsqrt(cosfac2)
5925         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5926         sinfac=dsqrt(sinfac2)
5927         it=iabs(itype(i))
5928         if (it.eq.10) goto 1
5929 c
5930 C  Compute the axes of tghe local cartesian coordinates system; store in
5931 c   x_prime, y_prime and z_prime
5932 c
5933         do j=1,3
5934           x_prime(j) = 0.00
5935           y_prime(j) = 0.00
5936           z_prime(j) = 0.00
5937         enddo
5938 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5939 C     &   dc_norm(3,i+nres)
5940         do j = 1,3
5941           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5942           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5943         enddo
5944         do j = 1,3
5945           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5946         enddo
5947 c       write (2,*) "i",i
5948 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5949 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5950 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5951 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5952 c      & " xy",scalar(x_prime(1),y_prime(1)),
5953 c      & " xz",scalar(x_prime(1),z_prime(1)),
5954 c      & " yy",scalar(y_prime(1),y_prime(1)),
5955 c      & " yz",scalar(y_prime(1),z_prime(1)),
5956 c      & " zz",scalar(z_prime(1),z_prime(1))
5957 c
5958 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5959 C to local coordinate system. Store in xx, yy, zz.
5960 c
5961         xx=0.0d0
5962         yy=0.0d0
5963         zz=0.0d0
5964         do j = 1,3
5965           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5966           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5967           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5968         enddo
5969
5970         xxtab(i)=xx
5971         yytab(i)=yy
5972         zztab(i)=zz
5973 C
5974 C Compute the energy of the ith side cbain
5975 C
5976 c        write (2,*) "xx",xx," yy",yy," zz",zz
5977         it=iabs(itype(i))
5978         do j = 1,65
5979           x(j) = sc_parmin(j,it)
5980         enddo
5981 #ifdef CHECK_COORD
5982 Cc diagnostics - remove later
5983         xx1 = dcos(alph(2))
5984         yy1 = dsin(alph(2))*dcos(omeg(2))
5985         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5986         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5987      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5988      &    xx1,yy1,zz1
5989 C,"  --- ", xx_w,yy_w,zz_w
5990 c end diagnostics
5991 #endif
5992         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5993      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5994      &   + x(10)*yy*zz
5995         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5996      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5997      & + x(20)*yy*zz
5998         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5999      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6000      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6001      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6002      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6003      &  +x(40)*xx*yy*zz
6004         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6005      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6006      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6007      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6008      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6009      &  +x(60)*xx*yy*zz
6010         dsc_i   = 0.743d0+x(61)
6011         dp2_i   = 1.9d0+x(62)
6012         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6013      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6014         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6015      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6016         s1=(1+x(63))/(0.1d0 + dscp1)
6017         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6018         s2=(1+x(65))/(0.1d0 + dscp2)
6019         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6020         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6021      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6022 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6023 c     &   sumene4,
6024 c     &   dscp1,dscp2,sumene
6025 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6026         escloc = escloc + sumene
6027 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6028 c     & ,zz,xx,yy
6029 c#define DEBUG
6030 #ifdef DEBUG
6031 C
6032 C This section to check the numerical derivatives of the energy of ith side
6033 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6034 C #define DEBUG in the code to turn it on.
6035 C
6036         write (2,*) "sumene               =",sumene
6037         aincr=1.0d-7
6038         xxsave=xx
6039         xx=xx+aincr
6040         write (2,*) xx,yy,zz
6041         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6042         de_dxx_num=(sumenep-sumene)/aincr
6043         xx=xxsave
6044         write (2,*) "xx+ sumene from enesc=",sumenep
6045         yysave=yy
6046         yy=yy+aincr
6047         write (2,*) xx,yy,zz
6048         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6049         de_dyy_num=(sumenep-sumene)/aincr
6050         yy=yysave
6051         write (2,*) "yy+ sumene from enesc=",sumenep
6052         zzsave=zz
6053         zz=zz+aincr
6054         write (2,*) xx,yy,zz
6055         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6056         de_dzz_num=(sumenep-sumene)/aincr
6057         zz=zzsave
6058         write (2,*) "zz+ sumene from enesc=",sumenep
6059         costsave=cost2tab(i+1)
6060         sintsave=sint2tab(i+1)
6061         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6062         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6063         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6064         de_dt_num=(sumenep-sumene)/aincr
6065         write (2,*) " t+ sumene from enesc=",sumenep
6066         cost2tab(i+1)=costsave
6067         sint2tab(i+1)=sintsave
6068 C End of diagnostics section.
6069 #endif
6070 C
6071 C Compute the gradient of esc
6072 C
6073 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6074         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6075         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6076         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6077         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6078         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6079         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6080         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6081         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6082         pom1=(sumene3*sint2tab(i+1)+sumene1)
6083      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6084         pom2=(sumene4*cost2tab(i+1)+sumene2)
6085      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6086         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6087         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6088      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6089      &  +x(40)*yy*zz
6090         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6091         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6092      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6093      &  +x(60)*yy*zz
6094         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6095      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6096      &        +(pom1+pom2)*pom_dx
6097 #ifdef DEBUG
6098         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6099 #endif
6100 C
6101         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6102         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6103      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6104      &  +x(40)*xx*zz
6105         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6106         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6107      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6108      &  +x(59)*zz**2 +x(60)*xx*zz
6109         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6110      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6111      &        +(pom1-pom2)*pom_dy
6112 #ifdef DEBUG
6113         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6114 #endif
6115 C
6116         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6117      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6118      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6119      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6120      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6121      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6122      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6123      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6124 #ifdef DEBUG
6125         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6126 #endif
6127 C
6128         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6129      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6130      &  +pom1*pom_dt1+pom2*pom_dt2
6131 #ifdef DEBUG
6132         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6133 #endif
6134 c#undef DEBUG
6135 c
6136 C
6137        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6138        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6139        cosfac2xx=cosfac2*xx
6140        sinfac2yy=sinfac2*yy
6141        do k = 1,3
6142          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6143      &      vbld_inv(i+1)
6144          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6145      &      vbld_inv(i)
6146          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6147          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6148 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6149 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6150 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6151 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6152          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6153          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6154          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6155          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6156          dZZ_Ci1(k)=0.0d0
6157          dZZ_Ci(k)=0.0d0
6158          do j=1,3
6159            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6160      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6161            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6162      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6163          enddo
6164
6165          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6166          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6167          dZZ_XYZ(k)=vbld_inv(i+nres)*
6168      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6169 c
6170          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6171          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6172        enddo
6173
6174        do k=1,3
6175          dXX_Ctab(k,i)=dXX_Ci(k)
6176          dXX_C1tab(k,i)=dXX_Ci1(k)
6177          dYY_Ctab(k,i)=dYY_Ci(k)
6178          dYY_C1tab(k,i)=dYY_Ci1(k)
6179          dZZ_Ctab(k,i)=dZZ_Ci(k)
6180          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6181          dXX_XYZtab(k,i)=dXX_XYZ(k)
6182          dYY_XYZtab(k,i)=dYY_XYZ(k)
6183          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6184        enddo
6185
6186        do k = 1,3
6187 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6188 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6189 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6190 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6191 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6192 c     &    dt_dci(k)
6193 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6194 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6195          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6196      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6197          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6198      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6199          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6200      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6201        enddo
6202 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6203 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6204
6205 C to check gradient call subroutine check_grad
6206
6207     1 continue
6208       enddo
6209       return
6210       end
6211 c------------------------------------------------------------------------------
6212       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6213       implicit none
6214       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6215      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6216       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6217      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6218      &   + x(10)*yy*zz
6219       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6220      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6221      & + x(20)*yy*zz
6222       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6223      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6224      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6225      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6226      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6227      &  +x(40)*xx*yy*zz
6228       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6229      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6230      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6231      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6232      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6233      &  +x(60)*xx*yy*zz
6234       dsc_i   = 0.743d0+x(61)
6235       dp2_i   = 1.9d0+x(62)
6236       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6237      &          *(xx*cost2+yy*sint2))
6238       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6239      &          *(xx*cost2-yy*sint2))
6240       s1=(1+x(63))/(0.1d0 + dscp1)
6241       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6242       s2=(1+x(65))/(0.1d0 + dscp2)
6243       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6244       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6245      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6246       enesc=sumene
6247       return
6248       end
6249 #endif
6250 c------------------------------------------------------------------------------
6251       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6252 C
6253 C This procedure calculates two-body contact function g(rij) and its derivative:
6254 C
6255 C           eps0ij                                     !       x < -1
6256 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6257 C            0                                         !       x > 1
6258 C
6259 C where x=(rij-r0ij)/delta
6260 C
6261 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6262 C
6263       implicit none
6264       double precision rij,r0ij,eps0ij,fcont,fprimcont
6265       double precision x,x2,x4,delta
6266 c     delta=0.02D0*r0ij
6267 c      delta=0.2D0*r0ij
6268       x=(rij-r0ij)/delta
6269       if (x.lt.-1.0D0) then
6270         fcont=eps0ij
6271         fprimcont=0.0D0
6272       else if (x.le.1.0D0) then
6273         x2=x*x
6274         x4=x2*x2
6275         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6276         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6277       else
6278         fcont=0.0D0
6279         fprimcont=0.0D0
6280       endif
6281       return
6282       end
6283 c------------------------------------------------------------------------------
6284       subroutine splinthet(theti,delta,ss,ssder)
6285       implicit real*8 (a-h,o-z)
6286       include 'DIMENSIONS'
6287       include 'COMMON.VAR'
6288       include 'COMMON.GEO'
6289       thetup=pi-delta
6290       thetlow=delta
6291       if (theti.gt.pipol) then
6292         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6293       else
6294         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6295         ssder=-ssder
6296       endif
6297       return
6298       end
6299 c------------------------------------------------------------------------------
6300       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6301       implicit none
6302       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6303       double precision ksi,ksi2,ksi3,a1,a2,a3
6304       a1=fprim0*delta/(f1-f0)
6305       a2=3.0d0-2.0d0*a1
6306       a3=a1-2.0d0
6307       ksi=(x-x0)/delta
6308       ksi2=ksi*ksi
6309       ksi3=ksi2*ksi
6310       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6311       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6312       return
6313       end
6314 c------------------------------------------------------------------------------
6315       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6316       implicit none
6317       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6318       double precision ksi,ksi2,ksi3,a1,a2,a3
6319       ksi=(x-x0)/delta
6320       ksi2=ksi*ksi
6321       ksi3=ksi2*ksi
6322       a1=fprim0x*delta
6323       a2=3*(f1x-f0x)-2*fprim0x*delta
6324       a3=fprim0x*delta-2*(f1x-f0x)
6325       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6326       return
6327       end
6328 C-----------------------------------------------------------------------------
6329 #ifdef CRYST_TOR
6330 C-----------------------------------------------------------------------------
6331       subroutine etor(etors,edihcnstr)
6332       implicit real*8 (a-h,o-z)
6333       include 'DIMENSIONS'
6334       include 'COMMON.VAR'
6335       include 'COMMON.GEO'
6336       include 'COMMON.LOCAL'
6337       include 'COMMON.TORSION'
6338       include 'COMMON.INTERACT'
6339       include 'COMMON.DERIV'
6340       include 'COMMON.CHAIN'
6341       include 'COMMON.NAMES'
6342       include 'COMMON.IOUNITS'
6343       include 'COMMON.FFIELD'
6344       include 'COMMON.TORCNSTR'
6345       include 'COMMON.CONTROL'
6346       logical lprn
6347 C Set lprn=.true. for debugging
6348       lprn=.false.
6349 c      lprn=.true.
6350       etors=0.0D0
6351       do i=iphi_start,iphi_end
6352       etors_ii=0.0D0
6353         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6354      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6355         itori=itortyp(itype(i-2))
6356         itori1=itortyp(itype(i-1))
6357         phii=phi(i)
6358         gloci=0.0D0
6359 C Proline-Proline pair is a special case...
6360         if (itori.eq.3 .and. itori1.eq.3) then
6361           if (phii.gt.-dwapi3) then
6362             cosphi=dcos(3*phii)
6363             fac=1.0D0/(1.0D0-cosphi)
6364             etorsi=v1(1,3,3)*fac
6365             etorsi=etorsi+etorsi
6366             etors=etors+etorsi-v1(1,3,3)
6367             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6368             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6369           endif
6370           do j=1,3
6371             v1ij=v1(j+1,itori,itori1)
6372             v2ij=v2(j+1,itori,itori1)
6373             cosphi=dcos(j*phii)
6374             sinphi=dsin(j*phii)
6375             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6376             if (energy_dec) etors_ii=etors_ii+
6377      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6378             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6379           enddo
6380         else
6381           do j=1,nterm_old
6382             v1ij=v1(j,itori,itori1)
6383             v2ij=v2(j,itori,itori1)
6384             cosphi=dcos(j*phii)
6385             sinphi=dsin(j*phii)
6386             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6387             if (energy_dec) etors_ii=etors_ii+
6388      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6389             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6390           enddo
6391         endif
6392         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6393              'etor',i,etors_ii
6394         if (lprn)
6395      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6396      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6397      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6398         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6399 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6400       enddo
6401 ! 6/20/98 - dihedral angle constraints
6402       edihcnstr=0.0d0
6403       do i=1,ndih_constr
6404         itori=idih_constr(i)
6405         phii=phi(itori)
6406         difi=phii-phi0(i)
6407         if (difi.gt.drange(i)) then
6408           difi=difi-drange(i)
6409           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6410           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6411         else if (difi.lt.-drange(i)) then
6412           difi=difi+drange(i)
6413           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6414           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6415         endif
6416 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6417 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6418       enddo
6419 !      write (iout,*) 'edihcnstr',edihcnstr
6420       return
6421       end
6422 c------------------------------------------------------------------------------
6423       subroutine etor_d(etors_d)
6424       etors_d=0.0d0
6425       return
6426       end
6427 c----------------------------------------------------------------------------
6428 #else
6429       subroutine etor(etors,edihcnstr)
6430       implicit real*8 (a-h,o-z)
6431       include 'DIMENSIONS'
6432       include 'COMMON.VAR'
6433       include 'COMMON.GEO'
6434       include 'COMMON.LOCAL'
6435       include 'COMMON.TORSION'
6436       include 'COMMON.INTERACT'
6437       include 'COMMON.DERIV'
6438       include 'COMMON.CHAIN'
6439       include 'COMMON.NAMES'
6440       include 'COMMON.IOUNITS'
6441       include 'COMMON.FFIELD'
6442       include 'COMMON.TORCNSTR'
6443       include 'COMMON.CONTROL'
6444       logical lprn
6445 C Set lprn=.true. for debugging
6446       lprn=.false.
6447 c     lprn=.true.
6448       etors=0.0D0
6449       do i=iphi_start,iphi_end
6450 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6451 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6452 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6453 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6454         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6455      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6456 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6457 C For introducing the NH3+ and COO- group please check the etor_d for reference
6458 C and guidance
6459         etors_ii=0.0D0
6460          if (iabs(itype(i)).eq.20) then
6461          iblock=2
6462          else
6463          iblock=1
6464          endif
6465         itori=itortyp(itype(i-2))
6466         itori1=itortyp(itype(i-1))
6467         phii=phi(i)
6468         gloci=0.0D0
6469 C Regular cosine and sine terms
6470         do j=1,nterm(itori,itori1,iblock)
6471           v1ij=v1(j,itori,itori1,iblock)
6472           v2ij=v2(j,itori,itori1,iblock)
6473           cosphi=dcos(j*phii)
6474           sinphi=dsin(j*phii)
6475           etors=etors+v1ij*cosphi+v2ij*sinphi
6476           if (energy_dec) etors_ii=etors_ii+
6477      &                v1ij*cosphi+v2ij*sinphi
6478           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6479         enddo
6480 C Lorentz terms
6481 C                         v1
6482 C  E = SUM ----------------------------------- - v1
6483 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6484 C
6485         cosphi=dcos(0.5d0*phii)
6486         sinphi=dsin(0.5d0*phii)
6487         do j=1,nlor(itori,itori1,iblock)
6488           vl1ij=vlor1(j,itori,itori1)
6489           vl2ij=vlor2(j,itori,itori1)
6490           vl3ij=vlor3(j,itori,itori1)
6491           pom=vl2ij*cosphi+vl3ij*sinphi
6492           pom1=1.0d0/(pom*pom+1.0d0)
6493           etors=etors+vl1ij*pom1
6494           if (energy_dec) etors_ii=etors_ii+
6495      &                vl1ij*pom1
6496           pom=-pom*pom1*pom1
6497           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6498         enddo
6499 C Subtract the constant term
6500         etors=etors-v0(itori,itori1,iblock)
6501           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6502      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6503         if (lprn)
6504      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6505      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6506      &  (v1(j,itori,itori1,iblock),j=1,6),
6507      &  (v2(j,itori,itori1,iblock),j=1,6)
6508         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6509 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6510       enddo
6511 ! 6/20/98 - dihedral angle constraints
6512       edihcnstr=0.0d0
6513 c      do i=1,ndih_constr
6514       do i=idihconstr_start,idihconstr_end
6515         itori=idih_constr(i)
6516         phii=phi(itori)
6517         difi=pinorm(phii-phi0(i))
6518         if (difi.gt.drange(i)) then
6519           difi=difi-drange(i)
6520           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6521           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6522         else if (difi.lt.-drange(i)) then
6523           difi=difi+drange(i)
6524           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6525           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6526         else
6527           difi=0.0
6528         endif
6529 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6530 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6531 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6532       enddo
6533 cd       write (iout,*) 'edihcnstr',edihcnstr
6534       return
6535       end
6536 c----------------------------------------------------------------------------
6537       subroutine etor_d(etors_d)
6538 C 6/23/01 Compute double torsional energy
6539       implicit real*8 (a-h,o-z)
6540       include 'DIMENSIONS'
6541       include 'COMMON.VAR'
6542       include 'COMMON.GEO'
6543       include 'COMMON.LOCAL'
6544       include 'COMMON.TORSION'
6545       include 'COMMON.INTERACT'
6546       include 'COMMON.DERIV'
6547       include 'COMMON.CHAIN'
6548       include 'COMMON.NAMES'
6549       include 'COMMON.IOUNITS'
6550       include 'COMMON.FFIELD'
6551       include 'COMMON.TORCNSTR'
6552       logical lprn
6553 C Set lprn=.true. for debugging
6554       lprn=.false.
6555 c     lprn=.true.
6556       etors_d=0.0D0
6557 c      write(iout,*) "a tu??"
6558       do i=iphid_start,iphid_end
6559 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6560 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6561 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6562 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6563 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6564          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6565      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6566      &  (itype(i+1).eq.ntyp1)) cycle
6567 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6568         itori=itortyp(itype(i-2))
6569         itori1=itortyp(itype(i-1))
6570         itori2=itortyp(itype(i))
6571         phii=phi(i)
6572         phii1=phi(i+1)
6573         gloci1=0.0D0
6574         gloci2=0.0D0
6575         iblock=1
6576         if (iabs(itype(i+1)).eq.20) iblock=2
6577 C Iblock=2 Proline type
6578 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6579 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6580 C        if (itype(i+1).eq.ntyp1) iblock=3
6581 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6582 C IS or IS NOT need for this
6583 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6584 C        is (itype(i-3).eq.ntyp1) ntblock=2
6585 C        ntblock is N-terminal blocking group
6586
6587 C Regular cosine and sine terms
6588         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6589 C Example of changes for NH3+ blocking group
6590 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6591 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6592           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6593           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6594           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6595           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6596           cosphi1=dcos(j*phii)
6597           sinphi1=dsin(j*phii)
6598           cosphi2=dcos(j*phii1)
6599           sinphi2=dsin(j*phii1)
6600           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6601      &     v2cij*cosphi2+v2sij*sinphi2
6602           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6603           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6604         enddo
6605         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6606           do l=1,k-1
6607             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6608             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6609             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6610             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6611             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6612             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6613             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6614             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6615             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6616      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6617             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6618      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6619             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6620      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6621           enddo
6622         enddo
6623         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6624         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6625       enddo
6626       return
6627       end
6628 #endif
6629 c------------------------------------------------------------------------------
6630       subroutine eback_sc_corr(esccor)
6631 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6632 c        conformational states; temporarily implemented as differences
6633 c        between UNRES torsional potentials (dependent on three types of
6634 c        residues) and the torsional potentials dependent on all 20 types
6635 c        of residues computed from AM1  energy surfaces of terminally-blocked
6636 c        amino-acid residues.
6637       implicit real*8 (a-h,o-z)
6638       include 'DIMENSIONS'
6639       include 'COMMON.VAR'
6640       include 'COMMON.GEO'
6641       include 'COMMON.LOCAL'
6642       include 'COMMON.TORSION'
6643       include 'COMMON.SCCOR'
6644       include 'COMMON.INTERACT'
6645       include 'COMMON.DERIV'
6646       include 'COMMON.CHAIN'
6647       include 'COMMON.NAMES'
6648       include 'COMMON.IOUNITS'
6649       include 'COMMON.FFIELD'
6650       include 'COMMON.CONTROL'
6651       logical lprn
6652 C Set lprn=.true. for debugging
6653       lprn=.false.
6654 c      lprn=.true.
6655 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6656       esccor=0.0D0
6657       do i=itau_start,itau_end
6658         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6659         esccor_ii=0.0D0
6660         isccori=isccortyp(itype(i-2))
6661         isccori1=isccortyp(itype(i-1))
6662 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6663         phii=phi(i)
6664         do intertyp=1,3 !intertyp
6665 cc Added 09 May 2012 (Adasko)
6666 cc  Intertyp means interaction type of backbone mainchain correlation:
6667 c   1 = SC...Ca...Ca...Ca
6668 c   2 = Ca...Ca...Ca...SC
6669 c   3 = SC...Ca...Ca...SCi
6670         gloci=0.0D0
6671         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6672      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6673      &      (itype(i-1).eq.ntyp1)))
6674      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6675      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6676      &     .or.(itype(i).eq.ntyp1)))
6677      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6678      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6679      &      (itype(i-3).eq.ntyp1)))) cycle
6680         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6681         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6682      & cycle
6683        do j=1,nterm_sccor(isccori,isccori1)
6684           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6685           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6686           cosphi=dcos(j*tauangle(intertyp,i))
6687           sinphi=dsin(j*tauangle(intertyp,i))
6688           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6689           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6690         enddo
6691 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6692         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6693         if (lprn)
6694      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6695      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6696      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6697      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6698         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6699        enddo !intertyp
6700       enddo
6701
6702       return
6703       end
6704 c----------------------------------------------------------------------------
6705       subroutine multibody(ecorr)
6706 C This subroutine calculates multi-body contributions to energy following
6707 C the idea of Skolnick et al. If side chains I and J make a contact and
6708 C at the same time side chains I+1 and J+1 make a contact, an extra
6709 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6710       implicit real*8 (a-h,o-z)
6711       include 'DIMENSIONS'
6712       include 'COMMON.IOUNITS'
6713       include 'COMMON.DERIV'
6714       include 'COMMON.INTERACT'
6715       include 'COMMON.CONTACTS'
6716       double precision gx(3),gx1(3)
6717       logical lprn
6718
6719 C Set lprn=.true. for debugging
6720       lprn=.false.
6721
6722       if (lprn) then
6723         write (iout,'(a)') 'Contact function values:'
6724         do i=nnt,nct-2
6725           write (iout,'(i2,20(1x,i2,f10.5))')
6726      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6727         enddo
6728       endif
6729       ecorr=0.0D0
6730       do i=nnt,nct
6731         do j=1,3
6732           gradcorr(j,i)=0.0D0
6733           gradxorr(j,i)=0.0D0
6734         enddo
6735       enddo
6736       do i=nnt,nct-2
6737
6738         DO ISHIFT = 3,4
6739
6740         i1=i+ishift
6741         num_conti=num_cont(i)
6742         num_conti1=num_cont(i1)
6743         do jj=1,num_conti
6744           j=jcont(jj,i)
6745           do kk=1,num_conti1
6746             j1=jcont(kk,i1)
6747             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6748 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6749 cd   &                   ' ishift=',ishift
6750 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6751 C The system gains extra energy.
6752               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6753             endif   ! j1==j+-ishift
6754           enddo     ! kk
6755         enddo       ! jj
6756
6757         ENDDO ! ISHIFT
6758
6759       enddo         ! i
6760       return
6761       end
6762 c------------------------------------------------------------------------------
6763       double precision function esccorr(i,j,k,l,jj,kk)
6764       implicit real*8 (a-h,o-z)
6765       include 'DIMENSIONS'
6766       include 'COMMON.IOUNITS'
6767       include 'COMMON.DERIV'
6768       include 'COMMON.INTERACT'
6769       include 'COMMON.CONTACTS'
6770       double precision gx(3),gx1(3)
6771       logical lprn
6772       lprn=.false.
6773       eij=facont(jj,i)
6774       ekl=facont(kk,k)
6775 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6776 C Calculate the multi-body contribution to energy.
6777 C Calculate multi-body contributions to the gradient.
6778 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6779 cd   & k,l,(gacont(m,kk,k),m=1,3)
6780       do m=1,3
6781         gx(m) =ekl*gacont(m,jj,i)
6782         gx1(m)=eij*gacont(m,kk,k)
6783         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6784         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6785         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6786         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6787       enddo
6788       do m=i,j-1
6789         do ll=1,3
6790           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6791         enddo
6792       enddo
6793       do m=k,l-1
6794         do ll=1,3
6795           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6796         enddo
6797       enddo
6798       esccorr=-eij*ekl
6799       return
6800       end
6801 c------------------------------------------------------------------------------
6802       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6803 C This subroutine calculates multi-body contributions to hydrogen-bonding
6804       implicit real*8 (a-h,o-z)
6805       include 'DIMENSIONS'
6806       include 'COMMON.IOUNITS'
6807 #ifdef MPI
6808       include "mpif.h"
6809       parameter (max_cont=maxconts)
6810       parameter (max_dim=26)
6811       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6812       double precision zapas(max_dim,maxconts,max_fg_procs),
6813      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6814       common /przechowalnia/ zapas
6815       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6816      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6817 #endif
6818       include 'COMMON.SETUP'
6819       include 'COMMON.FFIELD'
6820       include 'COMMON.DERIV'
6821       include 'COMMON.INTERACT'
6822       include 'COMMON.CONTACTS'
6823       include 'COMMON.CONTROL'
6824       include 'COMMON.LOCAL'
6825       double precision gx(3),gx1(3),time00
6826       logical lprn,ldone
6827
6828 C Set lprn=.true. for debugging
6829       lprn=.false.
6830 #ifdef MPI
6831       n_corr=0
6832       n_corr1=0
6833       if (nfgtasks.le.1) goto 30
6834       if (lprn) then
6835         write (iout,'(a)') 'Contact function values before RECEIVE:'
6836         do i=nnt,nct-2
6837           write (iout,'(2i3,50(1x,i2,f5.2))')
6838      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6839      &    j=1,num_cont_hb(i))
6840         enddo
6841       endif
6842       call flush(iout)
6843       do i=1,ntask_cont_from
6844         ncont_recv(i)=0
6845       enddo
6846       do i=1,ntask_cont_to
6847         ncont_sent(i)=0
6848       enddo
6849 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6850 c     & ntask_cont_to
6851 C Make the list of contacts to send to send to other procesors
6852 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6853 c      call flush(iout)
6854       do i=iturn3_start,iturn3_end
6855 c        write (iout,*) "make contact list turn3",i," num_cont",
6856 c     &    num_cont_hb(i)
6857         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6858       enddo
6859       do i=iturn4_start,iturn4_end
6860 c        write (iout,*) "make contact list turn4",i," num_cont",
6861 c     &   num_cont_hb(i)
6862         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6863       enddo
6864       do ii=1,nat_sent
6865         i=iat_sent(ii)
6866 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6867 c     &    num_cont_hb(i)
6868         do j=1,num_cont_hb(i)
6869         do k=1,4
6870           jjc=jcont_hb(j,i)
6871           iproc=iint_sent_local(k,jjc,ii)
6872 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6873           if (iproc.gt.0) then
6874             ncont_sent(iproc)=ncont_sent(iproc)+1
6875             nn=ncont_sent(iproc)
6876             zapas(1,nn,iproc)=i
6877             zapas(2,nn,iproc)=jjc
6878             zapas(3,nn,iproc)=facont_hb(j,i)
6879             zapas(4,nn,iproc)=ees0p(j,i)
6880             zapas(5,nn,iproc)=ees0m(j,i)
6881             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6882             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6883             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6884             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6885             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6886             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6887             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6888             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6889             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6890             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6891             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6892             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6893             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6894             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6895             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6896             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6897             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6898             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6899             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6900             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6901             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6902           endif
6903         enddo
6904         enddo
6905       enddo
6906       if (lprn) then
6907       write (iout,*)
6908      &  "Numbers of contacts to be sent to other processors",
6909      &  (ncont_sent(i),i=1,ntask_cont_to)
6910       write (iout,*) "Contacts sent"
6911       do ii=1,ntask_cont_to
6912         nn=ncont_sent(ii)
6913         iproc=itask_cont_to(ii)
6914         write (iout,*) nn," contacts to processor",iproc,
6915      &   " of CONT_TO_COMM group"
6916         do i=1,nn
6917           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6918         enddo
6919       enddo
6920       call flush(iout)
6921       endif
6922       CorrelType=477
6923       CorrelID=fg_rank+1
6924       CorrelType1=478
6925       CorrelID1=nfgtasks+fg_rank+1
6926       ireq=0
6927 C Receive the numbers of needed contacts from other processors
6928       do ii=1,ntask_cont_from
6929         iproc=itask_cont_from(ii)
6930         ireq=ireq+1
6931         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6932      &    FG_COMM,req(ireq),IERR)
6933       enddo
6934 c      write (iout,*) "IRECV ended"
6935 c      call flush(iout)
6936 C Send the number of contacts needed by other processors
6937       do ii=1,ntask_cont_to
6938         iproc=itask_cont_to(ii)
6939         ireq=ireq+1
6940         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6941      &    FG_COMM,req(ireq),IERR)
6942       enddo
6943 c      write (iout,*) "ISEND ended"
6944 c      write (iout,*) "number of requests (nn)",ireq
6945       call flush(iout)
6946       if (ireq.gt.0)
6947      &  call MPI_Waitall(ireq,req,status_array,ierr)
6948 c      write (iout,*)
6949 c     &  "Numbers of contacts to be received from other processors",
6950 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6951 c      call flush(iout)
6952 C Receive contacts
6953       ireq=0
6954       do ii=1,ntask_cont_from
6955         iproc=itask_cont_from(ii)
6956         nn=ncont_recv(ii)
6957 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6958 c     &   " of CONT_TO_COMM group"
6959         call flush(iout)
6960         if (nn.gt.0) then
6961           ireq=ireq+1
6962           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6963      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6964 c          write (iout,*) "ireq,req",ireq,req(ireq)
6965         endif
6966       enddo
6967 C Send the contacts to processors that need them
6968       do ii=1,ntask_cont_to
6969         iproc=itask_cont_to(ii)
6970         nn=ncont_sent(ii)
6971 c        write (iout,*) nn," contacts to processor",iproc,
6972 c     &   " of CONT_TO_COMM group"
6973         if (nn.gt.0) then
6974           ireq=ireq+1
6975           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6976      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6977 c          write (iout,*) "ireq,req",ireq,req(ireq)
6978 c          do i=1,nn
6979 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6980 c          enddo
6981         endif
6982       enddo
6983 c      write (iout,*) "number of requests (contacts)",ireq
6984 c      write (iout,*) "req",(req(i),i=1,4)
6985 c      call flush(iout)
6986       if (ireq.gt.0)
6987      & call MPI_Waitall(ireq,req,status_array,ierr)
6988       do iii=1,ntask_cont_from
6989         iproc=itask_cont_from(iii)
6990         nn=ncont_recv(iii)
6991         if (lprn) then
6992         write (iout,*) "Received",nn," contacts from processor",iproc,
6993      &   " of CONT_FROM_COMM group"
6994         call flush(iout)
6995         do i=1,nn
6996           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6997         enddo
6998         call flush(iout)
6999         endif
7000         do i=1,nn
7001           ii=zapas_recv(1,i,iii)
7002 c Flag the received contacts to prevent double-counting
7003           jj=-zapas_recv(2,i,iii)
7004 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7005 c          call flush(iout)
7006           nnn=num_cont_hb(ii)+1
7007           num_cont_hb(ii)=nnn
7008           jcont_hb(nnn,ii)=jj
7009           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7010           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7011           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7012           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7013           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7014           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7015           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7016           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7017           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7018           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7019           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7020           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7021           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7022           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7023           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7024           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7025           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7026           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7027           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7028           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7029           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7030           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7031           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7032           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7033         enddo
7034       enddo
7035       call flush(iout)
7036       if (lprn) then
7037         write (iout,'(a)') 'Contact function values after receive:'
7038         do i=nnt,nct-2
7039           write (iout,'(2i3,50(1x,i3,f5.2))')
7040      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7041      &    j=1,num_cont_hb(i))
7042         enddo
7043         call flush(iout)
7044       endif
7045    30 continue
7046 #endif
7047       if (lprn) then
7048         write (iout,'(a)') 'Contact function values:'
7049         do i=nnt,nct-2
7050           write (iout,'(2i3,50(1x,i3,f5.2))')
7051      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7052      &    j=1,num_cont_hb(i))
7053         enddo
7054       endif
7055       ecorr=0.0D0
7056 C Remove the loop below after debugging !!!
7057       do i=nnt,nct
7058         do j=1,3
7059           gradcorr(j,i)=0.0D0
7060           gradxorr(j,i)=0.0D0
7061         enddo
7062       enddo
7063 C Calculate the local-electrostatic correlation terms
7064       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7065         i1=i+1
7066         num_conti=num_cont_hb(i)
7067         num_conti1=num_cont_hb(i+1)
7068         do jj=1,num_conti
7069           j=jcont_hb(jj,i)
7070           jp=iabs(j)
7071           do kk=1,num_conti1
7072             j1=jcont_hb(kk,i1)
7073             jp1=iabs(j1)
7074 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7075 c     &         ' jj=',jj,' kk=',kk
7076             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7077      &          .or. j.lt.0 .and. j1.gt.0) .and.
7078      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7079 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7080 C The system gains extra energy.
7081               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7082               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7083      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7084               n_corr=n_corr+1
7085             else if (j1.eq.j) then
7086 C Contacts I-J and I-(J+1) occur simultaneously.
7087 C The system loses extra energy.
7088 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7089             endif
7090           enddo ! kk
7091           do kk=1,num_conti
7092             j1=jcont_hb(kk,i)
7093 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7094 c    &         ' jj=',jj,' kk=',kk
7095             if (j1.eq.j+1) then
7096 C Contacts I-J and (I+1)-J occur simultaneously.
7097 C The system loses extra energy.
7098 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7099             endif ! j1==j+1
7100           enddo ! kk
7101         enddo ! jj
7102       enddo ! i
7103       return
7104       end
7105 c------------------------------------------------------------------------------
7106       subroutine add_hb_contact(ii,jj,itask)
7107       implicit real*8 (a-h,o-z)
7108       include "DIMENSIONS"
7109       include "COMMON.IOUNITS"
7110       integer max_cont
7111       integer max_dim
7112       parameter (max_cont=maxconts)
7113       parameter (max_dim=26)
7114       include "COMMON.CONTACTS"
7115       double precision zapas(max_dim,maxconts,max_fg_procs),
7116      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7117       common /przechowalnia/ zapas
7118       integer i,j,ii,jj,iproc,itask(4),nn
7119 c      write (iout,*) "itask",itask
7120       do i=1,2
7121         iproc=itask(i)
7122         if (iproc.gt.0) then
7123           do j=1,num_cont_hb(ii)
7124             jjc=jcont_hb(j,ii)
7125 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7126             if (jjc.eq.jj) then
7127               ncont_sent(iproc)=ncont_sent(iproc)+1
7128               nn=ncont_sent(iproc)
7129               zapas(1,nn,iproc)=ii
7130               zapas(2,nn,iproc)=jjc
7131               zapas(3,nn,iproc)=facont_hb(j,ii)
7132               zapas(4,nn,iproc)=ees0p(j,ii)
7133               zapas(5,nn,iproc)=ees0m(j,ii)
7134               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7135               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7136               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7137               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7138               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7139               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7140               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7141               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7142               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7143               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7144               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7145               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7146               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7147               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7148               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7149               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7150               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7151               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7152               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7153               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7154               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7155               exit
7156             endif
7157           enddo
7158         endif
7159       enddo
7160       return
7161       end
7162 c------------------------------------------------------------------------------
7163       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7164      &  n_corr1)
7165 C This subroutine calculates multi-body contributions to hydrogen-bonding
7166       implicit real*8 (a-h,o-z)
7167       include 'DIMENSIONS'
7168       include 'COMMON.IOUNITS'
7169 #ifdef MPI
7170       include "mpif.h"
7171       parameter (max_cont=maxconts)
7172       parameter (max_dim=70)
7173       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7174       double precision zapas(max_dim,maxconts,max_fg_procs),
7175      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7176       common /przechowalnia/ zapas
7177       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7178      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7179 #endif
7180       include 'COMMON.SETUP'
7181       include 'COMMON.FFIELD'
7182       include 'COMMON.DERIV'
7183       include 'COMMON.LOCAL'
7184       include 'COMMON.INTERACT'
7185       include 'COMMON.CONTACTS'
7186       include 'COMMON.CHAIN'
7187       include 'COMMON.CONTROL'
7188       double precision gx(3),gx1(3)
7189       integer num_cont_hb_old(maxres)
7190       logical lprn,ldone
7191       double precision eello4,eello5,eelo6,eello_turn6
7192       external eello4,eello5,eello6,eello_turn6
7193 C Set lprn=.true. for debugging
7194       lprn=.false.
7195       eturn6=0.0d0
7196 #ifdef MPI
7197       do i=1,nres
7198         num_cont_hb_old(i)=num_cont_hb(i)
7199       enddo
7200       n_corr=0
7201       n_corr1=0
7202       if (nfgtasks.le.1) goto 30
7203       if (lprn) then
7204         write (iout,'(a)') 'Contact function values before RECEIVE:'
7205         do i=nnt,nct-2
7206           write (iout,'(2i3,50(1x,i2,f5.2))')
7207      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7208      &    j=1,num_cont_hb(i))
7209         enddo
7210       endif
7211       call flush(iout)
7212       do i=1,ntask_cont_from
7213         ncont_recv(i)=0
7214       enddo
7215       do i=1,ntask_cont_to
7216         ncont_sent(i)=0
7217       enddo
7218 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7219 c     & ntask_cont_to
7220 C Make the list of contacts to send to send to other procesors
7221       do i=iturn3_start,iturn3_end
7222 c        write (iout,*) "make contact list turn3",i," num_cont",
7223 c     &    num_cont_hb(i)
7224         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7225       enddo
7226       do i=iturn4_start,iturn4_end
7227 c        write (iout,*) "make contact list turn4",i," num_cont",
7228 c     &   num_cont_hb(i)
7229         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7230       enddo
7231       do ii=1,nat_sent
7232         i=iat_sent(ii)
7233 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7234 c     &    num_cont_hb(i)
7235         do j=1,num_cont_hb(i)
7236         do k=1,4
7237           jjc=jcont_hb(j,i)
7238           iproc=iint_sent_local(k,jjc,ii)
7239 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7240           if (iproc.ne.0) then
7241             ncont_sent(iproc)=ncont_sent(iproc)+1
7242             nn=ncont_sent(iproc)
7243             zapas(1,nn,iproc)=i
7244             zapas(2,nn,iproc)=jjc
7245             zapas(3,nn,iproc)=d_cont(j,i)
7246             ind=3
7247             do kk=1,3
7248               ind=ind+1
7249               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7250             enddo
7251             do kk=1,2
7252               do ll=1,2
7253                 ind=ind+1
7254                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7255               enddo
7256             enddo
7257             do jj=1,5
7258               do kk=1,3
7259                 do ll=1,2
7260                   do mm=1,2
7261                     ind=ind+1
7262                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7263                   enddo
7264                 enddo
7265               enddo
7266             enddo
7267           endif
7268         enddo
7269         enddo
7270       enddo
7271       if (lprn) then
7272       write (iout,*)
7273      &  "Numbers of contacts to be sent to other processors",
7274      &  (ncont_sent(i),i=1,ntask_cont_to)
7275       write (iout,*) "Contacts sent"
7276       do ii=1,ntask_cont_to
7277         nn=ncont_sent(ii)
7278         iproc=itask_cont_to(ii)
7279         write (iout,*) nn," contacts to processor",iproc,
7280      &   " of CONT_TO_COMM group"
7281         do i=1,nn
7282           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7283         enddo
7284       enddo
7285       call flush(iout)
7286       endif
7287       CorrelType=477
7288       CorrelID=fg_rank+1
7289       CorrelType1=478
7290       CorrelID1=nfgtasks+fg_rank+1
7291       ireq=0
7292 C Receive the numbers of needed contacts from other processors
7293       do ii=1,ntask_cont_from
7294         iproc=itask_cont_from(ii)
7295         ireq=ireq+1
7296         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7297      &    FG_COMM,req(ireq),IERR)
7298       enddo
7299 c      write (iout,*) "IRECV ended"
7300 c      call flush(iout)
7301 C Send the number of contacts needed by other processors
7302       do ii=1,ntask_cont_to
7303         iproc=itask_cont_to(ii)
7304         ireq=ireq+1
7305         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7306      &    FG_COMM,req(ireq),IERR)
7307       enddo
7308 c      write (iout,*) "ISEND ended"
7309 c      write (iout,*) "number of requests (nn)",ireq
7310       call flush(iout)
7311       if (ireq.gt.0)
7312      &  call MPI_Waitall(ireq,req,status_array,ierr)
7313 c      write (iout,*)
7314 c     &  "Numbers of contacts to be received from other processors",
7315 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7316 c      call flush(iout)
7317 C Receive contacts
7318       ireq=0
7319       do ii=1,ntask_cont_from
7320         iproc=itask_cont_from(ii)
7321         nn=ncont_recv(ii)
7322 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7323 c     &   " of CONT_TO_COMM group"
7324         call flush(iout)
7325         if (nn.gt.0) then
7326           ireq=ireq+1
7327           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7328      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7329 c          write (iout,*) "ireq,req",ireq,req(ireq)
7330         endif
7331       enddo
7332 C Send the contacts to processors that need them
7333       do ii=1,ntask_cont_to
7334         iproc=itask_cont_to(ii)
7335         nn=ncont_sent(ii)
7336 c        write (iout,*) nn," contacts to processor",iproc,
7337 c     &   " of CONT_TO_COMM group"
7338         if (nn.gt.0) then
7339           ireq=ireq+1
7340           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7341      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7342 c          write (iout,*) "ireq,req",ireq,req(ireq)
7343 c          do i=1,nn
7344 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7345 c          enddo
7346         endif
7347       enddo
7348 c      write (iout,*) "number of requests (contacts)",ireq
7349 c      write (iout,*) "req",(req(i),i=1,4)
7350 c      call flush(iout)
7351       if (ireq.gt.0)
7352      & call MPI_Waitall(ireq,req,status_array,ierr)
7353       do iii=1,ntask_cont_from
7354         iproc=itask_cont_from(iii)
7355         nn=ncont_recv(iii)
7356         if (lprn) then
7357         write (iout,*) "Received",nn," contacts from processor",iproc,
7358      &   " of CONT_FROM_COMM group"
7359         call flush(iout)
7360         do i=1,nn
7361           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7362         enddo
7363         call flush(iout)
7364         endif
7365         do i=1,nn
7366           ii=zapas_recv(1,i,iii)
7367 c Flag the received contacts to prevent double-counting
7368           jj=-zapas_recv(2,i,iii)
7369 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7370 c          call flush(iout)
7371           nnn=num_cont_hb(ii)+1
7372           num_cont_hb(ii)=nnn
7373           jcont_hb(nnn,ii)=jj
7374           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7375           ind=3
7376           do kk=1,3
7377             ind=ind+1
7378             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7379           enddo
7380           do kk=1,2
7381             do ll=1,2
7382               ind=ind+1
7383               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7384             enddo
7385           enddo
7386           do jj=1,5
7387             do kk=1,3
7388               do ll=1,2
7389                 do mm=1,2
7390                   ind=ind+1
7391                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7392                 enddo
7393               enddo
7394             enddo
7395           enddo
7396         enddo
7397       enddo
7398       call flush(iout)
7399       if (lprn) then
7400         write (iout,'(a)') 'Contact function values after receive:'
7401         do i=nnt,nct-2
7402           write (iout,'(2i3,50(1x,i3,5f6.3))')
7403      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7404      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7405         enddo
7406         call flush(iout)
7407       endif
7408    30 continue
7409 #endif
7410       if (lprn) then
7411         write (iout,'(a)') 'Contact function values:'
7412         do i=nnt,nct-2
7413           write (iout,'(2i3,50(1x,i2,5f6.3))')
7414      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7415      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7416         enddo
7417       endif
7418       ecorr=0.0D0
7419       ecorr5=0.0d0
7420       ecorr6=0.0d0
7421 C Remove the loop below after debugging !!!
7422       do i=nnt,nct
7423         do j=1,3
7424           gradcorr(j,i)=0.0D0
7425           gradxorr(j,i)=0.0D0
7426         enddo
7427       enddo
7428 C Calculate the dipole-dipole interaction energies
7429       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7430       do i=iatel_s,iatel_e+1
7431         num_conti=num_cont_hb(i)
7432         do jj=1,num_conti
7433           j=jcont_hb(jj,i)
7434 #ifdef MOMENT
7435           call dipole(i,j,jj)
7436 #endif
7437         enddo
7438       enddo
7439       endif
7440 C Calculate the local-electrostatic correlation terms
7441 c                write (iout,*) "gradcorr5 in eello5 before loop"
7442 c                do iii=1,nres
7443 c                  write (iout,'(i5,3f10.5)')
7444 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7445 c                enddo
7446       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7447 c        write (iout,*) "corr loop i",i
7448         i1=i+1
7449         num_conti=num_cont_hb(i)
7450         num_conti1=num_cont_hb(i+1)
7451         do jj=1,num_conti
7452           j=jcont_hb(jj,i)
7453           jp=iabs(j)
7454           do kk=1,num_conti1
7455             j1=jcont_hb(kk,i1)
7456             jp1=iabs(j1)
7457 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7458 c     &         ' jj=',jj,' kk=',kk
7459 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7460             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7461      &          .or. j.lt.0 .and. j1.gt.0) .and.
7462      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7463 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7464 C The system gains extra energy.
7465               n_corr=n_corr+1
7466               sqd1=dsqrt(d_cont(jj,i))
7467               sqd2=dsqrt(d_cont(kk,i1))
7468               sred_geom = sqd1*sqd2
7469               IF (sred_geom.lt.cutoff_corr) THEN
7470                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7471      &            ekont,fprimcont)
7472 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7473 cd     &         ' jj=',jj,' kk=',kk
7474                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7475                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7476                 do l=1,3
7477                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7478                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7479                 enddo
7480                 n_corr1=n_corr1+1
7481 cd               write (iout,*) 'sred_geom=',sred_geom,
7482 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7483 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7484 cd               write (iout,*) "g_contij",g_contij
7485 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7486 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7487                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7488                 if (wcorr4.gt.0.0d0)
7489      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7490                   if (energy_dec.and.wcorr4.gt.0.0d0)
7491      1                 write (iout,'(a6,4i5,0pf7.3)')
7492      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7493 c                write (iout,*) "gradcorr5 before eello5"
7494 c                do iii=1,nres
7495 c                  write (iout,'(i5,3f10.5)')
7496 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7497 c                enddo
7498                 if (wcorr5.gt.0.0d0)
7499      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7500 c                write (iout,*) "gradcorr5 after eello5"
7501 c                do iii=1,nres
7502 c                  write (iout,'(i5,3f10.5)')
7503 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7504 c                enddo
7505                   if (energy_dec.and.wcorr5.gt.0.0d0)
7506      1                 write (iout,'(a6,4i5,0pf7.3)')
7507      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7508 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7509 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7510                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7511      &               .or. wturn6.eq.0.0d0))then
7512 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7513                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7514                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7515      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7516 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7517 cd     &            'ecorr6=',ecorr6
7518 cd                write (iout,'(4e15.5)') sred_geom,
7519 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7520 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7521 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7522                 else if (wturn6.gt.0.0d0
7523      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7524 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7525                   eturn6=eturn6+eello_turn6(i,jj,kk)
7526                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7527      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7528 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7529                 endif
7530               ENDIF
7531 1111          continue
7532             endif
7533           enddo ! kk
7534         enddo ! jj
7535       enddo ! i
7536       do i=1,nres
7537         num_cont_hb(i)=num_cont_hb_old(i)
7538       enddo
7539 c                write (iout,*) "gradcorr5 in eello5"
7540 c                do iii=1,nres
7541 c                  write (iout,'(i5,3f10.5)')
7542 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7543 c                enddo
7544       return
7545       end
7546 c------------------------------------------------------------------------------
7547       subroutine add_hb_contact_eello(ii,jj,itask)
7548       implicit real*8 (a-h,o-z)
7549       include "DIMENSIONS"
7550       include "COMMON.IOUNITS"
7551       integer max_cont
7552       integer max_dim
7553       parameter (max_cont=maxconts)
7554       parameter (max_dim=70)
7555       include "COMMON.CONTACTS"
7556       double precision zapas(max_dim,maxconts,max_fg_procs),
7557      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7558       common /przechowalnia/ zapas
7559       integer i,j,ii,jj,iproc,itask(4),nn
7560 c      write (iout,*) "itask",itask
7561       do i=1,2
7562         iproc=itask(i)
7563         if (iproc.gt.0) then
7564           do j=1,num_cont_hb(ii)
7565             jjc=jcont_hb(j,ii)
7566 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7567             if (jjc.eq.jj) then
7568               ncont_sent(iproc)=ncont_sent(iproc)+1
7569               nn=ncont_sent(iproc)
7570               zapas(1,nn,iproc)=ii
7571               zapas(2,nn,iproc)=jjc
7572               zapas(3,nn,iproc)=d_cont(j,ii)
7573               ind=3
7574               do kk=1,3
7575                 ind=ind+1
7576                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7577               enddo
7578               do kk=1,2
7579                 do ll=1,2
7580                   ind=ind+1
7581                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7582                 enddo
7583               enddo
7584               do jj=1,5
7585                 do kk=1,3
7586                   do ll=1,2
7587                     do mm=1,2
7588                       ind=ind+1
7589                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7590                     enddo
7591                   enddo
7592                 enddo
7593               enddo
7594               exit
7595             endif
7596           enddo
7597         endif
7598       enddo
7599       return
7600       end
7601 c------------------------------------------------------------------------------
7602       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7603       implicit real*8 (a-h,o-z)
7604       include 'DIMENSIONS'
7605       include 'COMMON.IOUNITS'
7606       include 'COMMON.DERIV'
7607       include 'COMMON.INTERACT'
7608       include 'COMMON.CONTACTS'
7609       double precision gx(3),gx1(3)
7610       logical lprn
7611       lprn=.false.
7612       eij=facont_hb(jj,i)
7613       ekl=facont_hb(kk,k)
7614       ees0pij=ees0p(jj,i)
7615       ees0pkl=ees0p(kk,k)
7616       ees0mij=ees0m(jj,i)
7617       ees0mkl=ees0m(kk,k)
7618       ekont=eij*ekl
7619       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7620 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7621 C Following 4 lines for diagnostics.
7622 cd    ees0pkl=0.0D0
7623 cd    ees0pij=1.0D0
7624 cd    ees0mkl=0.0D0
7625 cd    ees0mij=1.0D0
7626 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7627 c     & 'Contacts ',i,j,
7628 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7629 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7630 c     & 'gradcorr_long'
7631 C Calculate the multi-body contribution to energy.
7632 c      ecorr=ecorr+ekont*ees
7633 C Calculate multi-body contributions to the gradient.
7634       coeffpees0pij=coeffp*ees0pij
7635       coeffmees0mij=coeffm*ees0mij
7636       coeffpees0pkl=coeffp*ees0pkl
7637       coeffmees0mkl=coeffm*ees0mkl
7638       do ll=1,3
7639 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7640         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7641      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7642      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7643         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7644      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7645      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7646 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7647         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7648      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7649      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7650         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7651      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7652      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7653         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7654      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7655      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7656         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7657         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7658         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7659      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7660      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7661         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7662         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7663 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7664       enddo
7665 c      write (iout,*)
7666 cgrad      do m=i+1,j-1
7667 cgrad        do ll=1,3
7668 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7669 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7670 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7671 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7672 cgrad        enddo
7673 cgrad      enddo
7674 cgrad      do m=k+1,l-1
7675 cgrad        do ll=1,3
7676 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7677 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7678 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7679 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7680 cgrad        enddo
7681 cgrad      enddo
7682 c      write (iout,*) "ehbcorr",ekont*ees
7683       ehbcorr=ekont*ees
7684       return
7685       end
7686 #ifdef MOMENT
7687 C---------------------------------------------------------------------------
7688       subroutine dipole(i,j,jj)
7689       implicit real*8 (a-h,o-z)
7690       include 'DIMENSIONS'
7691       include 'COMMON.IOUNITS'
7692       include 'COMMON.CHAIN'
7693       include 'COMMON.FFIELD'
7694       include 'COMMON.DERIV'
7695       include 'COMMON.INTERACT'
7696       include 'COMMON.CONTACTS'
7697       include 'COMMON.TORSION'
7698       include 'COMMON.VAR'
7699       include 'COMMON.GEO'
7700       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7701      &  auxmat(2,2)
7702       iti1 = itortyp(itype(i+1))
7703       if (j.lt.nres-1) then
7704         itj1 = itortyp(itype(j+1))
7705       else
7706         itj1=ntortyp
7707       endif
7708       do iii=1,2
7709         dipi(iii,1)=Ub2(iii,i)
7710         dipderi(iii)=Ub2der(iii,i)
7711         dipi(iii,2)=b1(iii,i+1)
7712         dipj(iii,1)=Ub2(iii,j)
7713         dipderj(iii)=Ub2der(iii,j)
7714         dipj(iii,2)=b1(iii,j+1)
7715       enddo
7716       kkk=0
7717       do iii=1,2
7718         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7719         do jjj=1,2
7720           kkk=kkk+1
7721           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7722         enddo
7723       enddo
7724       do kkk=1,5
7725         do lll=1,3
7726           mmm=0
7727           do iii=1,2
7728             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7729      &        auxvec(1))
7730             do jjj=1,2
7731               mmm=mmm+1
7732               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7733             enddo
7734           enddo
7735         enddo
7736       enddo
7737       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7738       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7739       do iii=1,2
7740         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7741       enddo
7742       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7743       do iii=1,2
7744         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7745       enddo
7746       return
7747       end
7748 #endif
7749 C---------------------------------------------------------------------------
7750       subroutine calc_eello(i,j,k,l,jj,kk)
7751 C
7752 C This subroutine computes matrices and vectors needed to calculate
7753 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7754 C
7755       implicit real*8 (a-h,o-z)
7756       include 'DIMENSIONS'
7757       include 'COMMON.IOUNITS'
7758       include 'COMMON.CHAIN'
7759       include 'COMMON.DERIV'
7760       include 'COMMON.INTERACT'
7761       include 'COMMON.CONTACTS'
7762       include 'COMMON.TORSION'
7763       include 'COMMON.VAR'
7764       include 'COMMON.GEO'
7765       include 'COMMON.FFIELD'
7766       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7767      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7768       logical lprn
7769       common /kutas/ lprn
7770 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7771 cd     & ' jj=',jj,' kk=',kk
7772 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7773 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7774 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7775       do iii=1,2
7776         do jjj=1,2
7777           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7778           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7779         enddo
7780       enddo
7781       call transpose2(aa1(1,1),aa1t(1,1))
7782       call transpose2(aa2(1,1),aa2t(1,1))
7783       do kkk=1,5
7784         do lll=1,3
7785           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7786      &      aa1tder(1,1,lll,kkk))
7787           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7788      &      aa2tder(1,1,lll,kkk))
7789         enddo
7790       enddo
7791       if (l.eq.j+1) then
7792 C parallel orientation of the two CA-CA-CA frames.
7793         if (i.gt.1) then
7794           iti=itortyp(itype(i))
7795         else
7796           iti=ntortyp
7797         endif
7798         itk1=itortyp(itype(k+1))
7799         itj=itortyp(itype(j))
7800         if (l.lt.nres-1) then
7801           itl1=itortyp(itype(l+1))
7802         else
7803           itl1=ntortyp
7804         endif
7805 C A1 kernel(j+1) A2T
7806 cd        do iii=1,2
7807 cd          write (iout,'(3f10.5,5x,3f10.5)')
7808 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7809 cd        enddo
7810         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7811      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7812      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7813 C Following matrices are needed only for 6-th order cumulants
7814         IF (wcorr6.gt.0.0d0) THEN
7815         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7816      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7817      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7818         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7819      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7820      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7821      &   ADtEAderx(1,1,1,1,1,1))
7822         lprn=.false.
7823         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7824      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7825      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7826      &   ADtEA1derx(1,1,1,1,1,1))
7827         ENDIF
7828 C End 6-th order cumulants
7829 cd        lprn=.false.
7830 cd        if (lprn) then
7831 cd        write (2,*) 'In calc_eello6'
7832 cd        do iii=1,2
7833 cd          write (2,*) 'iii=',iii
7834 cd          do kkk=1,5
7835 cd            write (2,*) 'kkk=',kkk
7836 cd            do jjj=1,2
7837 cd              write (2,'(3(2f10.5),5x)')
7838 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7839 cd            enddo
7840 cd          enddo
7841 cd        enddo
7842 cd        endif
7843         call transpose2(EUgder(1,1,k),auxmat(1,1))
7844         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7845         call transpose2(EUg(1,1,k),auxmat(1,1))
7846         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7847         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7848         do iii=1,2
7849           do kkk=1,5
7850             do lll=1,3
7851               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7852      &          EAEAderx(1,1,lll,kkk,iii,1))
7853             enddo
7854           enddo
7855         enddo
7856 C A1T kernel(i+1) A2
7857         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7858      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7859      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7860 C Following matrices are needed only for 6-th order cumulants
7861         IF (wcorr6.gt.0.0d0) THEN
7862         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7863      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7864      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7865         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7866      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7867      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7868      &   ADtEAderx(1,1,1,1,1,2))
7869         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7870      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7871      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7872      &   ADtEA1derx(1,1,1,1,1,2))
7873         ENDIF
7874 C End 6-th order cumulants
7875         call transpose2(EUgder(1,1,l),auxmat(1,1))
7876         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7877         call transpose2(EUg(1,1,l),auxmat(1,1))
7878         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7879         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7880         do iii=1,2
7881           do kkk=1,5
7882             do lll=1,3
7883               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7884      &          EAEAderx(1,1,lll,kkk,iii,2))
7885             enddo
7886           enddo
7887         enddo
7888 C AEAb1 and AEAb2
7889 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7890 C They are needed only when the fifth- or the sixth-order cumulants are
7891 C indluded.
7892         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7893         call transpose2(AEA(1,1,1),auxmat(1,1))
7894         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7895         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7896         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7897         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7898         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7899         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7900         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7901         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7902         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7903         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7904         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7905         call transpose2(AEA(1,1,2),auxmat(1,1))
7906         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7907         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7908         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7909         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7910         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7911         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7912         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7913         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7914         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7915         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7916         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7917 C Calculate the Cartesian derivatives of the vectors.
7918         do iii=1,2
7919           do kkk=1,5
7920             do lll=1,3
7921               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7922               call matvec2(auxmat(1,1),b1(1,i),
7923      &          AEAb1derx(1,lll,kkk,iii,1,1))
7924               call matvec2(auxmat(1,1),Ub2(1,i),
7925      &          AEAb2derx(1,lll,kkk,iii,1,1))
7926               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7927      &          AEAb1derx(1,lll,kkk,iii,2,1))
7928               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7929      &          AEAb2derx(1,lll,kkk,iii,2,1))
7930               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7931               call matvec2(auxmat(1,1),b1(1,j),
7932      &          AEAb1derx(1,lll,kkk,iii,1,2))
7933               call matvec2(auxmat(1,1),Ub2(1,j),
7934      &          AEAb2derx(1,lll,kkk,iii,1,2))
7935               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7936      &          AEAb1derx(1,lll,kkk,iii,2,2))
7937               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7938      &          AEAb2derx(1,lll,kkk,iii,2,2))
7939             enddo
7940           enddo
7941         enddo
7942         ENDIF
7943 C End vectors
7944       else
7945 C Antiparallel orientation of the two CA-CA-CA frames.
7946         if (i.gt.1) then
7947           iti=itortyp(itype(i))
7948         else
7949           iti=ntortyp
7950         endif
7951         itk1=itortyp(itype(k+1))
7952         itl=itortyp(itype(l))
7953         itj=itortyp(itype(j))
7954         if (j.lt.nres-1) then
7955           itj1=itortyp(itype(j+1))
7956         else
7957           itj1=ntortyp
7958         endif
7959 C A2 kernel(j-1)T A1T
7960         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7961      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7962      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7963 C Following matrices are needed only for 6-th order cumulants
7964         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7965      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7966         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7967      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7968      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7969         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7970      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7971      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7972      &   ADtEAderx(1,1,1,1,1,1))
7973         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7974      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7975      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7976      &   ADtEA1derx(1,1,1,1,1,1))
7977         ENDIF
7978 C End 6-th order cumulants
7979         call transpose2(EUgder(1,1,k),auxmat(1,1))
7980         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7981         call transpose2(EUg(1,1,k),auxmat(1,1))
7982         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7983         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7984         do iii=1,2
7985           do kkk=1,5
7986             do lll=1,3
7987               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7988      &          EAEAderx(1,1,lll,kkk,iii,1))
7989             enddo
7990           enddo
7991         enddo
7992 C A2T kernel(i+1)T A1
7993         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7994      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7995      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7996 C Following matrices are needed only for 6-th order cumulants
7997         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7998      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7999         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8000      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8001      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8002         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8003      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8004      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8005      &   ADtEAderx(1,1,1,1,1,2))
8006         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8007      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8008      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8009      &   ADtEA1derx(1,1,1,1,1,2))
8010         ENDIF
8011 C End 6-th order cumulants
8012         call transpose2(EUgder(1,1,j),auxmat(1,1))
8013         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8014         call transpose2(EUg(1,1,j),auxmat(1,1))
8015         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8016         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8017         do iii=1,2
8018           do kkk=1,5
8019             do lll=1,3
8020               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8021      &          EAEAderx(1,1,lll,kkk,iii,2))
8022             enddo
8023           enddo
8024         enddo
8025 C AEAb1 and AEAb2
8026 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8027 C They are needed only when the fifth- or the sixth-order cumulants are
8028 C indluded.
8029         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8030      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8031         call transpose2(AEA(1,1,1),auxmat(1,1))
8032         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8034         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8035         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8036         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8037         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8038         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8039         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8040         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8041         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8042         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8043         call transpose2(AEA(1,1,2),auxmat(1,1))
8044         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8045         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8046         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8047         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8048         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8049         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8050         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8051         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8052         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8053         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8054         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8055 C Calculate the Cartesian derivatives of the vectors.
8056         do iii=1,2
8057           do kkk=1,5
8058             do lll=1,3
8059               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8060               call matvec2(auxmat(1,1),b1(1,i),
8061      &          AEAb1derx(1,lll,kkk,iii,1,1))
8062               call matvec2(auxmat(1,1),Ub2(1,i),
8063      &          AEAb2derx(1,lll,kkk,iii,1,1))
8064               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8065      &          AEAb1derx(1,lll,kkk,iii,2,1))
8066               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8067      &          AEAb2derx(1,lll,kkk,iii,2,1))
8068               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8069               call matvec2(auxmat(1,1),b1(1,l),
8070      &          AEAb1derx(1,lll,kkk,iii,1,2))
8071               call matvec2(auxmat(1,1),Ub2(1,l),
8072      &          AEAb2derx(1,lll,kkk,iii,1,2))
8073               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8074      &          AEAb1derx(1,lll,kkk,iii,2,2))
8075               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8076      &          AEAb2derx(1,lll,kkk,iii,2,2))
8077             enddo
8078           enddo
8079         enddo
8080         ENDIF
8081 C End vectors
8082       endif
8083       return
8084       end
8085 C---------------------------------------------------------------------------
8086       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8087      &  KK,KKderg,AKA,AKAderg,AKAderx)
8088       implicit none
8089       integer nderg
8090       logical transp
8091       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8092      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8093      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8094       integer iii,kkk,lll
8095       integer jjj,mmm
8096       logical lprn
8097       common /kutas/ lprn
8098       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8099       do iii=1,nderg
8100         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8101      &    AKAderg(1,1,iii))
8102       enddo
8103 cd      if (lprn) write (2,*) 'In kernel'
8104       do kkk=1,5
8105 cd        if (lprn) write (2,*) 'kkk=',kkk
8106         do lll=1,3
8107           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8108      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8109 cd          if (lprn) then
8110 cd            write (2,*) 'lll=',lll
8111 cd            write (2,*) 'iii=1'
8112 cd            do jjj=1,2
8113 cd              write (2,'(3(2f10.5),5x)')
8114 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8115 cd            enddo
8116 cd          endif
8117           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8118      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8119 cd          if (lprn) then
8120 cd            write (2,*) 'lll=',lll
8121 cd            write (2,*) 'iii=2'
8122 cd            do jjj=1,2
8123 cd              write (2,'(3(2f10.5),5x)')
8124 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8125 cd            enddo
8126 cd          endif
8127         enddo
8128       enddo
8129       return
8130       end
8131 C---------------------------------------------------------------------------
8132       double precision function eello4(i,j,k,l,jj,kk)
8133       implicit real*8 (a-h,o-z)
8134       include 'DIMENSIONS'
8135       include 'COMMON.IOUNITS'
8136       include 'COMMON.CHAIN'
8137       include 'COMMON.DERIV'
8138       include 'COMMON.INTERACT'
8139       include 'COMMON.CONTACTS'
8140       include 'COMMON.TORSION'
8141       include 'COMMON.VAR'
8142       include 'COMMON.GEO'
8143       double precision pizda(2,2),ggg1(3),ggg2(3)
8144 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8145 cd        eello4=0.0d0
8146 cd        return
8147 cd      endif
8148 cd      print *,'eello4:',i,j,k,l,jj,kk
8149 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8150 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8151 cold      eij=facont_hb(jj,i)
8152 cold      ekl=facont_hb(kk,k)
8153 cold      ekont=eij*ekl
8154       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8155 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8156       gcorr_loc(k-1)=gcorr_loc(k-1)
8157      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8158       if (l.eq.j+1) then
8159         gcorr_loc(l-1)=gcorr_loc(l-1)
8160      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8161       else
8162         gcorr_loc(j-1)=gcorr_loc(j-1)
8163      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8164       endif
8165       do iii=1,2
8166         do kkk=1,5
8167           do lll=1,3
8168             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8169      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8170 cd            derx(lll,kkk,iii)=0.0d0
8171           enddo
8172         enddo
8173       enddo
8174 cd      gcorr_loc(l-1)=0.0d0
8175 cd      gcorr_loc(j-1)=0.0d0
8176 cd      gcorr_loc(k-1)=0.0d0
8177 cd      eel4=1.0d0
8178 cd      write (iout,*)'Contacts have occurred for peptide groups',
8179 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8180 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8181       if (j.lt.nres-1) then
8182         j1=j+1
8183         j2=j-1
8184       else
8185         j1=j-1
8186         j2=j-2
8187       endif
8188       if (l.lt.nres-1) then
8189         l1=l+1
8190         l2=l-1
8191       else
8192         l1=l-1
8193         l2=l-2
8194       endif
8195       do ll=1,3
8196 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8197 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8198         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8199         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8200 cgrad        ghalf=0.5d0*ggg1(ll)
8201         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8202         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8203         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8204         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8205         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8206         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8207 cgrad        ghalf=0.5d0*ggg2(ll)
8208         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8209         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8210         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8211         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8212         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8213         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8214       enddo
8215 cgrad      do m=i+1,j-1
8216 cgrad        do ll=1,3
8217 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8218 cgrad        enddo
8219 cgrad      enddo
8220 cgrad      do m=k+1,l-1
8221 cgrad        do ll=1,3
8222 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8223 cgrad        enddo
8224 cgrad      enddo
8225 cgrad      do m=i+2,j2
8226 cgrad        do ll=1,3
8227 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8228 cgrad        enddo
8229 cgrad      enddo
8230 cgrad      do m=k+2,l2
8231 cgrad        do ll=1,3
8232 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8233 cgrad        enddo
8234 cgrad      enddo
8235 cd      do iii=1,nres-3
8236 cd        write (2,*) iii,gcorr_loc(iii)
8237 cd      enddo
8238       eello4=ekont*eel4
8239 cd      write (2,*) 'ekont',ekont
8240 cd      write (iout,*) 'eello4',ekont*eel4
8241       return
8242       end
8243 C---------------------------------------------------------------------------
8244       double precision function eello5(i,j,k,l,jj,kk)
8245       implicit real*8 (a-h,o-z)
8246       include 'DIMENSIONS'
8247       include 'COMMON.IOUNITS'
8248       include 'COMMON.CHAIN'
8249       include 'COMMON.DERIV'
8250       include 'COMMON.INTERACT'
8251       include 'COMMON.CONTACTS'
8252       include 'COMMON.TORSION'
8253       include 'COMMON.VAR'
8254       include 'COMMON.GEO'
8255       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8256       double precision ggg1(3),ggg2(3)
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 C                                                                              C
8259 C                            Parallel chains                                   C
8260 C                                                                              C
8261 C          o             o                   o             o                   C
8262 C         /l\           / \             \   / \           / \   /              C
8263 C        /   \         /   \             \ /   \         /   \ /               C
8264 C       j| o |l1       | o |              o| o |         | o |o                C
8265 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8266 C      \i/   \         /   \ /             /   \         /   \                 C
8267 C       o    k1             o                                                  C
8268 C         (I)          (II)                (III)          (IV)                 C
8269 C                                                                              C
8270 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8271 C                                                                              C
8272 C                            Antiparallel chains                               C
8273 C                                                                              C
8274 C          o             o                   o             o                   C
8275 C         /j\           / \             \   / \           / \   /              C
8276 C        /   \         /   \             \ /   \         /   \ /               C
8277 C      j1| o |l        | o |              o| o |         | o |o                C
8278 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8279 C      \i/   \         /   \ /             /   \         /   \                 C
8280 C       o     k1            o                                                  C
8281 C         (I)          (II)                (III)          (IV)                 C
8282 C                                                                              C
8283 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8284 C                                                                              C
8285 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8286 C                                                                              C
8287 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8288 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8289 cd        eello5=0.0d0
8290 cd        return
8291 cd      endif
8292 cd      write (iout,*)
8293 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8294 cd     &   ' and',k,l
8295       itk=itortyp(itype(k))
8296       itl=itortyp(itype(l))
8297       itj=itortyp(itype(j))
8298       eello5_1=0.0d0
8299       eello5_2=0.0d0
8300       eello5_3=0.0d0
8301       eello5_4=0.0d0
8302 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8303 cd     &   eel5_3_num,eel5_4_num)
8304       do iii=1,2
8305         do kkk=1,5
8306           do lll=1,3
8307             derx(lll,kkk,iii)=0.0d0
8308           enddo
8309         enddo
8310       enddo
8311 cd      eij=facont_hb(jj,i)
8312 cd      ekl=facont_hb(kk,k)
8313 cd      ekont=eij*ekl
8314 cd      write (iout,*)'Contacts have occurred for peptide groups',
8315 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8316 cd      goto 1111
8317 C Contribution from the graph I.
8318 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8319 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8320       call transpose2(EUg(1,1,k),auxmat(1,1))
8321       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8322       vv(1)=pizda(1,1)-pizda(2,2)
8323       vv(2)=pizda(1,2)+pizda(2,1)
8324       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8325      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8326 C Explicit gradient in virtual-dihedral angles.
8327       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8328      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8329      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8330       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8331       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8332       vv(1)=pizda(1,1)-pizda(2,2)
8333       vv(2)=pizda(1,2)+pizda(2,1)
8334       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8335      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8336      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8337       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8338       vv(1)=pizda(1,1)-pizda(2,2)
8339       vv(2)=pizda(1,2)+pizda(2,1)
8340       if (l.eq.j+1) then
8341         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8342      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8343      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8344       else
8345         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8346      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8347      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8348       endif
8349 C Cartesian gradient
8350       do iii=1,2
8351         do kkk=1,5
8352           do lll=1,3
8353             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8354      &        pizda(1,1))
8355             vv(1)=pizda(1,1)-pizda(2,2)
8356             vv(2)=pizda(1,2)+pizda(2,1)
8357             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8358      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8359      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8360           enddo
8361         enddo
8362       enddo
8363 c      goto 1112
8364 c1111  continue
8365 C Contribution from graph II
8366       call transpose2(EE(1,1,itk),auxmat(1,1))
8367       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8368       vv(1)=pizda(1,1)+pizda(2,2)
8369       vv(2)=pizda(2,1)-pizda(1,2)
8370       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8371      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8372 C Explicit gradient in virtual-dihedral angles.
8373       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8374      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8375       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8376       vv(1)=pizda(1,1)+pizda(2,2)
8377       vv(2)=pizda(2,1)-pizda(1,2)
8378       if (l.eq.j+1) then
8379         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8380      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8381      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8382       else
8383         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8384      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8385      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8386       endif
8387 C Cartesian gradient
8388       do iii=1,2
8389         do kkk=1,5
8390           do lll=1,3
8391             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8392      &        pizda(1,1))
8393             vv(1)=pizda(1,1)+pizda(2,2)
8394             vv(2)=pizda(2,1)-pizda(1,2)
8395             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8396      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8397      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8398           enddo
8399         enddo
8400       enddo
8401 cd      goto 1112
8402 cd1111  continue
8403       if (l.eq.j+1) then
8404 cd        goto 1110
8405 C Parallel orientation
8406 C Contribution from graph III
8407         call transpose2(EUg(1,1,l),auxmat(1,1))
8408         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8409         vv(1)=pizda(1,1)-pizda(2,2)
8410         vv(2)=pizda(1,2)+pizda(2,1)
8411         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8412      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8413 C Explicit gradient in virtual-dihedral angles.
8414         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8415      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8416      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8417         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8418         vv(1)=pizda(1,1)-pizda(2,2)
8419         vv(2)=pizda(1,2)+pizda(2,1)
8420         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8421      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8422      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8423         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8424         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8425         vv(1)=pizda(1,1)-pizda(2,2)
8426         vv(2)=pizda(1,2)+pizda(2,1)
8427         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8428      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8429      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8430 C Cartesian gradient
8431         do iii=1,2
8432           do kkk=1,5
8433             do lll=1,3
8434               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8435      &          pizda(1,1))
8436               vv(1)=pizda(1,1)-pizda(2,2)
8437               vv(2)=pizda(1,2)+pizda(2,1)
8438               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8439      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8440      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8441             enddo
8442           enddo
8443         enddo
8444 cd        goto 1112
8445 C Contribution from graph IV
8446 cd1110    continue
8447         call transpose2(EE(1,1,itl),auxmat(1,1))
8448         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8449         vv(1)=pizda(1,1)+pizda(2,2)
8450         vv(2)=pizda(2,1)-pizda(1,2)
8451         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8452      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8453 C Explicit gradient in virtual-dihedral angles.
8454         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8455      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8456         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8457         vv(1)=pizda(1,1)+pizda(2,2)
8458         vv(2)=pizda(2,1)-pizda(1,2)
8459         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8460      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8461      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8462 C Cartesian gradient
8463         do iii=1,2
8464           do kkk=1,5
8465             do lll=1,3
8466               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8467      &          pizda(1,1))
8468               vv(1)=pizda(1,1)+pizda(2,2)
8469               vv(2)=pizda(2,1)-pizda(1,2)
8470               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8471      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8472      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8473             enddo
8474           enddo
8475         enddo
8476       else
8477 C Antiparallel orientation
8478 C Contribution from graph III
8479 c        goto 1110
8480         call transpose2(EUg(1,1,j),auxmat(1,1))
8481         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8482         vv(1)=pizda(1,1)-pizda(2,2)
8483         vv(2)=pizda(1,2)+pizda(2,1)
8484         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8485      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8486 C Explicit gradient in virtual-dihedral angles.
8487         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8488      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8489      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8490         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8491         vv(1)=pizda(1,1)-pizda(2,2)
8492         vv(2)=pizda(1,2)+pizda(2,1)
8493         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8494      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8495      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8496         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8497         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8498         vv(1)=pizda(1,1)-pizda(2,2)
8499         vv(2)=pizda(1,2)+pizda(2,1)
8500         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8501      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8502      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8503 C Cartesian gradient
8504         do iii=1,2
8505           do kkk=1,5
8506             do lll=1,3
8507               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8508      &          pizda(1,1))
8509               vv(1)=pizda(1,1)-pizda(2,2)
8510               vv(2)=pizda(1,2)+pizda(2,1)
8511               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8512      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8513      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8514             enddo
8515           enddo
8516         enddo
8517 cd        goto 1112
8518 C Contribution from graph IV
8519 1110    continue
8520         call transpose2(EE(1,1,itj),auxmat(1,1))
8521         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8522         vv(1)=pizda(1,1)+pizda(2,2)
8523         vv(2)=pizda(2,1)-pizda(1,2)
8524         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8525      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8526 C Explicit gradient in virtual-dihedral angles.
8527         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8528      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8529         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8530         vv(1)=pizda(1,1)+pizda(2,2)
8531         vv(2)=pizda(2,1)-pizda(1,2)
8532         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8533      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8534      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8535 C Cartesian gradient
8536         do iii=1,2
8537           do kkk=1,5
8538             do lll=1,3
8539               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8540      &          pizda(1,1))
8541               vv(1)=pizda(1,1)+pizda(2,2)
8542               vv(2)=pizda(2,1)-pizda(1,2)
8543               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8544      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8545      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8546             enddo
8547           enddo
8548         enddo
8549       endif
8550 1112  continue
8551       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8552 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8553 cd        write (2,*) 'ijkl',i,j,k,l
8554 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8555 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8556 cd      endif
8557 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8558 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8559 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8560 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8561       if (j.lt.nres-1) then
8562         j1=j+1
8563         j2=j-1
8564       else
8565         j1=j-1
8566         j2=j-2
8567       endif
8568       if (l.lt.nres-1) then
8569         l1=l+1
8570         l2=l-1
8571       else
8572         l1=l-1
8573         l2=l-2
8574       endif
8575 cd      eij=1.0d0
8576 cd      ekl=1.0d0
8577 cd      ekont=1.0d0
8578 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8579 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8580 C        summed up outside the subrouine as for the other subroutines
8581 C        handling long-range interactions. The old code is commented out
8582 C        with "cgrad" to keep track of changes.
8583       do ll=1,3
8584 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8585 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8586         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8587         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8588 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8589 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8590 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8591 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8592 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8593 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8594 c     &   gradcorr5ij,
8595 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8596 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8597 cgrad        ghalf=0.5d0*ggg1(ll)
8598 cd        ghalf=0.0d0
8599         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8600         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8601         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8602         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8603         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8604         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8605 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8606 cgrad        ghalf=0.5d0*ggg2(ll)
8607 cd        ghalf=0.0d0
8608         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8609         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8610         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8611         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8612         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8613         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8614       enddo
8615 cd      goto 1112
8616 cgrad      do m=i+1,j-1
8617 cgrad        do ll=1,3
8618 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8619 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8620 cgrad        enddo
8621 cgrad      enddo
8622 cgrad      do m=k+1,l-1
8623 cgrad        do ll=1,3
8624 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8625 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8626 cgrad        enddo
8627 cgrad      enddo
8628 c1112  continue
8629 cgrad      do m=i+2,j2
8630 cgrad        do ll=1,3
8631 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8632 cgrad        enddo
8633 cgrad      enddo
8634 cgrad      do m=k+2,l2
8635 cgrad        do ll=1,3
8636 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8637 cgrad        enddo
8638 cgrad      enddo
8639 cd      do iii=1,nres-3
8640 cd        write (2,*) iii,g_corr5_loc(iii)
8641 cd      enddo
8642       eello5=ekont*eel5
8643 cd      write (2,*) 'ekont',ekont
8644 cd      write (iout,*) 'eello5',ekont*eel5
8645       return
8646       end
8647 c--------------------------------------------------------------------------
8648       double precision function eello6(i,j,k,l,jj,kk)
8649       implicit real*8 (a-h,o-z)
8650       include 'DIMENSIONS'
8651       include 'COMMON.IOUNITS'
8652       include 'COMMON.CHAIN'
8653       include 'COMMON.DERIV'
8654       include 'COMMON.INTERACT'
8655       include 'COMMON.CONTACTS'
8656       include 'COMMON.TORSION'
8657       include 'COMMON.VAR'
8658       include 'COMMON.GEO'
8659       include 'COMMON.FFIELD'
8660       double precision ggg1(3),ggg2(3)
8661 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8662 cd        eello6=0.0d0
8663 cd        return
8664 cd      endif
8665 cd      write (iout,*)
8666 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8667 cd     &   ' and',k,l
8668       eello6_1=0.0d0
8669       eello6_2=0.0d0
8670       eello6_3=0.0d0
8671       eello6_4=0.0d0
8672       eello6_5=0.0d0
8673       eello6_6=0.0d0
8674 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8675 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8676       do iii=1,2
8677         do kkk=1,5
8678           do lll=1,3
8679             derx(lll,kkk,iii)=0.0d0
8680           enddo
8681         enddo
8682       enddo
8683 cd      eij=facont_hb(jj,i)
8684 cd      ekl=facont_hb(kk,k)
8685 cd      ekont=eij*ekl
8686 cd      eij=1.0d0
8687 cd      ekl=1.0d0
8688 cd      ekont=1.0d0
8689       if (l.eq.j+1) then
8690         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8691         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8692         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8693         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8694         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8695         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8696       else
8697         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8698         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8699         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8700         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8701         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8702           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8703         else
8704           eello6_5=0.0d0
8705         endif
8706         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8707       endif
8708 C If turn contributions are considered, they will be handled separately.
8709       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8710 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8711 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8712 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8713 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8714 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8715 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8716 cd      goto 1112
8717       if (j.lt.nres-1) then
8718         j1=j+1
8719         j2=j-1
8720       else
8721         j1=j-1
8722         j2=j-2
8723       endif
8724       if (l.lt.nres-1) then
8725         l1=l+1
8726         l2=l-1
8727       else
8728         l1=l-1
8729         l2=l-2
8730       endif
8731       do ll=1,3
8732 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8733 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8734 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8735 cgrad        ghalf=0.5d0*ggg1(ll)
8736 cd        ghalf=0.0d0
8737         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8738         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8739         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8740         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8741         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8742         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8743         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8744         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8745 cgrad        ghalf=0.5d0*ggg2(ll)
8746 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8747 cd        ghalf=0.0d0
8748         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8749         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8750         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8751         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8752         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8753         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8754       enddo
8755 cd      goto 1112
8756 cgrad      do m=i+1,j-1
8757 cgrad        do ll=1,3
8758 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8759 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8760 cgrad        enddo
8761 cgrad      enddo
8762 cgrad      do m=k+1,l-1
8763 cgrad        do ll=1,3
8764 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8765 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8766 cgrad        enddo
8767 cgrad      enddo
8768 cgrad1112  continue
8769 cgrad      do m=i+2,j2
8770 cgrad        do ll=1,3
8771 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8772 cgrad        enddo
8773 cgrad      enddo
8774 cgrad      do m=k+2,l2
8775 cgrad        do ll=1,3
8776 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8777 cgrad        enddo
8778 cgrad      enddo
8779 cd      do iii=1,nres-3
8780 cd        write (2,*) iii,g_corr6_loc(iii)
8781 cd      enddo
8782       eello6=ekont*eel6
8783 cd      write (2,*) 'ekont',ekont
8784 cd      write (iout,*) 'eello6',ekont*eel6
8785       return
8786       end
8787 c--------------------------------------------------------------------------
8788       double precision function eello6_graph1(i,j,k,l,imat,swap)
8789       implicit real*8 (a-h,o-z)
8790       include 'DIMENSIONS'
8791       include 'COMMON.IOUNITS'
8792       include 'COMMON.CHAIN'
8793       include 'COMMON.DERIV'
8794       include 'COMMON.INTERACT'
8795       include 'COMMON.CONTACTS'
8796       include 'COMMON.TORSION'
8797       include 'COMMON.VAR'
8798       include 'COMMON.GEO'
8799       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8800       logical swap
8801       logical lprn
8802       common /kutas/ lprn
8803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8804 C                                                                              C
8805 C      Parallel       Antiparallel                                             C
8806 C                                                                              C
8807 C          o             o                                                     C
8808 C         /l\           /j\                                                    C
8809 C        /   \         /   \                                                   C
8810 C       /| o |         | o |\                                                  C
8811 C     \ j|/k\|  /   \  |/k\|l /                                                C
8812 C      \ /   \ /     \ /   \ /                                                 C
8813 C       o     o       o     o                                                  C
8814 C       i             i                                                        C
8815 C                                                                              C
8816 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8817       itk=itortyp(itype(k))
8818       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8819       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8820       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8821       call transpose2(EUgC(1,1,k),auxmat(1,1))
8822       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8823       vv1(1)=pizda1(1,1)-pizda1(2,2)
8824       vv1(2)=pizda1(1,2)+pizda1(2,1)
8825       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8826       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8827       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8828       s5=scalar2(vv(1),Dtobr2(1,i))
8829 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8830       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8831       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8832      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8833      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8834      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8835      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8836      & +scalar2(vv(1),Dtobr2der(1,i)))
8837       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8838       vv1(1)=pizda1(1,1)-pizda1(2,2)
8839       vv1(2)=pizda1(1,2)+pizda1(2,1)
8840       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8841       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8842       if (l.eq.j+1) then
8843         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8844      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8845      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8846      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8847      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8848       else
8849         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8850      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8851      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8852      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8853      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8854       endif
8855       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8856       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8857       vv1(1)=pizda1(1,1)-pizda1(2,2)
8858       vv1(2)=pizda1(1,2)+pizda1(2,1)
8859       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8860      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8861      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8862      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8863       do iii=1,2
8864         if (swap) then
8865           ind=3-iii
8866         else
8867           ind=iii
8868         endif
8869         do kkk=1,5
8870           do lll=1,3
8871             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8872             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8873             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8874             call transpose2(EUgC(1,1,k),auxmat(1,1))
8875             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8876      &        pizda1(1,1))
8877             vv1(1)=pizda1(1,1)-pizda1(2,2)
8878             vv1(2)=pizda1(1,2)+pizda1(2,1)
8879             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8880             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8881      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8882             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8883      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8884             s5=scalar2(vv(1),Dtobr2(1,i))
8885             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8886           enddo
8887         enddo
8888       enddo
8889       return
8890       end
8891 c----------------------------------------------------------------------------
8892       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8893       implicit real*8 (a-h,o-z)
8894       include 'DIMENSIONS'
8895       include 'COMMON.IOUNITS'
8896       include 'COMMON.CHAIN'
8897       include 'COMMON.DERIV'
8898       include 'COMMON.INTERACT'
8899       include 'COMMON.CONTACTS'
8900       include 'COMMON.TORSION'
8901       include 'COMMON.VAR'
8902       include 'COMMON.GEO'
8903       logical swap
8904       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8905      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8906       logical lprn
8907       common /kutas/ lprn
8908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8909 C                                                                              C
8910 C      Parallel       Antiparallel                                             C
8911 C                                                                              C
8912 C          o             o                                                     C
8913 C     \   /l\           /j\   /                                                C
8914 C      \ /   \         /   \ /                                                 C
8915 C       o| o |         | o |o                                                  C
8916 C     \ j|/k\|      \  |/k\|l                                                  C
8917 C      \ /   \       \ /   \                                                   C
8918 C       o             o                                                        C
8919 C       i             i                                                        C
8920 C                                                                              C
8921 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8922 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8923 C AL 7/4/01 s1 would occur in the sixth-order moment,
8924 C           but not in a cluster cumulant
8925 #ifdef MOMENT
8926       s1=dip(1,jj,i)*dip(1,kk,k)
8927 #endif
8928       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8929       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8930       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8931       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8932       call transpose2(EUg(1,1,k),auxmat(1,1))
8933       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8934       vv(1)=pizda(1,1)-pizda(2,2)
8935       vv(2)=pizda(1,2)+pizda(2,1)
8936       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8937 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8938 #ifdef MOMENT
8939       eello6_graph2=-(s1+s2+s3+s4)
8940 #else
8941       eello6_graph2=-(s2+s3+s4)
8942 #endif
8943 c      eello6_graph2=-s3
8944 C Derivatives in gamma(i-1)
8945       if (i.gt.1) then
8946 #ifdef MOMENT
8947         s1=dipderg(1,jj,i)*dip(1,kk,k)
8948 #endif
8949         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8950         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8951         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8952         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8953 #ifdef MOMENT
8954         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8955 #else
8956         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8957 #endif
8958 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8959       endif
8960 C Derivatives in gamma(k-1)
8961 #ifdef MOMENT
8962       s1=dip(1,jj,i)*dipderg(1,kk,k)
8963 #endif
8964       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8965       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8966       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8967       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8968       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8969       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8970       vv(1)=pizda(1,1)-pizda(2,2)
8971       vv(2)=pizda(1,2)+pizda(2,1)
8972       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8973 #ifdef MOMENT
8974       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8975 #else
8976       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8977 #endif
8978 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8979 C Derivatives in gamma(j-1) or gamma(l-1)
8980       if (j.gt.1) then
8981 #ifdef MOMENT
8982         s1=dipderg(3,jj,i)*dip(1,kk,k)
8983 #endif
8984         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8985         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8986         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8987         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8988         vv(1)=pizda(1,1)-pizda(2,2)
8989         vv(2)=pizda(1,2)+pizda(2,1)
8990         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8991 #ifdef MOMENT
8992         if (swap) then
8993           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8994         else
8995           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8996         endif
8997 #endif
8998         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8999 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9000       endif
9001 C Derivatives in gamma(l-1) or gamma(j-1)
9002       if (l.gt.1) then
9003 #ifdef MOMENT
9004         s1=dip(1,jj,i)*dipderg(3,kk,k)
9005 #endif
9006         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9007         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9008         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9009         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9010         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9011         vv(1)=pizda(1,1)-pizda(2,2)
9012         vv(2)=pizda(1,2)+pizda(2,1)
9013         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9014 #ifdef MOMENT
9015         if (swap) then
9016           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9017         else
9018           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9019         endif
9020 #endif
9021         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9022 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9023       endif
9024 C Cartesian derivatives.
9025       if (lprn) then
9026         write (2,*) 'In eello6_graph2'
9027         do iii=1,2
9028           write (2,*) 'iii=',iii
9029           do kkk=1,5
9030             write (2,*) 'kkk=',kkk
9031             do jjj=1,2
9032               write (2,'(3(2f10.5),5x)')
9033      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9034             enddo
9035           enddo
9036         enddo
9037       endif
9038       do iii=1,2
9039         do kkk=1,5
9040           do lll=1,3
9041 #ifdef MOMENT
9042             if (iii.eq.1) then
9043               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9044             else
9045               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9046             endif
9047 #endif
9048             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9049      &        auxvec(1))
9050             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9051             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9052      &        auxvec(1))
9053             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9054             call transpose2(EUg(1,1,k),auxmat(1,1))
9055             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9056      &        pizda(1,1))
9057             vv(1)=pizda(1,1)-pizda(2,2)
9058             vv(2)=pizda(1,2)+pizda(2,1)
9059             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9060 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9061 #ifdef MOMENT
9062             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9063 #else
9064             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9065 #endif
9066             if (swap) then
9067               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9068             else
9069               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9070             endif
9071           enddo
9072         enddo
9073       enddo
9074       return
9075       end
9076 c----------------------------------------------------------------------------
9077       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9078       implicit real*8 (a-h,o-z)
9079       include 'DIMENSIONS'
9080       include 'COMMON.IOUNITS'
9081       include 'COMMON.CHAIN'
9082       include 'COMMON.DERIV'
9083       include 'COMMON.INTERACT'
9084       include 'COMMON.CONTACTS'
9085       include 'COMMON.TORSION'
9086       include 'COMMON.VAR'
9087       include 'COMMON.GEO'
9088       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9089       logical swap
9090 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9091 C                                                                              C
9092 C      Parallel       Antiparallel                                             C
9093 C                                                                              C
9094 C          o             o                                                     C
9095 C         /l\   /   \   /j\                                                    C
9096 C        /   \ /     \ /   \                                                   C
9097 C       /| o |o       o| o |\                                                  C
9098 C       j|/k\|  /      |/k\|l /                                                C
9099 C        /   \ /       /   \ /                                                 C
9100 C       /     o       /     o                                                  C
9101 C       i             i                                                        C
9102 C                                                                              C
9103 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9104 C
9105 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9106 C           energy moment and not to the cluster cumulant.
9107       iti=itortyp(itype(i))
9108       if (j.lt.nres-1) then
9109         itj1=itortyp(itype(j+1))
9110       else
9111         itj1=ntortyp
9112       endif
9113       itk=itortyp(itype(k))
9114       itk1=itortyp(itype(k+1))
9115       if (l.lt.nres-1) then
9116         itl1=itortyp(itype(l+1))
9117       else
9118         itl1=ntortyp
9119       endif
9120 #ifdef MOMENT
9121       s1=dip(4,jj,i)*dip(4,kk,k)
9122 #endif
9123       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9124       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9125       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9126       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9127       call transpose2(EE(1,1,itk),auxmat(1,1))
9128       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9129       vv(1)=pizda(1,1)+pizda(2,2)
9130       vv(2)=pizda(2,1)-pizda(1,2)
9131       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9132 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9133 cd     & "sum",-(s2+s3+s4)
9134 #ifdef MOMENT
9135       eello6_graph3=-(s1+s2+s3+s4)
9136 #else
9137       eello6_graph3=-(s2+s3+s4)
9138 #endif
9139 c      eello6_graph3=-s4
9140 C Derivatives in gamma(k-1)
9141       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9142       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9143       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9144       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9145 C Derivatives in gamma(l-1)
9146       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9147       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9148       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9149       vv(1)=pizda(1,1)+pizda(2,2)
9150       vv(2)=pizda(2,1)-pizda(1,2)
9151       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9152       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9153 C Cartesian derivatives.
9154       do iii=1,2
9155         do kkk=1,5
9156           do lll=1,3
9157 #ifdef MOMENT
9158             if (iii.eq.1) then
9159               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9160             else
9161               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9162             endif
9163 #endif
9164             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9165      &        auxvec(1))
9166             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9167             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9168      &        auxvec(1))
9169             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9170             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9171      &        pizda(1,1))
9172             vv(1)=pizda(1,1)+pizda(2,2)
9173             vv(2)=pizda(2,1)-pizda(1,2)
9174             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9175 #ifdef MOMENT
9176             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9177 #else
9178             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9179 #endif
9180             if (swap) then
9181               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9182             else
9183               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9184             endif
9185 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9186           enddo
9187         enddo
9188       enddo
9189       return
9190       end
9191 c----------------------------------------------------------------------------
9192       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9193       implicit real*8 (a-h,o-z)
9194       include 'DIMENSIONS'
9195       include 'COMMON.IOUNITS'
9196       include 'COMMON.CHAIN'
9197       include 'COMMON.DERIV'
9198       include 'COMMON.INTERACT'
9199       include 'COMMON.CONTACTS'
9200       include 'COMMON.TORSION'
9201       include 'COMMON.VAR'
9202       include 'COMMON.GEO'
9203       include 'COMMON.FFIELD'
9204       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9205      & auxvec1(2),auxmat1(2,2)
9206       logical swap
9207 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9208 C                                                                              C
9209 C      Parallel       Antiparallel                                             C
9210 C                                                                              C
9211 C          o             o                                                     C
9212 C         /l\   /   \   /j\                                                    C
9213 C        /   \ /     \ /   \                                                   C
9214 C       /| o |o       o| o |\                                                  C
9215 C     \ j|/k\|      \  |/k\|l                                                  C
9216 C      \ /   \       \ /   \                                                   C
9217 C       o     \       o     \                                                  C
9218 C       i             i                                                        C
9219 C                                                                              C
9220 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9221 C
9222 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9223 C           energy moment and not to the cluster cumulant.
9224 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9225       iti=itortyp(itype(i))
9226       itj=itortyp(itype(j))
9227       if (j.lt.nres-1) then
9228         itj1=itortyp(itype(j+1))
9229       else
9230         itj1=ntortyp
9231       endif
9232       itk=itortyp(itype(k))
9233       if (k.lt.nres-1) then
9234         itk1=itortyp(itype(k+1))
9235       else
9236         itk1=ntortyp
9237       endif
9238       itl=itortyp(itype(l))
9239       if (l.lt.nres-1) then
9240         itl1=itortyp(itype(l+1))
9241       else
9242         itl1=ntortyp
9243       endif
9244 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9245 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9246 cd     & ' itl',itl,' itl1',itl1
9247 #ifdef MOMENT
9248       if (imat.eq.1) then
9249         s1=dip(3,jj,i)*dip(3,kk,k)
9250       else
9251         s1=dip(2,jj,j)*dip(2,kk,l)
9252       endif
9253 #endif
9254       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9255       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9256       if (j.eq.l+1) then
9257         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9258         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9259       else
9260         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9261         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9262       endif
9263       call transpose2(EUg(1,1,k),auxmat(1,1))
9264       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9265       vv(1)=pizda(1,1)-pizda(2,2)
9266       vv(2)=pizda(2,1)+pizda(1,2)
9267       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9268 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9269 #ifdef MOMENT
9270       eello6_graph4=-(s1+s2+s3+s4)
9271 #else
9272       eello6_graph4=-(s2+s3+s4)
9273 #endif
9274 C Derivatives in gamma(i-1)
9275       if (i.gt.1) then
9276 #ifdef MOMENT
9277         if (imat.eq.1) then
9278           s1=dipderg(2,jj,i)*dip(3,kk,k)
9279         else
9280           s1=dipderg(4,jj,j)*dip(2,kk,l)
9281         endif
9282 #endif
9283         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9284         if (j.eq.l+1) then
9285           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9286           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9287         else
9288           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9289           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9290         endif
9291         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9292         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9293 cd          write (2,*) 'turn6 derivatives'
9294 #ifdef MOMENT
9295           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9296 #else
9297           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9298 #endif
9299         else
9300 #ifdef MOMENT
9301           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9302 #else
9303           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9304 #endif
9305         endif
9306       endif
9307 C Derivatives in gamma(k-1)
9308 #ifdef MOMENT
9309       if (imat.eq.1) then
9310         s1=dip(3,jj,i)*dipderg(2,kk,k)
9311       else
9312         s1=dip(2,jj,j)*dipderg(4,kk,l)
9313       endif
9314 #endif
9315       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9316       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9317       if (j.eq.l+1) then
9318         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9319         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9320       else
9321         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9322         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9323       endif
9324       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9325       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9326       vv(1)=pizda(1,1)-pizda(2,2)
9327       vv(2)=pizda(2,1)+pizda(1,2)
9328       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9329       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9330 #ifdef MOMENT
9331         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9332 #else
9333         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9334 #endif
9335       else
9336 #ifdef MOMENT
9337         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9338 #else
9339         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9340 #endif
9341       endif
9342 C Derivatives in gamma(j-1) or gamma(l-1)
9343       if (l.eq.j+1 .and. l.gt.1) then
9344         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9345         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9346         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9347         vv(1)=pizda(1,1)-pizda(2,2)
9348         vv(2)=pizda(2,1)+pizda(1,2)
9349         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9350         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9351       else if (j.gt.1) then
9352         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9353         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9354         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9355         vv(1)=pizda(1,1)-pizda(2,2)
9356         vv(2)=pizda(2,1)+pizda(1,2)
9357         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9358         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9359           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9360         else
9361           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9362         endif
9363       endif
9364 C Cartesian derivatives.
9365       do iii=1,2
9366         do kkk=1,5
9367           do lll=1,3
9368 #ifdef MOMENT
9369             if (iii.eq.1) then
9370               if (imat.eq.1) then
9371                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9372               else
9373                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9374               endif
9375             else
9376               if (imat.eq.1) then
9377                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9378               else
9379                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9380               endif
9381             endif
9382 #endif
9383             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9384      &        auxvec(1))
9385             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9386             if (j.eq.l+1) then
9387               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9388      &          b1(1,j+1),auxvec(1))
9389               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9390             else
9391               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9392      &          b1(1,l+1),auxvec(1))
9393               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9394             endif
9395             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9396      &        pizda(1,1))
9397             vv(1)=pizda(1,1)-pizda(2,2)
9398             vv(2)=pizda(2,1)+pizda(1,2)
9399             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9400             if (swap) then
9401               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9402 #ifdef MOMENT
9403                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9404      &             -(s1+s2+s4)
9405 #else
9406                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9407      &             -(s2+s4)
9408 #endif
9409                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9410               else
9411 #ifdef MOMENT
9412                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9413 #else
9414                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9415 #endif
9416                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9417               endif
9418             else
9419 #ifdef MOMENT
9420               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9421 #else
9422               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9423 #endif
9424               if (l.eq.j+1) then
9425                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9426               else
9427                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9428               endif
9429             endif
9430           enddo
9431         enddo
9432       enddo
9433       return
9434       end
9435 c----------------------------------------------------------------------------
9436       double precision function eello_turn6(i,jj,kk)
9437       implicit real*8 (a-h,o-z)
9438       include 'DIMENSIONS'
9439       include 'COMMON.IOUNITS'
9440       include 'COMMON.CHAIN'
9441       include 'COMMON.DERIV'
9442       include 'COMMON.INTERACT'
9443       include 'COMMON.CONTACTS'
9444       include 'COMMON.TORSION'
9445       include 'COMMON.VAR'
9446       include 'COMMON.GEO'
9447       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9448      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9449      &  ggg1(3),ggg2(3)
9450       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9451      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9452 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9453 C           the respective energy moment and not to the cluster cumulant.
9454       s1=0.0d0
9455       s8=0.0d0
9456       s13=0.0d0
9457 c
9458       eello_turn6=0.0d0
9459       j=i+4
9460       k=i+1
9461       l=i+3
9462       iti=itortyp(itype(i))
9463       itk=itortyp(itype(k))
9464       itk1=itortyp(itype(k+1))
9465       itl=itortyp(itype(l))
9466       itj=itortyp(itype(j))
9467 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9468 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9469 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9470 cd        eello6=0.0d0
9471 cd        return
9472 cd      endif
9473 cd      write (iout,*)
9474 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9475 cd     &   ' and',k,l
9476 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9477       do iii=1,2
9478         do kkk=1,5
9479           do lll=1,3
9480             derx_turn(lll,kkk,iii)=0.0d0
9481           enddo
9482         enddo
9483       enddo
9484 cd      eij=1.0d0
9485 cd      ekl=1.0d0
9486 cd      ekont=1.0d0
9487       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9488 cd      eello6_5=0.0d0
9489 cd      write (2,*) 'eello6_5',eello6_5
9490 #ifdef MOMENT
9491       call transpose2(AEA(1,1,1),auxmat(1,1))
9492       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9493       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9494       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9495 #endif
9496       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9497       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9498       s2 = scalar2(b1(1,k),vtemp1(1))
9499 #ifdef MOMENT
9500       call transpose2(AEA(1,1,2),atemp(1,1))
9501       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9502       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9503       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9504 #endif
9505       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9506       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9507       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9508 #ifdef MOMENT
9509       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9510       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9511       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9512       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9513       ss13 = scalar2(b1(1,k),vtemp4(1))
9514       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9515 #endif
9516 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9517 c      s1=0.0d0
9518 c      s2=0.0d0
9519 c      s8=0.0d0
9520 c      s12=0.0d0
9521 c      s13=0.0d0
9522       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9523 C Derivatives in gamma(i+2)
9524       s1d =0.0d0
9525       s8d =0.0d0
9526 #ifdef MOMENT
9527       call transpose2(AEA(1,1,1),auxmatd(1,1))
9528       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9529       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9530       call transpose2(AEAderg(1,1,2),atempd(1,1))
9531       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9532       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9533 #endif
9534       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9535       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9536       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9537 c      s1d=0.0d0
9538 c      s2d=0.0d0
9539 c      s8d=0.0d0
9540 c      s12d=0.0d0
9541 c      s13d=0.0d0
9542       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9543 C Derivatives in gamma(i+3)
9544 #ifdef MOMENT
9545       call transpose2(AEA(1,1,1),auxmatd(1,1))
9546       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9547       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9548       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9549 #endif
9550       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9551       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9552       s2d = scalar2(b1(1,k),vtemp1d(1))
9553 #ifdef MOMENT
9554       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9555       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9556 #endif
9557       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9558 #ifdef MOMENT
9559       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9560       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9561       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9562 #endif
9563 c      s1d=0.0d0
9564 c      s2d=0.0d0
9565 c      s8d=0.0d0
9566 c      s12d=0.0d0
9567 c      s13d=0.0d0
9568 #ifdef MOMENT
9569       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9570      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9571 #else
9572       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9573      &               -0.5d0*ekont*(s2d+s12d)
9574 #endif
9575 C Derivatives in gamma(i+4)
9576       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9577       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9578       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9579 #ifdef MOMENT
9580       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9581       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9582       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9583 #endif
9584 c      s1d=0.0d0
9585 c      s2d=0.0d0
9586 c      s8d=0.0d0
9587 C      s12d=0.0d0
9588 c      s13d=0.0d0
9589 #ifdef MOMENT
9590       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9591 #else
9592       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9593 #endif
9594 C Derivatives in gamma(i+5)
9595 #ifdef MOMENT
9596       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9597       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9598       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9599 #endif
9600       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9601       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9602       s2d = scalar2(b1(1,k),vtemp1d(1))
9603 #ifdef MOMENT
9604       call transpose2(AEA(1,1,2),atempd(1,1))
9605       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9606       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9607 #endif
9608       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9609       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9610 #ifdef MOMENT
9611       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9612       ss13d = scalar2(b1(1,k),vtemp4d(1))
9613       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9614 #endif
9615 c      s1d=0.0d0
9616 c      s2d=0.0d0
9617 c      s8d=0.0d0
9618 c      s12d=0.0d0
9619 c      s13d=0.0d0
9620 #ifdef MOMENT
9621       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9622      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9623 #else
9624       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9625      &               -0.5d0*ekont*(s2d+s12d)
9626 #endif
9627 C Cartesian derivatives
9628       do iii=1,2
9629         do kkk=1,5
9630           do lll=1,3
9631 #ifdef MOMENT
9632             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9633             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9634             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9635 #endif
9636             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9637             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9638      &          vtemp1d(1))
9639             s2d = scalar2(b1(1,k),vtemp1d(1))
9640 #ifdef MOMENT
9641             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9642             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9643             s8d = -(atempd(1,1)+atempd(2,2))*
9644      &           scalar2(cc(1,1,itl),vtemp2(1))
9645 #endif
9646             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9647      &           auxmatd(1,1))
9648             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9649             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9650 c      s1d=0.0d0
9651 c      s2d=0.0d0
9652 c      s8d=0.0d0
9653 c      s12d=0.0d0
9654 c      s13d=0.0d0
9655 #ifdef MOMENT
9656             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9657      &        - 0.5d0*(s1d+s2d)
9658 #else
9659             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9660      &        - 0.5d0*s2d
9661 #endif
9662 #ifdef MOMENT
9663             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9664      &        - 0.5d0*(s8d+s12d)
9665 #else
9666             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9667      &        - 0.5d0*s12d
9668 #endif
9669           enddo
9670         enddo
9671       enddo
9672 #ifdef MOMENT
9673       do kkk=1,5
9674         do lll=1,3
9675           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9676      &      achuj_tempd(1,1))
9677           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9678           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9679           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9680           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9681           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9682      &      vtemp4d(1))
9683           ss13d = scalar2(b1(1,k),vtemp4d(1))
9684           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9685           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9686         enddo
9687       enddo
9688 #endif
9689 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9690 cd     &  16*eel_turn6_num
9691 cd      goto 1112
9692       if (j.lt.nres-1) then
9693         j1=j+1
9694         j2=j-1
9695       else
9696         j1=j-1
9697         j2=j-2
9698       endif
9699       if (l.lt.nres-1) then
9700         l1=l+1
9701         l2=l-1
9702       else
9703         l1=l-1
9704         l2=l-2
9705       endif
9706       do ll=1,3
9707 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9708 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9709 cgrad        ghalf=0.5d0*ggg1(ll)
9710 cd        ghalf=0.0d0
9711         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9712         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9713         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9714      &    +ekont*derx_turn(ll,2,1)
9715         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9716         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9717      &    +ekont*derx_turn(ll,4,1)
9718         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9719         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9720         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9721 cgrad        ghalf=0.5d0*ggg2(ll)
9722 cd        ghalf=0.0d0
9723         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9724      &    +ekont*derx_turn(ll,2,2)
9725         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9726         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9727      &    +ekont*derx_turn(ll,4,2)
9728         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9729         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9730         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9731       enddo
9732 cd      goto 1112
9733 cgrad      do m=i+1,j-1
9734 cgrad        do ll=1,3
9735 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9736 cgrad        enddo
9737 cgrad      enddo
9738 cgrad      do m=k+1,l-1
9739 cgrad        do ll=1,3
9740 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9741 cgrad        enddo
9742 cgrad      enddo
9743 cgrad1112  continue
9744 cgrad      do m=i+2,j2
9745 cgrad        do ll=1,3
9746 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9747 cgrad        enddo
9748 cgrad      enddo
9749 cgrad      do m=k+2,l2
9750 cgrad        do ll=1,3
9751 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9752 cgrad        enddo
9753 cgrad      enddo
9754 cd      do iii=1,nres-3
9755 cd        write (2,*) iii,g_corr6_loc(iii)
9756 cd      enddo
9757       eello_turn6=ekont*eel_turn6
9758 cd      write (2,*) 'ekont',ekont
9759 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9760       return
9761       end
9762
9763 C-----------------------------------------------------------------------------
9764       double precision function scalar(u,v)
9765 !DIR$ INLINEALWAYS scalar
9766 #ifndef OSF
9767 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9768 #endif
9769       implicit none
9770       double precision u(3),v(3)
9771 cd      double precision sc
9772 cd      integer i
9773 cd      sc=0.0d0
9774 cd      do i=1,3
9775 cd        sc=sc+u(i)*v(i)
9776 cd      enddo
9777 cd      scalar=sc
9778
9779       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9780       return
9781       end
9782 crc-------------------------------------------------
9783       SUBROUTINE MATVEC2(A1,V1,V2)
9784 !DIR$ INLINEALWAYS MATVEC2
9785 #ifndef OSF
9786 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9787 #endif
9788       implicit real*8 (a-h,o-z)
9789       include 'DIMENSIONS'
9790       DIMENSION A1(2,2),V1(2),V2(2)
9791 c      DO 1 I=1,2
9792 c        VI=0.0
9793 c        DO 3 K=1,2
9794 c    3     VI=VI+A1(I,K)*V1(K)
9795 c        Vaux(I)=VI
9796 c    1 CONTINUE
9797
9798       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9799       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9800
9801       v2(1)=vaux1
9802       v2(2)=vaux2
9803       END
9804 C---------------------------------------
9805       SUBROUTINE MATMAT2(A1,A2,A3)
9806 #ifndef OSF
9807 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9808 #endif
9809       implicit real*8 (a-h,o-z)
9810       include 'DIMENSIONS'
9811       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9812 c      DIMENSION AI3(2,2)
9813 c        DO  J=1,2
9814 c          A3IJ=0.0
9815 c          DO K=1,2
9816 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9817 c          enddo
9818 c          A3(I,J)=A3IJ
9819 c       enddo
9820 c      enddo
9821
9822       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9823       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9824       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9825       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9826
9827       A3(1,1)=AI3_11
9828       A3(2,1)=AI3_21
9829       A3(1,2)=AI3_12
9830       A3(2,2)=AI3_22
9831       END
9832
9833 c-------------------------------------------------------------------------
9834       double precision function scalar2(u,v)
9835 !DIR$ INLINEALWAYS scalar2
9836       implicit none
9837       double precision u(2),v(2)
9838       double precision sc
9839       integer i
9840       scalar2=u(1)*v(1)+u(2)*v(2)
9841       return
9842       end
9843
9844 C-----------------------------------------------------------------------------
9845
9846       subroutine transpose2(a,at)
9847 !DIR$ INLINEALWAYS transpose2
9848 #ifndef OSF
9849 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9850 #endif
9851       implicit none
9852       double precision a(2,2),at(2,2)
9853       at(1,1)=a(1,1)
9854       at(1,2)=a(2,1)
9855       at(2,1)=a(1,2)
9856       at(2,2)=a(2,2)
9857       return
9858       end
9859 c--------------------------------------------------------------------------
9860       subroutine transpose(n,a,at)
9861       implicit none
9862       integer n,i,j
9863       double precision a(n,n),at(n,n)
9864       do i=1,n
9865         do j=1,n
9866           at(j,i)=a(i,j)
9867         enddo
9868       enddo
9869       return
9870       end
9871 C---------------------------------------------------------------------------
9872       subroutine prodmat3(a1,a2,kk,transp,prod)
9873 !DIR$ INLINEALWAYS prodmat3
9874 #ifndef OSF
9875 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9876 #endif
9877       implicit none
9878       integer i,j
9879       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9880       logical transp
9881 crc      double precision auxmat(2,2),prod_(2,2)
9882
9883       if (transp) then
9884 crc        call transpose2(kk(1,1),auxmat(1,1))
9885 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9886 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9887
9888            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9889      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9890            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9891      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9892            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9893      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9894            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9895      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9896
9897       else
9898 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9899 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9900
9901            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9902      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9903            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9904      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9905            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9906      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9907            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9908      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9909
9910       endif
9911 c      call transpose2(a2(1,1),a2t(1,1))
9912
9913 crc      print *,transp
9914 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9915 crc      print *,((prod(i,j),i=1,2),j=1,2)
9916
9917       return
9918       end
9919