source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144       if (shield_mode.gt.0) then
 145        call set_shield_fac
 146       endif
 147 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 148       if (ipot.lt.6) then
 149 #ifdef SPLITELE
 150          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #else
 155          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 156      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 157      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 158      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 159 #endif
 160             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 161          else
 162             ees=0.0d0
 163             evdw1=0.0d0
 164             eel_loc=0.0d0
 165             eello_turn3=0.0d0
 166             eello_turn4=0.0d0
 167          endif
 168       else
 169         write (iout,*) "Soft-spheer ELEC potential"
 170 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 171 c     &   eello_turn4)
 172       endif
 173 c      print *,"Processor",myrank," computed UELEC"
 174 C
 175 C Calculate excluded-volume interaction energy between peptide groups
 176 C and side chains.
 177 C
 178       if (ipot.lt.6) then
 179        if(wscp.gt.0d0) then
 180         call escp(evdw2,evdw2_14)
 181        else
 182         evdw2=0
 183         evdw2_14=0
 184        endif
 185       else
 186 c        write (iout,*) "Soft-sphere SCP potential"
 187         call escp_soft_sphere(evdw2,evdw2_14)
 188       endif
 189 c
 190 c Calculate the bond-stretching energy
 191 c
 192       call ebond(estr)
 193 C
 194 C Calculate the disulfide-bridge and other energy and the contributions
 195 C from other distance constraints.
 196 cd    print *,'Calling EHPB'
 197       call edis(ehpb)
 198 cd    print *,'EHPB exitted succesfully.'
 199 C
 200 C Calculate the virtual-bond-angle energy.
 201 C
 202       if (wang.gt.0d0) then
 203         call ebend(ebe)
 204       else
 205         ebe=0
 206       endif
 207 c      print *,"Processor",myrank," computed UB"
 208 C
 209 C Calculate the SC local energy.
 210 C
 211 C      print *,"TU DOCHODZE?"
 212       call esc(escloc)
 213 c      print *,"Processor",myrank," computed USC"
 214 C
 215 C Calculate the virtual-bond torsional energy.
 216 C
 217 cd    print *,'nterm=',nterm
 218       if (wtor.gt.0) then
 219        call etor(etors,edihcnstr)
 220       else
 221        etors=0
 222        edihcnstr=0
 223       endif
 224 c      print *,"Processor",myrank," computed Utor"
 225 C
 226 C 6/23/01 Calculate double-torsional energy
 227 C
 228       if (wtor_d.gt.0) then
 229        call etor_d(etors_d)
 230       else
 231        etors_d=0
 232       endif
 233 c      print *,"Processor",myrank," computed Utord"
 234 C
 235 C 21/5/07 Calculate local sicdechain correlation energy
 236 C
 237       if (wsccor.gt.0.0d0) then
 238         call eback_sc_corr(esccor)
 239       else
 240         esccor=0.0d0
 241       endif
 242 C      print *,"PRZED MULIt"
 243 c      print *,"Processor",myrank," computed Usccorr"
 244 C
 245 C 12/1/95 Multi-body terms
 246 C
 247       n_corr=0
 248       n_corr1=0
 249       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 250      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 251          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 252 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 253 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 254       else
 255          ecorr=0.0d0
 256          ecorr5=0.0d0
 257          ecorr6=0.0d0
 258          eturn6=0.0d0
 259       endif
 260       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 261          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 262 cd         write (iout,*) "multibody_hb ecorr",ecorr
 263       endif
 264 c      print *,"Processor",myrank," computed Ucorr"
 265 C
 266 C If performing constraint dynamics, call the constraint energy
 267 C  after the equilibration time
 268       if(usampl.and.totT.gt.eq_time) then
 269          call EconstrQ
 270          call Econstr_back
 271       else
 272          Uconst=0.0d0
 273          Uconst_back=0.0d0
 274       endif
 275 C 01/27/2015 added by adasko
 276 C the energy component below is energy transfer into lipid environment
 277 C based on partition function
 278 C      print *,"przed lipidami"
 279       if (wliptran.gt.0) then
 280         call Eliptransfer(eliptran)
 281       endif
 282 C      print *,"za lipidami"
 283       if (AFMlog.gt.0) then
 284         call AFMforce(Eafmforce)
 285       else if (selfguide.gt.0) then
 286         call AFMvel(Eafmforce)
 287       endif
 288 #ifdef TIMING
 289       time_enecalc=time_enecalc+MPI_Wtime()-time00
 290 #endif
 291 c      print *,"Processor",myrank," computed Uconstr"
 292 #ifdef TIMING
 293       time00=MPI_Wtime()
 294 #endif
 295 c
 296 C Sum the energies
 297 C
 298       energia(1)=evdw
 299 #ifdef SCP14
 300       energia(2)=evdw2-evdw2_14
 301       energia(18)=evdw2_14
 302 #else
 303       energia(2)=evdw2
 304       energia(18)=0.0d0
 305 #endif
 306 #ifdef SPLITELE
 307       energia(3)=ees
 308       energia(16)=evdw1
 309 #else
 310       energia(3)=ees+evdw1
 311       energia(16)=0.0d0
 312 #endif
 313       energia(4)=ecorr
 314       energia(5)=ecorr5
 315       energia(6)=ecorr6
 316       energia(7)=eel_loc
 317       energia(8)=eello_turn3
 318       energia(9)=eello_turn4
 319       energia(10)=eturn6
 320       energia(11)=ebe
 321       energia(12)=escloc
 322       energia(13)=etors
 323       energia(14)=etors_d
 324       energia(15)=ehpb
 325       energia(19)=edihcnstr
 326       energia(17)=estr
 327       energia(20)=Uconst+Uconst_back
 328       energia(21)=esccor
 329       energia(22)=eliptran
 330       energia(23)=Eafmforce
 331 c    Here are the energies showed per procesor if the are more processors
 332 c    per molecule then we sum it up in sum_energy subroutine
 333 c      print *," Processor",myrank," calls SUM_ENERGY"
 334       call sum_energy(energia,.true.)
 335       if (dyn_ss) call dyn_set_nss
 336 c      print *," Processor",myrank," left SUM_ENERGY"
 337 #ifdef TIMING
 338       time_sumene=time_sumene+MPI_Wtime()-time00
 339 #endif
 340       return
 341       end
 342 c-------------------------------------------------------------------------------
 343       subroutine sum_energy(energia,reduce)
 344       implicit real*8 (a-h,o-z)
 345       include 'DIMENSIONS'
 346 #ifndef ISNAN
 347       external proc_proc
 348 #ifdef WINPGI
 349 cMS$ATTRIBUTES C ::  proc_proc
 350 #endif
 351 #endif
 352 #ifdef MPI
 353       include "mpif.h"
 354 #endif
 355       include 'COMMON.SETUP'
 356       include 'COMMON.IOUNITS'
 357       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 358       include 'COMMON.FFIELD'
 359       include 'COMMON.DERIV'
 360       include 'COMMON.INTERACT'
 361       include 'COMMON.SBRIDGE'
 362       include 'COMMON.CHAIN'
 363       include 'COMMON.VAR'
 364       include 'COMMON.CONTROL'
 365       include 'COMMON.TIME1'
 366       logical reduce
 367 #ifdef MPI
 368       if (nfgtasks.gt.1 .and. reduce) then
 369 #ifdef DEBUG
 370         write (iout,*) "energies before REDUCE"
 371         call enerprint(energia)
 372         call flush(iout)
 373 #endif
 374         do i=0,n_ene
 375           enebuff(i)=energia(i)
 376         enddo
 377         time00=MPI_Wtime()
 378         call MPI_Barrier(FG_COMM,IERR)
 379         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 380         time00=MPI_Wtime()
 381         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 382      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 383 #ifdef DEBUG
 384         write (iout,*) "energies after REDUCE"
 385         call enerprint(energia)
 386         call flush(iout)
 387 #endif
 388         time_Reduce=time_Reduce+MPI_Wtime()-time00
 389       endif
 390       if (fg_rank.eq.0) then
 391 #endif
 392       evdw=energia(1)
 393 #ifdef SCP14
 394       evdw2=energia(2)+energia(18)
 395       evdw2_14=energia(18)
 396 #else
 397       evdw2=energia(2)
 398 #endif
 399 #ifdef SPLITELE
 400       ees=energia(3)
 401       evdw1=energia(16)
 402 #else
 403       ees=energia(3)
 404       evdw1=0.0d0
 405 #endif
 406       ecorr=energia(4)
 407       ecorr5=energia(5)
 408       ecorr6=energia(6)
 409       eel_loc=energia(7)
 410       eello_turn3=energia(8)
 411       eello_turn4=energia(9)
 412       eturn6=energia(10)
 413       ebe=energia(11)
 414       escloc=energia(12)
 415       etors=energia(13)
 416       etors_d=energia(14)
 417       ehpb=energia(15)
 418       edihcnstr=energia(19)
 419       estr=energia(17)
 420       Uconst=energia(20)
 421       esccor=energia(21)
 422       eliptran=energia(22)
 423       Eafmforce=energia(23)
 424 #ifdef SPLITELE
 425       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 426      & +wang*ebe+wtor*etors+wscloc*escloc
 427      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 428      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 429      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 430      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 431 #else
 432       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 433      & +wang*ebe+wtor*etors+wscloc*escloc
 434      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 435      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 436      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 437      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 438      & +Eafmforce
 439 #endif
 440       energia(0)=etot
 441 c detecting NaNQ
 442 #ifdef ISNAN
 443 #ifdef AIX
 444       if (isnan(etot).ne.0) energia(0)=1.0d+99
 445 #else
 446       if (isnan(etot)) energia(0)=1.0d+99
 447 #endif
 448 #else
 449       i=0
 450 #ifdef WINPGI
 451       idumm=proc_proc(etot,i)
 452 #else
 453       call proc_proc(etot,i)
 454 #endif
 455       if(i.eq.1)energia(0)=1.0d+99
 456 #endif
 457 #ifdef MPI
 458       endif
 459 #endif
 460       return
 461       end
 462 c-------------------------------------------------------------------------------
 463       subroutine sum_gradient
 464       implicit real*8 (a-h,o-z)
 465       include 'DIMENSIONS'
 466 #ifndef ISNAN
 467       external proc_proc
 468 #ifdef WINPGI
 469 cMS$ATTRIBUTES C ::  proc_proc
 470 #endif
 471 #endif
 472 #ifdef MPI
 473       include 'mpif.h'
 474 #endif
 475       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 476      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 477      & ,gloc_scbuf(3,-1:maxres)
 478       include 'COMMON.SETUP'
 479       include 'COMMON.IOUNITS'
 480       include 'COMMON.FFIELD'
 481       include 'COMMON.DERIV'
 482       include 'COMMON.INTERACT'
 483       include 'COMMON.SBRIDGE'
 484       include 'COMMON.CHAIN'
 485       include 'COMMON.VAR'
 486       include 'COMMON.CONTROL'
 487       include 'COMMON.TIME1'
 488       include 'COMMON.MAXGRAD'
 489       include 'COMMON.SCCOR'
 490 #ifdef TIMING
 491       time01=MPI_Wtime()
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 498       enddo
 499       call flush(iout)
 500 #endif
 501 #ifdef MPI
 502 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 503         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 504      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 505 #endif
 506 C
 507 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 508 C            in virtual-bond-vector coordinates
 509 C
 510 #ifdef DEBUG
 511 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 512 c      do i=1,nres-1
 513 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 514 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 515 c      enddo
 516 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 517 c      do i=1,nres-1
 518 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 519 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 520 c      enddo
 521       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 522       do i=1,nres
 523         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 524      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 525      &   g_corr5_loc(i)
 526       enddo
 527       call flush(iout)
 528 #endif
 529 #ifdef SPLITELE
 530       do i=0,nct
 531         do j=1,3
 532           gradbufc(j,i)=wsc*gvdwc(j,i)+
 533      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 534      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 535      &                wel_loc*gel_loc_long(j,i)+
 536      &                wcorr*gradcorr_long(j,i)+
 537      &                wcorr5*gradcorr5_long(j,i)+
 538      &                wcorr6*gradcorr6_long(j,i)+
 539      &                wturn6*gcorr6_turn_long(j,i)+
 540      &                wstrain*ghpbc(j,i)
 541      &                +wliptran*gliptranc(j,i)
 542      &                +gradafm(j,i)
 543
 544         enddo
 545       enddo
 546 #else
 547       do i=0,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+
 552      &                wbond*gradb(j,i)+
 553      &                wel_loc*gel_loc_long(j,i)+
 554      &                wcorr*gradcorr_long(j,i)+
 555      &                wcorr5*gradcorr5_long(j,i)+
 556      &                wcorr6*gradcorr6_long(j,i)+
 557      &                wturn6*gcorr6_turn_long(j,i)+
 558      &                wstrain*ghpbc(j,i)
 559      &                +wliptran*gliptranc(j,i)
 560      &                +gradafm(j,i)
 561
 562         enddo
 563       enddo
 564 #endif
 565 #ifdef MPI
 566       if (nfgtasks.gt.1) then
 567       time00=MPI_Wtime()
 568 #ifdef DEBUG
 569       write (iout,*) "gradbufc before allreduce"
 570       do i=1,nres
 571         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 572       enddo
 573       call flush(iout)
 574 #endif
 575       do i=0,nres
 576         do j=1,3
 577           gradbufc_sum(j,i)=gradbufc(j,i)
 578         enddo
 579       enddo
 580 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 581 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 582 c      time_reduce=time_reduce+MPI_Wtime()-time00
 583 #ifdef DEBUG
 584 c      write (iout,*) "gradbufc_sum after allreduce"
 585 c      do i=1,nres
 586 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 587 c      enddo
 588 c      call flush(iout)
 589 #endif
 590 #ifdef TIMING
 591 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 592 #endif
 593       do i=nnt,nres
 594         do k=1,3
 595           gradbufc(k,i)=0.0d0
 596         enddo
 597       enddo
 598 #ifdef DEBUG
 599       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 600       write (iout,*) (i," jgrad_start",jgrad_start(i),
 601      &                  " jgrad_end  ",jgrad_end(i),
 602      &                  i=igrad_start,igrad_end)
 603 #endif
 604 c
 605 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 606 c do not parallelize this part.
 607 c
 608 c      do i=igrad_start,igrad_end
 609 c        do j=jgrad_start(i),jgrad_end(i)
 610 c          do k=1,3
 611 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 612 c          enddo
 613 c        enddo
 614 c      enddo
 615       do j=1,3
 616         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 617       enddo
 618       do i=nres-2,-1,-1
 619         do j=1,3
 620           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 621         enddo
 622       enddo
 623 #ifdef DEBUG
 624       write (iout,*) "gradbufc after summing"
 625       do i=1,nres
 626         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 627       enddo
 628       call flush(iout)
 629 #endif
 630       else
 631 #endif
 632 #ifdef DEBUG
 633       write (iout,*) "gradbufc"
 634       do i=1,nres
 635         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 636       enddo
 637       call flush(iout)
 638 #endif
 639       do i=-1,nres
 640         do j=1,3
 641           gradbufc_sum(j,i)=gradbufc(j,i)
 642           gradbufc(j,i)=0.0d0
 643         enddo
 644       enddo
 645       do j=1,3
 646         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 647       enddo
 648       do i=nres-2,-1,-1
 649         do j=1,3
 650           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 651         enddo
 652       enddo
 653 c      do i=nnt,nres-1
 654 c        do k=1,3
 655 c          gradbufc(k,i)=0.0d0
 656 c        enddo
 657 c        do j=i+1,nres
 658 c          do k=1,3
 659 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 660 c          enddo
 661 c        enddo
 662 c      enddo
 663 #ifdef DEBUG
 664       write (iout,*) "gradbufc after summing"
 665       do i=1,nres
 666         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 667       enddo
 668       call flush(iout)
 669 #endif
 670 #ifdef MPI
 671       endif
 672 #endif
 673       do k=1,3
 674         gradbufc(k,nres)=0.0d0
 675       enddo
 676       do i=-1,nct
 677         do j=1,3
 678 #ifdef SPLITELE
 679           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 680      &                wel_loc*gel_loc(j,i)+
 681      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 682      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 683      &                wel_loc*gel_loc_long(j,i)+
 684      &                wcorr*gradcorr_long(j,i)+
 685      &                wcorr5*gradcorr5_long(j,i)+
 686      &                wcorr6*gradcorr6_long(j,i)+
 687      &                wturn6*gcorr6_turn_long(j,i))+
 688      &                wbond*gradb(j,i)+
 689      &                wcorr*gradcorr(j,i)+
 690      &                wturn3*gcorr3_turn(j,i)+
 691      &                wturn4*gcorr4_turn(j,i)+
 692      &                wcorr5*gradcorr5(j,i)+
 693      &                wcorr6*gradcorr6(j,i)+
 694      &                wturn6*gcorr6_turn(j,i)+
 695      &                wsccor*gsccorc(j,i)
 696      &               +wscloc*gscloc(j,i)
 697      &               +wliptran*gliptranc(j,i)
 698      &                +gradafm(j,i)
 699 #else
 700           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 701      &                wel_loc*gel_loc(j,i)+
 702      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 703      &                welec*gelc_long(j,i)
 704      &                wel_loc*gel_loc_long(j,i)+
 705      &                wcorr*gcorr_long(j,i)+
 706      &                wcorr5*gradcorr5_long(j,i)+
 707      &                wcorr6*gradcorr6_long(j,i)+
 708      &                wturn6*gcorr6_turn_long(j,i))+
 709      &                wbond*gradb(j,i)+
 710      &                wcorr*gradcorr(j,i)+
 711      &                wturn3*gcorr3_turn(j,i)+
 712      &                wturn4*gcorr4_turn(j,i)+
 713      &                wcorr5*gradcorr5(j,i)+
 714      &                wcorr6*gradcorr6(j,i)+
 715      &                wturn6*gcorr6_turn(j,i)+
 716      &                wsccor*gsccorc(j,i)
 717      &               +wscloc*gscloc(j,i)
 718      &               +wliptran*gliptranc(j,i)
 719      &                +gradafm(j,i)
 720
 721 #endif
 722           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 723      &                  wbond*gradbx(j,i)+
 724      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 725      &                  wsccor*gsccorx(j,i)
 726      &                 +wscloc*gsclocx(j,i)
 727      &                 +wliptran*gliptranx(j,i)
 728         enddo
 729       enddo
 730 #ifdef DEBUG
 731       write (iout,*) "gloc before adding corr"
 732       do i=1,4*nres
 733         write (iout,*) i,gloc(i,icg)
 734       enddo
 735 #endif
 736       do i=1,nres-3
 737         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 738      &   +wcorr5*g_corr5_loc(i)
 739      &   +wcorr6*g_corr6_loc(i)
 740      &   +wturn4*gel_loc_turn4(i)
 741      &   +wturn3*gel_loc_turn3(i)
 742      &   +wturn6*gel_loc_turn6(i)
 743      &   +wel_loc*gel_loc_loc(i)
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc after adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751 #ifdef MPI
 752       if (nfgtasks.gt.1) then
 753         do j=1,3
 754           do i=1,nres
 755             gradbufc(j,i)=gradc(j,i,icg)
 756             gradbufx(j,i)=gradx(j,i,icg)
 757           enddo
 758         enddo
 759         do i=1,4*nres
 760           glocbuf(i)=gloc(i,icg)
 761         enddo
 762 c#define DEBUG
 763 #ifdef DEBUG
 764       write (iout,*) "gloc_sc before reduce"
 765       do i=1,nres
 766        do j=1,1
 767         write (iout,*) i,j,gloc_sc(j,i,icg)
 768        enddo
 769       enddo
 770 #endif
 771 c#undef DEBUG
 772         do i=1,nres
 773          do j=1,3
 774           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 775          enddo
 776         enddo
 777         time00=MPI_Wtime()
 778         call MPI_Barrier(FG_COMM,IERR)
 779         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 780         time00=MPI_Wtime()
 781         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 782      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 783         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 784      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 785         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 786      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 787         time_reduce=time_reduce+MPI_Wtime()-time00
 788         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 789      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 790         time_reduce=time_reduce+MPI_Wtime()-time00
 791 c#define DEBUG
 792 #ifdef DEBUG
 793       write (iout,*) "gloc_sc after reduce"
 794       do i=1,nres
 795        do j=1,1
 796         write (iout,*) i,j,gloc_sc(j,i,icg)
 797        enddo
 798       enddo
 799 #endif
 800 c#undef DEBUG
 801 #ifdef DEBUG
 802       write (iout,*) "gloc after reduce"
 803       do i=1,4*nres
 804         write (iout,*) i,gloc(i,icg)
 805       enddo
 806 #endif
 807       endif
 808 #endif
 809       if (gnorm_check) then
 810 c
 811 c Compute the maximum elements of the gradient
 812 c
 813       gvdwc_max=0.0d0
 814       gvdwc_scp_max=0.0d0
 815       gelc_max=0.0d0
 816       gvdwpp_max=0.0d0
 817       gradb_max=0.0d0
 818       ghpbc_max=0.0d0
 819       gradcorr_max=0.0d0
 820       gel_loc_max=0.0d0
 821       gcorr3_turn_max=0.0d0
 822       gcorr4_turn_max=0.0d0
 823       gradcorr5_max=0.0d0
 824       gradcorr6_max=0.0d0
 825       gcorr6_turn_max=0.0d0
 826       gsccorc_max=0.0d0
 827       gscloc_max=0.0d0
 828       gvdwx_max=0.0d0
 829       gradx_scp_max=0.0d0
 830       ghpbx_max=0.0d0
 831       gradxorr_max=0.0d0
 832       gsccorx_max=0.0d0
 833       gsclocx_max=0.0d0
 834       do i=1,nct
 835         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 836         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 837         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 838         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 839      &   gvdwc_scp_max=gvdwc_scp_norm
 840         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 841         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 842         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 843         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 844         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 845         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 846         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 847         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 848         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 849         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 850         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 851         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 852         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 853      &    gcorr3_turn(1,i)))
 854         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 855      &    gcorr3_turn_max=gcorr3_turn_norm
 856         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 857      &    gcorr4_turn(1,i)))
 858         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 859      &    gcorr4_turn_max=gcorr4_turn_norm
 860         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 861         if (gradcorr5_norm.gt.gradcorr5_max)
 862      &    gradcorr5_max=gradcorr5_norm
 863         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 864         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 865         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 866      &    gcorr6_turn(1,i)))
 867         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 868      &    gcorr6_turn_max=gcorr6_turn_norm
 869         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 870         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 871         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 872         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 873         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 874         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 875         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 876         if (gradx_scp_norm.gt.gradx_scp_max)
 877      &    gradx_scp_max=gradx_scp_norm
 878         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 879         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 880         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 881         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 882         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 883         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 884         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 885         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 886       enddo
 887       if (gradout) then
 888 #ifdef AIX
 889         open(istat,file=statname,position="append")
 890 #else
 891         open(istat,file=statname,access="append")
 892 #endif
 893         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 894      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 895      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 896      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 897      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 898      &     gsccorx_max,gsclocx_max
 899         close(istat)
 900         if (gvdwc_max.gt.1.0d4) then
 901           write (iout,*) "gvdwc gvdwx gradb gradbx"
 902           do i=nnt,nct
 903             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 904      &        gradb(j,i),gradbx(j,i),j=1,3)
 905           enddo
 906           call pdbout(0.0d0,'cipiszcze',iout)
 907           call flush(iout)
 908         endif
 909       endif
 910       endif
 911 #ifdef DEBUG
 912       write (iout,*) "gradc gradx gloc"
 913       do i=1,nres
 914         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 915      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 916       enddo
 917 #endif
 918 #ifdef TIMING
 919       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 920 #endif
 921       return
 922       end
 923 c-------------------------------------------------------------------------------
 924       subroutine rescale_weights(t_bath)
 925       implicit real*8 (a-h,o-z)
 926       include 'DIMENSIONS'
 927       include 'COMMON.IOUNITS'
 928       include 'COMMON.FFIELD'
 929       include 'COMMON.SBRIDGE'
 930       double precision kfac /2.4d0/
 931       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 932 c      facT=temp0/t_bath
 933 c      facT=2*temp0/(t_bath+temp0)
 934       if (rescale_mode.eq.0) then
 935         facT=1.0d0
 936         facT2=1.0d0
 937         facT3=1.0d0
 938         facT4=1.0d0
 939         facT5=1.0d0
 940       else if (rescale_mode.eq.1) then
 941         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 942         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 943         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 944         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 945         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 946       else if (rescale_mode.eq.2) then
 947         x=t_bath/temp0
 948         x2=x*x
 949         x3=x2*x
 950         x4=x3*x
 951         x5=x4*x
 952         facT=licznik/dlog(dexp(x)+dexp(-x))
 953         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 954         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 955         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 956         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 957       else
 958         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 959         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 960 #ifdef MPI
 961        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 962 #endif
 963        stop 555
 964       endif
 965       welec=weights(3)*fact
 966       wcorr=weights(4)*fact3
 967       wcorr5=weights(5)*fact4
 968       wcorr6=weights(6)*fact5
 969       wel_loc=weights(7)*fact2
 970       wturn3=weights(8)*fact2
 971       wturn4=weights(9)*fact3
 972       wturn6=weights(10)*fact5
 973       wtor=weights(13)*fact
 974       wtor_d=weights(14)*fact2
 975       wsccor=weights(21)*fact
 976
 977       return
 978       end
 979 C------------------------------------------------------------------------
 980       subroutine enerprint(energia)
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'COMMON.IOUNITS'
 984       include 'COMMON.FFIELD'
 985       include 'COMMON.SBRIDGE'
 986       include 'COMMON.MD'
 987       double precision energia(0:n_ene)
 988       etot=energia(0)
 989       evdw=energia(1)
 990       evdw2=energia(2)
 991 #ifdef SCP14
 992       evdw2=energia(2)+energia(18)
 993 #else
 994       evdw2=energia(2)
 995 #endif
 996       ees=energia(3)
 997 #ifdef SPLITELE
 998       evdw1=energia(16)
 999 #endif
1000       ecorr=energia(4)
1001       ecorr5=energia(5)
1002       ecorr6=energia(6)
1003       eel_loc=energia(7)
1004       eello_turn3=energia(8)
1005       eello_turn4=energia(9)
1006       eello_turn6=energia(10)
1007       ebe=energia(11)
1008       escloc=energia(12)
1009       etors=energia(13)
1010       etors_d=energia(14)
1011       ehpb=energia(15)
1012       edihcnstr=energia(19)
1013       estr=energia(17)
1014       Uconst=energia(20)
1015       esccor=energia(21)
1016       eliptran=energia(22)
1017       Eafmforce=energia(23)
1018 #ifdef SPLITELE
1019       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1020      &  estr,wbond,ebe,wang,
1021      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1022      &  ecorr,wcorr,
1023      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1024      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1025      &  edihcnstr,ebr*nss,
1026      &  Uconst,eliptran,wliptran,Eafmforce,etot
1027    10 format (/'Virtual-chain energies:'//
1028      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1029      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1030      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1031      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1032      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1033      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1034      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1035      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1036      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1037      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1038      & ' (SS bridges & dist. cnstr.)'/
1039      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1040      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1041      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1042      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1043      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1044      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1045      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1046      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1047      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1048      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1049      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1050      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1051      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1052      & 'ETOT=  ',1pE16.6,' (total)')
1053
1054 #else
1055       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1056      &  estr,wbond,ebe,wang,
1057      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1058      &  ecorr,wcorr,
1059      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1060      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1061      &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
1062    10 format (/'Virtual-chain energies:'//
1063      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1064      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1065      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1066      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1067      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1068      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1069      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1070      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1071      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1072      & ' (SS bridges & dist. cnstr.)'/
1073      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1074      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1075      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1076      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1077      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1078      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1079      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1080      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1081      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1082      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1083      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1084      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1085      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1086      & 'ETOT=  ',1pE16.6,' (total)')
1087 #endif
1088       return
1089       end
1090 C-----------------------------------------------------------------------
1091       subroutine elj(evdw)
1092 C
1093 C This subroutine calculates the interaction energy of nonbonded side chains
1094 C assuming the LJ potential of interaction.
1095 C
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       parameter (accur=1.0d-10)
1099       include 'COMMON.GEO'
1100       include 'COMMON.VAR'
1101       include 'COMMON.LOCAL'
1102       include 'COMMON.CHAIN'
1103       include 'COMMON.DERIV'
1104       include 'COMMON.INTERACT'
1105       include 'COMMON.TORSION'
1106       include 'COMMON.SBRIDGE'
1107       include 'COMMON.NAMES'
1108       include 'COMMON.IOUNITS'
1109       include 'COMMON.CONTACTS'
1110       dimension gg(3)
1111 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1112       evdw=0.0D0
1113       do i=iatsc_s,iatsc_e
1114         itypi=iabs(itype(i))
1115         if (itypi.eq.ntyp1) cycle
1116         itypi1=iabs(itype(i+1))
1117         xi=c(1,nres+i)
1118         yi=c(2,nres+i)
1119         zi=c(3,nres+i)
1120 C Change 12/1/95
1121         num_conti=0
1122 C
1123 C Calculate SC interaction energy.
1124 C
1125         do iint=1,nint_gr(i)
1126 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1127 cd   &                  'iend=',iend(i,iint)
1128           do j=istart(i,iint),iend(i,iint)
1129             itypj=iabs(itype(j))
1130             if (itypj.eq.ntyp1) cycle
1131             xj=c(1,nres+j)-xi
1132             yj=c(2,nres+j)-yi
1133             zj=c(3,nres+j)-zi
1134 C Change 12/1/95 to calculate four-body interactions
1135             rij=xj*xj+yj*yj+zj*zj
1136             rrij=1.0D0/rij
1137 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1138             eps0ij=eps(itypi,itypj)
1139             fac=rrij**expon2
1140 C have you changed here?
1141             e1=fac*fac*aa
1142             e2=fac*bb
1143             evdwij=e1+e2
1144 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1145 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1146 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1147 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1148 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1149 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1150             evdw=evdw+evdwij
1151 C
1152 C Calculate the components of the gradient in DC and X
1153 C
1154             fac=-rrij*(e1+evdwij)
1155             gg(1)=xj*fac
1156             gg(2)=yj*fac
1157             gg(3)=zj*fac
1158             do k=1,3
1159               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1160               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1161               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1162               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1163             enddo
1164 cgrad            do k=i,j-1
1165 cgrad              do l=1,3
1166 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1167 cgrad              enddo
1168 cgrad            enddo
1169 C
1170 C 12/1/95, revised on 5/20/97
1171 C
1172 C Calculate the contact function. The ith column of the array JCONT will
1173 C contain the numbers of atoms that make contacts with the atom I (of numbers
1174 C greater than I). The arrays FACONT and GACONT will contain the values of
1175 C the contact function and its derivative.
1176 C
1177 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1178 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1179 C Uncomment next line, if the correlation interactions are contact function only
1180             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1181               rij=dsqrt(rij)
1182               sigij=sigma(itypi,itypj)
1183               r0ij=rs0(itypi,itypj)
1184 C
1185 C Check whether the SC's are not too far to make a contact.
1186 C
1187               rcut=1.5d0*r0ij
1188               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1189 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1190 C
1191               if (fcont.gt.0.0D0) then
1192 C If the SC-SC distance if close to sigma, apply spline.
1193 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1194 cAdam &             fcont1,fprimcont1)
1195 cAdam           fcont1=1.0d0-fcont1
1196 cAdam           if (fcont1.gt.0.0d0) then
1197 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1198 cAdam             fcont=fcont*fcont1
1199 cAdam           endif
1200 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1201 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1202 cga             do k=1,3
1203 cga               gg(k)=gg(k)*eps0ij
1204 cga             enddo
1205 cga             eps0ij=-evdwij*eps0ij
1206 C Uncomment for AL's type of SC correlation interactions.
1207 cadam           eps0ij=-evdwij
1208                 num_conti=num_conti+1
1209                 jcont(num_conti,i)=j
1210                 facont(num_conti,i)=fcont*eps0ij
1211                 fprimcont=eps0ij*fprimcont/rij
1212                 fcont=expon*fcont
1213 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1214 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1215 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1216 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1217                 gacont(1,num_conti,i)=-fprimcont*xj
1218                 gacont(2,num_conti,i)=-fprimcont*yj
1219                 gacont(3,num_conti,i)=-fprimcont*zj
1220 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1221 cd              write (iout,'(2i3,3f10.5)')
1222 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1223               endif
1224             endif
1225           enddo      ! j
1226         enddo        ! iint
1227 C Change 12/1/95
1228         num_cont(i)=num_conti
1229       enddo          ! i
1230       do i=1,nct
1231         do j=1,3
1232           gvdwc(j,i)=expon*gvdwc(j,i)
1233           gvdwx(j,i)=expon*gvdwx(j,i)
1234         enddo
1235       enddo
1236 C******************************************************************************
1237 C
1238 C                              N O T E !!!
1239 C
1240 C To save time, the factor of EXPON has been extracted from ALL components
1241 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1242 C use!
1243 C
1244 C******************************************************************************
1245       return
1246       end
1247 C-----------------------------------------------------------------------------
1248       subroutine eljk(evdw)
1249 C
1250 C This subroutine calculates the interaction energy of nonbonded side chains
1251 C assuming the LJK potential of interaction.
1252 C
1253       implicit real*8 (a-h,o-z)
1254       include 'DIMENSIONS'
1255       include 'COMMON.GEO'
1256       include 'COMMON.VAR'
1257       include 'COMMON.LOCAL'
1258       include 'COMMON.CHAIN'
1259       include 'COMMON.DERIV'
1260       include 'COMMON.INTERACT'
1261       include 'COMMON.IOUNITS'
1262       include 'COMMON.NAMES'
1263       dimension gg(3)
1264       logical scheck
1265 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1266       evdw=0.0D0
1267       do i=iatsc_s,iatsc_e
1268         itypi=iabs(itype(i))
1269         if (itypi.eq.ntyp1) cycle
1270         itypi1=iabs(itype(i+1))
1271         xi=c(1,nres+i)
1272         yi=c(2,nres+i)
1273         zi=c(3,nres+i)
1274 C
1275 C Calculate SC interaction energy.
1276 C
1277         do iint=1,nint_gr(i)
1278           do j=istart(i,iint),iend(i,iint)
1279             itypj=iabs(itype(j))
1280             if (itypj.eq.ntyp1) cycle
1281             xj=c(1,nres+j)-xi
1282             yj=c(2,nres+j)-yi
1283             zj=c(3,nres+j)-zi
1284             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1285             fac_augm=rrij**expon
1286             e_augm=augm(itypi,itypj)*fac_augm
1287             r_inv_ij=dsqrt(rrij)
1288             rij=1.0D0/r_inv_ij
1289             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1290             fac=r_shift_inv**expon
1291 C have you changed here?
1292             e1=fac*fac*aa
1293             e2=fac*bb
1294             evdwij=e_augm+e1+e2
1295 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1296 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1297 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1298 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1299 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1300 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1301 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1302             evdw=evdw+evdwij
1303 C
1304 C Calculate the components of the gradient in DC and X
1305 C
1306             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1307             gg(1)=xj*fac
1308             gg(2)=yj*fac
1309             gg(3)=zj*fac
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 cgrad            do k=i,j-1
1317 cgrad              do l=1,3
1318 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1319 cgrad              enddo
1320 cgrad            enddo
1321           enddo      ! j
1322         enddo        ! iint
1323       enddo          ! i
1324       do i=1,nct
1325         do j=1,3
1326           gvdwc(j,i)=expon*gvdwc(j,i)
1327           gvdwx(j,i)=expon*gvdwx(j,i)
1328         enddo
1329       enddo
1330       return
1331       end
1332 C-----------------------------------------------------------------------------
1333       subroutine ebp(evdw)
1334 C
1335 C This subroutine calculates the interaction energy of nonbonded side chains
1336 C assuming the Berne-Pechukas potential of interaction.
1337 C
1338       implicit real*8 (a-h,o-z)
1339       include 'DIMENSIONS'
1340       include 'COMMON.GEO'
1341       include 'COMMON.VAR'
1342       include 'COMMON.LOCAL'
1343       include 'COMMON.CHAIN'
1344       include 'COMMON.DERIV'
1345       include 'COMMON.NAMES'
1346       include 'COMMON.INTERACT'
1347       include 'COMMON.IOUNITS'
1348       include 'COMMON.CALC'
1349       common /srutu/ icall
1350 c     double precision rrsave(maxdim)
1351       logical lprn
1352       evdw=0.0D0
1353 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1354       evdw=0.0D0
1355 c     if (icall.eq.0) then
1356 c       lprn=.true.
1357 c     else
1358         lprn=.false.
1359 c     endif
1360       ind=0
1361       do i=iatsc_s,iatsc_e
1362         itypi=iabs(itype(i))
1363         if (itypi.eq.ntyp1) cycle
1364         itypi1=iabs(itype(i+1))
1365         xi=c(1,nres+i)
1366         yi=c(2,nres+i)
1367         zi=c(3,nres+i)
1368         dxi=dc_norm(1,nres+i)
1369         dyi=dc_norm(2,nres+i)
1370         dzi=dc_norm(3,nres+i)
1371 c        dsci_inv=dsc_inv(itypi)
1372         dsci_inv=vbld_inv(i+nres)
1373 C
1374 C Calculate SC interaction energy.
1375 C
1376         do iint=1,nint_gr(i)
1377           do j=istart(i,iint),iend(i,iint)
1378             ind=ind+1
1379             itypj=iabs(itype(j))
1380             if (itypj.eq.ntyp1) cycle
1381 c            dscj_inv=dsc_inv(itypj)
1382             dscj_inv=vbld_inv(j+nres)
1383             chi1=chi(itypi,itypj)
1384             chi2=chi(itypj,itypi)
1385             chi12=chi1*chi2
1386             chip1=chip(itypi)
1387             chip2=chip(itypj)
1388             chip12=chip1*chip2
1389             alf1=alp(itypi)
1390             alf2=alp(itypj)
1391             alf12=0.5D0*(alf1+alf2)
1392 C For diagnostics only!!!
1393 c           chi1=0.0D0
1394 c           chi2=0.0D0
1395 c           chi12=0.0D0
1396 c           chip1=0.0D0
1397 c           chip2=0.0D0
1398 c           chip12=0.0D0
1399 c           alf1=0.0D0
1400 c           alf2=0.0D0
1401 c           alf12=0.0D0
1402             xj=c(1,nres+j)-xi
1403             yj=c(2,nres+j)-yi
1404             zj=c(3,nres+j)-zi
1405             dxj=dc_norm(1,nres+j)
1406             dyj=dc_norm(2,nres+j)
1407             dzj=dc_norm(3,nres+j)
1408             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1409 cd          if (icall.eq.0) then
1410 cd            rrsave(ind)=rrij
1411 cd          else
1412 cd            rrij=rrsave(ind)
1413 cd          endif
1414             rij=dsqrt(rrij)
1415 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1416             call sc_angular
1417 C Calculate whole angle-dependent part of epsilon and contributions
1418 C to its derivatives
1419 C have you changed here?
1420             fac=(rrij*sigsq)**expon2
1421             e1=fac*fac*aa
1422             e2=fac*bb
1423             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1424             eps2der=evdwij*eps3rt
1425             eps3der=evdwij*eps2rt
1426             evdwij=evdwij*eps2rt*eps3rt
1427             evdw=evdw+evdwij
1428             if (lprn) then
1429             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1430             epsi=bb**2/aa
1431 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1432 cd     &        restyp(itypi),i,restyp(itypj),j,
1433 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1434 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1435 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1436 cd     &        evdwij
1437             endif
1438 C Calculate gradient components.
1439             e1=e1*eps1*eps2rt**2*eps3rt**2
1440             fac=-expon*(e1+evdwij)
1441             sigder=fac/sigsq
1442             fac=rrij*fac
1443 C Calculate radial part of the gradient
1444             gg(1)=xj*fac
1445             gg(2)=yj*fac
1446             gg(3)=zj*fac
1447 C Calculate the angular part of the gradient and sum add the contributions
1448 C to the appropriate components of the Cartesian gradient.
1449             call sc_grad
1450           enddo      ! j
1451         enddo        ! iint
1452       enddo          ! i
1453 c     stop
1454       return
1455       end
1456 C-----------------------------------------------------------------------------
1457       subroutine egb(evdw)
1458 C
1459 C This subroutine calculates the interaction energy of nonbonded side chains
1460 C assuming the Gay-Berne potential of interaction.
1461 C
1462       implicit real*8 (a-h,o-z)
1463       include 'DIMENSIONS'
1464       include 'COMMON.GEO'
1465       include 'COMMON.VAR'
1466       include 'COMMON.LOCAL'
1467       include 'COMMON.CHAIN'
1468       include 'COMMON.DERIV'
1469       include 'COMMON.NAMES'
1470       include 'COMMON.INTERACT'
1471       include 'COMMON.IOUNITS'
1472       include 'COMMON.CALC'
1473       include 'COMMON.CONTROL'
1474       include 'COMMON.SPLITELE'
1475       include 'COMMON.SBRIDGE'
1476       logical lprn
1477       integer xshift,yshift,zshift
1478       evdw=0.0D0
1479 ccccc      energy_dec=.false.
1480 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1481       evdw=0.0D0
1482       lprn=.false.
1483 c     if (icall.eq.0) lprn=.false.
1484       ind=0
1485 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1486 C we have the original box)
1487 C      do xshift=-1,1
1488 C      do yshift=-1,1
1489 C      do zshift=-1,1
1490       do i=iatsc_s,iatsc_e
1491         itypi=iabs(itype(i))
1492         if (itypi.eq.ntyp1) cycle
1493         itypi1=iabs(itype(i+1))
1494         xi=c(1,nres+i)
1495         yi=c(2,nres+i)
1496         zi=c(3,nres+i)
1497 C Return atom into box, boxxsize is size of box in x dimension
1498 c  134   continue
1499 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1500 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1501 C Condition for being inside the proper box
1502 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1503 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1504 c        go to 134
1505 c        endif
1506 c  135   continue
1507 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1508 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1509 C Condition for being inside the proper box
1510 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1511 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1512 c        go to 135
1513 c        endif
1514 c  136   continue
1515 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1516 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1517 C Condition for being inside the proper box
1518 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1519 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1520 c        go to 136
1521 c        endif
1522           xi=mod(xi,boxxsize)
1523           if (xi.lt.0) xi=xi+boxxsize
1524           yi=mod(yi,boxysize)
1525           if (yi.lt.0) yi=yi+boxysize
1526           zi=mod(zi,boxzsize)
1527           if (zi.lt.0) zi=zi+boxzsize
1528 C define scaling factor for lipids
1529
1530 C        if (positi.le.0) positi=positi+boxzsize
1531 C        print *,i
1532 C first for peptide groups
1533 c for each residue check if it is in lipid or lipid water border area
1534        if ((zi.gt.bordlipbot)
1535      &.and.(zi.lt.bordliptop)) then
1536 C the energy transfer exist
1537         if (zi.lt.buflipbot) then
1538 C what fraction I am in
1539          fracinbuf=1.0d0-
1540      &        ((zi-bordlipbot)/lipbufthick)
1541 C lipbufthick is thickenes of lipid buffore
1542          sslipi=sscalelip(fracinbuf)
1543          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1544         elseif (zi.gt.bufliptop) then
1545          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1546          sslipi=sscalelip(fracinbuf)
1547          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1548         else
1549          sslipi=1.0d0
1550          ssgradlipi=0.0
1551         endif
1552        else
1553          sslipi=0.0d0
1554          ssgradlipi=0.0
1555        endif
1556
1557 C          xi=xi+xshift*boxxsize
1558 C          yi=yi+yshift*boxysize
1559 C          zi=zi+zshift*boxzsize
1560
1561         dxi=dc_norm(1,nres+i)
1562         dyi=dc_norm(2,nres+i)
1563         dzi=dc_norm(3,nres+i)
1564 c        dsci_inv=dsc_inv(itypi)
1565         dsci_inv=vbld_inv(i+nres)
1566 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1567 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1568 C
1569 C Calculate SC interaction energy.
1570 C
1571         do iint=1,nint_gr(i)
1572           do j=istart(i,iint),iend(i,iint)
1573             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1574               call dyn_ssbond_ene(i,j,evdwij)
1575               evdw=evdw+evdwij
1576               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1577      &                        'evdw',i,j,evdwij,' ss'
1578             ELSE
1579             ind=ind+1
1580             itypj=iabs(itype(j))
1581             if (itypj.eq.ntyp1) cycle
1582 c            dscj_inv=dsc_inv(itypj)
1583             dscj_inv=vbld_inv(j+nres)
1584 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1585 c     &       1.0d0/vbld(j+nres)
1586 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1587             sig0ij=sigma(itypi,itypj)
1588             chi1=chi(itypi,itypj)
1589             chi2=chi(itypj,itypi)
1590             chi12=chi1*chi2
1591             chip1=chip(itypi)
1592             chip2=chip(itypj)
1593             chip12=chip1*chip2
1594             alf1=alp(itypi)
1595             alf2=alp(itypj)
1596             alf12=0.5D0*(alf1+alf2)
1597 C For diagnostics only!!!
1598 c           chi1=0.0D0
1599 c           chi2=0.0D0
1600 c           chi12=0.0D0
1601 c           chip1=0.0D0
1602 c           chip2=0.0D0
1603 c           chip12=0.0D0
1604 c           alf1=0.0D0
1605 c           alf2=0.0D0
1606 c           alf12=0.0D0
1607             xj=c(1,nres+j)
1608             yj=c(2,nres+j)
1609             zj=c(3,nres+j)
1610 C Return atom J into box the original box
1611 c  137   continue
1612 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1613 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1614 C Condition for being inside the proper box
1615 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1616 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1617 c        go to 137
1618 c        endif
1619 c  138   continue
1620 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1621 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1622 C Condition for being inside the proper box
1623 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1624 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1625 c        go to 138
1626 c        endif
1627 c  139   continue
1628 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1629 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1630 C Condition for being inside the proper box
1631 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1632 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1633 c        go to 139
1634 c        endif
1635           xj=mod(xj,boxxsize)
1636           if (xj.lt.0) xj=xj+boxxsize
1637           yj=mod(yj,boxysize)
1638           if (yj.lt.0) yj=yj+boxysize
1639           zj=mod(zj,boxzsize)
1640           if (zj.lt.0) zj=zj+boxzsize
1641        if ((zj.gt.bordlipbot)
1642      &.and.(zj.lt.bordliptop)) then
1643 C the energy transfer exist
1644         if (zj.lt.buflipbot) then
1645 C what fraction I am in
1646          fracinbuf=1.0d0-
1647      &        ((zj-bordlipbot)/lipbufthick)
1648 C lipbufthick is thickenes of lipid buffore
1649          sslipj=sscalelip(fracinbuf)
1650          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1651         elseif (zj.gt.bufliptop) then
1652          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1653          sslipj=sscalelip(fracinbuf)
1654          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1655         else
1656          sslipj=1.0d0
1657          ssgradlipj=0.0
1658         endif
1659        else
1660          sslipj=0.0d0
1661          ssgradlipj=0.0
1662        endif
1663       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1664      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1665       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1666      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1667 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1668 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1669 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1670 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1671       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1672       xj_safe=xj
1673       yj_safe=yj
1674       zj_safe=zj
1675       subchap=0
1676       do xshift=-1,1
1677       do yshift=-1,1
1678       do zshift=-1,1
1679           xj=xj_safe+xshift*boxxsize
1680           yj=yj_safe+yshift*boxysize
1681           zj=zj_safe+zshift*boxzsize
1682           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1683           if(dist_temp.lt.dist_init) then
1684             dist_init=dist_temp
1685             xj_temp=xj
1686             yj_temp=yj
1687             zj_temp=zj
1688             subchap=1
1689           endif
1690        enddo
1691        enddo
1692        enddo
1693        if (subchap.eq.1) then
1694           xj=xj_temp-xi
1695           yj=yj_temp-yi
1696           zj=zj_temp-zi
1697        else
1698           xj=xj_safe-xi
1699           yj=yj_safe-yi
1700           zj=zj_safe-zi
1701        endif
1702             dxj=dc_norm(1,nres+j)
1703             dyj=dc_norm(2,nres+j)
1704             dzj=dc_norm(3,nres+j)
1705 C            xj=xj-xi
1706 C            yj=yj-yi
1707 C            zj=zj-zi
1708 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1709 c            write (iout,*) "j",j," dc_norm",
1710 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1711             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1712             rij=dsqrt(rrij)
1713             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1714             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1715
1716 c            write (iout,'(a7,4f8.3)')
1717 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1718             if (sss.gt.0.0d0) then
1719 C Calculate angle-dependent terms of energy and contributions to their
1720 C derivatives.
1721             call sc_angular
1722             sigsq=1.0D0/sigsq
1723             sig=sig0ij*dsqrt(sigsq)
1724             rij_shift=1.0D0/rij-sig+sig0ij
1725 c for diagnostics; uncomment
1726 c            rij_shift=1.2*sig0ij
1727 C I hate to put IF's in the loops, but here don't have another choice!!!!
1728             if (rij_shift.le.0.0D0) then
1729               evdw=1.0D20
1730 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1731 cd     &        restyp(itypi),i,restyp(itypj),j,
1732 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1733               return
1734             endif
1735             sigder=-sig*sigsq
1736 c---------------------------------------------------------------
1737             rij_shift=1.0D0/rij_shift
1738             fac=rij_shift**expon
1739 C here to start with
1740 C            if (c(i,3).gt.
1741             faclip=fac
1742             e1=fac*fac*aa
1743             e2=fac*bb
1744             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1745             eps2der=evdwij*eps3rt
1746             eps3der=evdwij*eps2rt
1747 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1748 C     &((sslipi+sslipj)/2.0d0+
1749 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1750 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1751 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1752             evdwij=evdwij*eps2rt*eps3rt
1753             evdw=evdw+evdwij*sss
1754             if (lprn) then
1755             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1756             epsi=bb**2/aa
1757             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1758      &        restyp(itypi),i,restyp(itypj),j,
1759      &        epsi,sigm,chi1,chi2,chip1,chip2,
1760      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1761      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1762      &        evdwij
1763             endif
1764
1765             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1766      &                        'evdw',i,j,evdwij
1767
1768 C Calculate gradient components.
1769             e1=e1*eps1*eps2rt**2*eps3rt**2
1770             fac=-expon*(e1+evdwij)*rij_shift
1771             sigder=fac*sigder
1772             fac=rij*fac
1773 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1774 c     &      evdwij,fac,sigma(itypi,itypj),expon
1775             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1776 c            fac=0.0d0
1777 C Calculate the radial part of the gradient
1778             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1779      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1780      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1781      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1782             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1783             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1784 C            gg_lipi(3)=0.0d0
1785 C            gg_lipj(3)=0.0d0
1786             gg(1)=xj*fac
1787             gg(2)=yj*fac
1788             gg(3)=zj*fac
1789 C Calculate angular part of the gradient.
1790             call sc_grad
1791             endif
1792             ENDIF    ! dyn_ss
1793           enddo      ! j
1794         enddo        ! iint
1795       enddo          ! i
1796 C      enddo          ! zshift
1797 C      enddo          ! yshift
1798 C      enddo          ! xshift
1799 c      write (iout,*) "Number of loop steps in EGB:",ind
1800 cccc      energy_dec=.false.
1801       return
1802       end
1803 C-----------------------------------------------------------------------------
1804       subroutine egbv(evdw)
1805 C
1806 C This subroutine calculates the interaction energy of nonbonded side chains
1807 C assuming the Gay-Berne-Vorobjev potential of interaction.
1808 C
1809       implicit real*8 (a-h,o-z)
1810       include 'DIMENSIONS'
1811       include 'COMMON.GEO'
1812       include 'COMMON.VAR'
1813       include 'COMMON.LOCAL'
1814       include 'COMMON.CHAIN'
1815       include 'COMMON.DERIV'
1816       include 'COMMON.NAMES'
1817       include 'COMMON.INTERACT'
1818       include 'COMMON.IOUNITS'
1819       include 'COMMON.CALC'
1820       common /srutu/ icall
1821       logical lprn
1822       evdw=0.0D0
1823 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1824       evdw=0.0D0
1825       lprn=.false.
1826 c     if (icall.eq.0) lprn=.true.
1827       ind=0
1828       do i=iatsc_s,iatsc_e
1829         itypi=iabs(itype(i))
1830         if (itypi.eq.ntyp1) cycle
1831         itypi1=iabs(itype(i+1))
1832         xi=c(1,nres+i)
1833         yi=c(2,nres+i)
1834         zi=c(3,nres+i)
1835           xi=mod(xi,boxxsize)
1836           if (xi.lt.0) xi=xi+boxxsize
1837           yi=mod(yi,boxysize)
1838           if (yi.lt.0) yi=yi+boxysize
1839           zi=mod(zi,boxzsize)
1840           if (zi.lt.0) zi=zi+boxzsize
1841 C define scaling factor for lipids
1842
1843 C        if (positi.le.0) positi=positi+boxzsize
1844 C        print *,i
1845 C first for peptide groups
1846 c for each residue check if it is in lipid or lipid water border area
1847        if ((zi.gt.bordlipbot)
1848      &.and.(zi.lt.bordliptop)) then
1849 C the energy transfer exist
1850         if (zi.lt.buflipbot) then
1851 C what fraction I am in
1852          fracinbuf=1.0d0-
1853      &        ((zi-bordlipbot)/lipbufthick)
1854 C lipbufthick is thickenes of lipid buffore
1855          sslipi=sscalelip(fracinbuf)
1856          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1857         elseif (zi.gt.bufliptop) then
1858          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1859          sslipi=sscalelip(fracinbuf)
1860          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1861         else
1862          sslipi=1.0d0
1863          ssgradlipi=0.0
1864         endif
1865        else
1866          sslipi=0.0d0
1867          ssgradlipi=0.0
1868        endif
1869
1870         dxi=dc_norm(1,nres+i)
1871         dyi=dc_norm(2,nres+i)
1872         dzi=dc_norm(3,nres+i)
1873 c        dsci_inv=dsc_inv(itypi)
1874         dsci_inv=vbld_inv(i+nres)
1875 C
1876 C Calculate SC interaction energy.
1877 C
1878         do iint=1,nint_gr(i)
1879           do j=istart(i,iint),iend(i,iint)
1880             ind=ind+1
1881             itypj=iabs(itype(j))
1882             if (itypj.eq.ntyp1) cycle
1883 c            dscj_inv=dsc_inv(itypj)
1884             dscj_inv=vbld_inv(j+nres)
1885             sig0ij=sigma(itypi,itypj)
1886             r0ij=r0(itypi,itypj)
1887             chi1=chi(itypi,itypj)
1888             chi2=chi(itypj,itypi)
1889             chi12=chi1*chi2
1890             chip1=chip(itypi)
1891             chip2=chip(itypj)
1892             chip12=chip1*chip2
1893             alf1=alp(itypi)
1894             alf2=alp(itypj)
1895             alf12=0.5D0*(alf1+alf2)
1896 C For diagnostics only!!!
1897 c           chi1=0.0D0
1898 c           chi2=0.0D0
1899 c           chi12=0.0D0
1900 c           chip1=0.0D0
1901 c           chip2=0.0D0
1902 c           chip12=0.0D0
1903 c           alf1=0.0D0
1904 c           alf2=0.0D0
1905 c           alf12=0.0D0
1906 C            xj=c(1,nres+j)-xi
1907 C            yj=c(2,nres+j)-yi
1908 C            zj=c(3,nres+j)-zi
1909           xj=mod(xj,boxxsize)
1910           if (xj.lt.0) xj=xj+boxxsize
1911           yj=mod(yj,boxysize)
1912           if (yj.lt.0) yj=yj+boxysize
1913           zj=mod(zj,boxzsize)
1914           if (zj.lt.0) zj=zj+boxzsize
1915        if ((zj.gt.bordlipbot)
1916      &.and.(zj.lt.bordliptop)) then
1917 C the energy transfer exist
1918         if (zj.lt.buflipbot) then
1919 C what fraction I am in
1920          fracinbuf=1.0d0-
1921      &        ((zj-bordlipbot)/lipbufthick)
1922 C lipbufthick is thickenes of lipid buffore
1923          sslipj=sscalelip(fracinbuf)
1924          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925         elseif (zj.gt.bufliptop) then
1926          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927          sslipj=sscalelip(fracinbuf)
1928          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1929         else
1930          sslipj=1.0d0
1931          ssgradlipj=0.0
1932         endif
1933        else
1934          sslipj=0.0d0
1935          ssgradlipj=0.0
1936        endif
1937       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1940      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1942 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1943       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1944       xj_safe=xj
1945       yj_safe=yj
1946       zj_safe=zj
1947       subchap=0
1948       do xshift=-1,1
1949       do yshift=-1,1
1950       do zshift=-1,1
1951           xj=xj_safe+xshift*boxxsize
1952           yj=yj_safe+yshift*boxysize
1953           zj=zj_safe+zshift*boxzsize
1954           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1955           if(dist_temp.lt.dist_init) then
1956             dist_init=dist_temp
1957             xj_temp=xj
1958             yj_temp=yj
1959             zj_temp=zj
1960             subchap=1
1961           endif
1962        enddo
1963        enddo
1964        enddo
1965        if (subchap.eq.1) then
1966           xj=xj_temp-xi
1967           yj=yj_temp-yi
1968           zj=zj_temp-zi
1969        else
1970           xj=xj_safe-xi
1971           yj=yj_safe-yi
1972           zj=zj_safe-zi
1973        endif
1974             dxj=dc_norm(1,nres+j)
1975             dyj=dc_norm(2,nres+j)
1976             dzj=dc_norm(3,nres+j)
1977             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1978             rij=dsqrt(rrij)
1979 C Calculate angle-dependent terms of energy and contributions to their
1980 C derivatives.
1981             call sc_angular
1982             sigsq=1.0D0/sigsq
1983             sig=sig0ij*dsqrt(sigsq)
1984             rij_shift=1.0D0/rij-sig+r0ij
1985 C I hate to put IF's in the loops, but here don't have another choice!!!!
1986             if (rij_shift.le.0.0D0) then
1987               evdw=1.0D20
1988               return
1989             endif
1990             sigder=-sig*sigsq
1991 c---------------------------------------------------------------
1992             rij_shift=1.0D0/rij_shift
1993             fac=rij_shift**expon
1994             e1=fac*fac*aa
1995             e2=fac*bb
1996             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1997             eps2der=evdwij*eps3rt
1998             eps3der=evdwij*eps2rt
1999             fac_augm=rrij**expon
2000             e_augm=augm(itypi,itypj)*fac_augm
2001             evdwij=evdwij*eps2rt*eps3rt
2002             evdw=evdw+evdwij+e_augm
2003             if (lprn) then
2004             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2005             epsi=bb**2/aa
2006             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2007      &        restyp(itypi),i,restyp(itypj),j,
2008      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2009      &        chi1,chi2,chip1,chip2,
2010      &        eps1,eps2rt**2,eps3rt**2,
2011      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2012      &        evdwij+e_augm
2013             endif
2014 C Calculate gradient components.
2015             e1=e1*eps1*eps2rt**2*eps3rt**2
2016             fac=-expon*(e1+evdwij)*rij_shift
2017             sigder=fac*sigder
2018             fac=rij*fac-2*expon*rrij*e_augm
2019             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2020 C Calculate the radial part of the gradient
2021             gg(1)=xj*fac
2022             gg(2)=yj*fac
2023             gg(3)=zj*fac
2024 C Calculate angular part of the gradient.
2025             call sc_grad
2026           enddo      ! j
2027         enddo        ! iint
2028       enddo          ! i
2029       end
2030 C-----------------------------------------------------------------------------
2031       subroutine sc_angular
2032 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2033 C om12. Called by ebp, egb, and egbv.
2034       implicit none
2035       include 'COMMON.CALC'
2036       include 'COMMON.IOUNITS'
2037       erij(1)=xj*rij
2038       erij(2)=yj*rij
2039       erij(3)=zj*rij
2040       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2041       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2042       om12=dxi*dxj+dyi*dyj+dzi*dzj
2043       chiom12=chi12*om12
2044 C Calculate eps1(om12) and its derivative in om12
2045       faceps1=1.0D0-om12*chiom12
2046       faceps1_inv=1.0D0/faceps1
2047       eps1=dsqrt(faceps1_inv)
2048 C Following variable is eps1*deps1/dom12
2049       eps1_om12=faceps1_inv*chiom12
2050 c diagnostics only
2051 c      faceps1_inv=om12
2052 c      eps1=om12
2053 c      eps1_om12=1.0d0
2054 c      write (iout,*) "om12",om12," eps1",eps1
2055 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2056 C and om12.
2057       om1om2=om1*om2
2058       chiom1=chi1*om1
2059       chiom2=chi2*om2
2060       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2061       sigsq=1.0D0-facsig*faceps1_inv
2062       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2063       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2064       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2065 c diagnostics only
2066 c      sigsq=1.0d0
2067 c      sigsq_om1=0.0d0
2068 c      sigsq_om2=0.0d0
2069 c      sigsq_om12=0.0d0
2070 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2071 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2072 c     &    " eps1",eps1
2073 C Calculate eps2 and its derivatives in om1, om2, and om12.
2074       chipom1=chip1*om1
2075       chipom2=chip2*om2
2076       chipom12=chip12*om12
2077       facp=1.0D0-om12*chipom12
2078       facp_inv=1.0D0/facp
2079       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2080 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2081 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2082 C Following variable is the square root of eps2
2083       eps2rt=1.0D0-facp1*facp_inv
2084 C Following three variables are the derivatives of the square root of eps
2085 C in om1, om2, and om12.
2086       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2087       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2088       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2089 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2090       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2091 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2092 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2093 c     &  " eps2rt_om12",eps2rt_om12
2094 C Calculate whole angle-dependent part of epsilon and contributions
2095 C to its derivatives
2096       return
2097       end
2098 C----------------------------------------------------------------------------
2099       subroutine sc_grad
2100       implicit real*8 (a-h,o-z)
2101       include 'DIMENSIONS'
2102       include 'COMMON.CHAIN'
2103       include 'COMMON.DERIV'
2104       include 'COMMON.CALC'
2105       include 'COMMON.IOUNITS'
2106       double precision dcosom1(3),dcosom2(3)
2107 cc      print *,'sss=',sss
2108       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2109       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2110       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2111      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2112 c diagnostics only
2113 c      eom1=0.0d0
2114 c      eom2=0.0d0
2115 c      eom12=evdwij*eps1_om12
2116 c end diagnostics
2117 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2118 c     &  " sigder",sigder
2119 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2120 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2121       do k=1,3
2122         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2123         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2124       enddo
2125       do k=1,3
2126         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2127       enddo
2128 c      write (iout,*) "gg",(gg(k),k=1,3)
2129       do k=1,3
2130         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2131      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2132      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2133         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2134      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2135      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2136 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2137 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2138 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2139 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2140       enddo
2141 C
2142 C Calculate the components of the gradient in DC and X
2143 C
2144 cgrad      do k=i,j-1
2145 cgrad        do l=1,3
2146 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2147 cgrad        enddo
2148 cgrad      enddo
2149       do l=1,3
2150         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2151         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2152       enddo
2153       return
2154       end
2155 C-----------------------------------------------------------------------
2156       subroutine e_softsphere(evdw)
2157 C
2158 C This subroutine calculates the interaction energy of nonbonded side chains
2159 C assuming the LJ potential of interaction.
2160 C
2161       implicit real*8 (a-h,o-z)
2162       include 'DIMENSIONS'
2163       parameter (accur=1.0d-10)
2164       include 'COMMON.GEO'
2165       include 'COMMON.VAR'
2166       include 'COMMON.LOCAL'
2167       include 'COMMON.CHAIN'
2168       include 'COMMON.DERIV'
2169       include 'COMMON.INTERACT'
2170       include 'COMMON.TORSION'
2171       include 'COMMON.SBRIDGE'
2172       include 'COMMON.NAMES'
2173       include 'COMMON.IOUNITS'
2174       include 'COMMON.CONTACTS'
2175       dimension gg(3)
2176 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2177       evdw=0.0D0
2178       do i=iatsc_s,iatsc_e
2179         itypi=iabs(itype(i))
2180         if (itypi.eq.ntyp1) cycle
2181         itypi1=iabs(itype(i+1))
2182         xi=c(1,nres+i)
2183         yi=c(2,nres+i)
2184         zi=c(3,nres+i)
2185 C
2186 C Calculate SC interaction energy.
2187 C
2188         do iint=1,nint_gr(i)
2189 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2190 cd   &                  'iend=',iend(i,iint)
2191           do j=istart(i,iint),iend(i,iint)
2192             itypj=iabs(itype(j))
2193             if (itypj.eq.ntyp1) cycle
2194             xj=c(1,nres+j)-xi
2195             yj=c(2,nres+j)-yi
2196             zj=c(3,nres+j)-zi
2197             rij=xj*xj+yj*yj+zj*zj
2198 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2199             r0ij=r0(itypi,itypj)
2200             r0ijsq=r0ij*r0ij
2201 c            print *,i,j,r0ij,dsqrt(rij)
2202             if (rij.lt.r0ijsq) then
2203               evdwij=0.25d0*(rij-r0ijsq)**2
2204               fac=rij-r0ijsq
2205             else
2206               evdwij=0.0d0
2207               fac=0.0d0
2208             endif
2209             evdw=evdw+evdwij
2210 C
2211 C Calculate the components of the gradient in DC and X
2212 C
2213             gg(1)=xj*fac
2214             gg(2)=yj*fac
2215             gg(3)=zj*fac
2216             do k=1,3
2217               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2218               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2219               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2220               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2221             enddo
2222 cgrad            do k=i,j-1
2223 cgrad              do l=1,3
2224 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2225 cgrad              enddo
2226 cgrad            enddo
2227           enddo ! j
2228         enddo ! iint
2229       enddo ! i
2230       return
2231       end
2232 C--------------------------------------------------------------------------
2233       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2234      &              eello_turn4)
2235 C
2236 C Soft-sphere potential of p-p interaction
2237 C
2238       implicit real*8 (a-h,o-z)
2239       include 'DIMENSIONS'
2240       include 'COMMON.CONTROL'
2241       include 'COMMON.IOUNITS'
2242       include 'COMMON.GEO'
2243       include 'COMMON.VAR'
2244       include 'COMMON.LOCAL'
2245       include 'COMMON.CHAIN'
2246       include 'COMMON.DERIV'
2247       include 'COMMON.INTERACT'
2248       include 'COMMON.CONTACTS'
2249       include 'COMMON.TORSION'
2250       include 'COMMON.VECTORS'
2251       include 'COMMON.FFIELD'
2252       dimension ggg(3)
2253 C      write(iout,*) 'In EELEC_soft_sphere'
2254       ees=0.0D0
2255       evdw1=0.0D0
2256       eel_loc=0.0d0
2257       eello_turn3=0.0d0
2258       eello_turn4=0.0d0
2259       ind=0
2260       do i=iatel_s,iatel_e
2261         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2262         dxi=dc(1,i)
2263         dyi=dc(2,i)
2264         dzi=dc(3,i)
2265         xmedi=c(1,i)+0.5d0*dxi
2266         ymedi=c(2,i)+0.5d0*dyi
2267         zmedi=c(3,i)+0.5d0*dzi
2268           xmedi=mod(xmedi,boxxsize)
2269           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2270           ymedi=mod(ymedi,boxysize)
2271           if (ymedi.lt.0) ymedi=ymedi+boxysize
2272           zmedi=mod(zmedi,boxzsize)
2273           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2274         num_conti=0
2275 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2276         do j=ielstart(i),ielend(i)
2277           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2278           ind=ind+1
2279           iteli=itel(i)
2280           itelj=itel(j)
2281           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2282           r0ij=rpp(iteli,itelj)
2283           r0ijsq=r0ij*r0ij
2284           dxj=dc(1,j)
2285           dyj=dc(2,j)
2286           dzj=dc(3,j)
2287           xj=c(1,j)+0.5D0*dxj
2288           yj=c(2,j)+0.5D0*dyj
2289           zj=c(3,j)+0.5D0*dzj
2290           xj=mod(xj,boxxsize)
2291           if (xj.lt.0) xj=xj+boxxsize
2292           yj=mod(yj,boxysize)
2293           if (yj.lt.0) yj=yj+boxysize
2294           zj=mod(zj,boxzsize)
2295           if (zj.lt.0) zj=zj+boxzsize
2296       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2297       xj_safe=xj
2298       yj_safe=yj
2299       zj_safe=zj
2300       isubchap=0
2301       do xshift=-1,1
2302       do yshift=-1,1
2303       do zshift=-1,1
2304           xj=xj_safe+xshift*boxxsize
2305           yj=yj_safe+yshift*boxysize
2306           zj=zj_safe+zshift*boxzsize
2307           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2308           if(dist_temp.lt.dist_init) then
2309             dist_init=dist_temp
2310             xj_temp=xj
2311             yj_temp=yj
2312             zj_temp=zj
2313             isubchap=1
2314           endif
2315        enddo
2316        enddo
2317        enddo
2318        if (isubchap.eq.1) then
2319           xj=xj_temp-xmedi
2320           yj=yj_temp-ymedi
2321           zj=zj_temp-zmedi
2322        else
2323           xj=xj_safe-xmedi
2324           yj=yj_safe-ymedi
2325           zj=zj_safe-zmedi
2326        endif
2327           rij=xj*xj+yj*yj+zj*zj
2328             sss=sscale(sqrt(rij))
2329             sssgrad=sscagrad(sqrt(rij))
2330           if (rij.lt.r0ijsq) then
2331             evdw1ij=0.25d0*(rij-r0ijsq)**2
2332             fac=rij-r0ijsq
2333           else
2334             evdw1ij=0.0d0
2335             fac=0.0d0
2336           endif
2337           evdw1=evdw1+evdw1ij*sss
2338 C
2339 C Calculate contributions to the Cartesian gradient.
2340 C
2341           ggg(1)=fac*xj*sssgrad
2342           ggg(2)=fac*yj*sssgrad
2343           ggg(3)=fac*zj*sssgrad
2344           do k=1,3
2345             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2346             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2347           enddo
2348 *
2349 * Loop over residues i+1 thru j-1.
2350 *
2351 cgrad          do k=i+1,j-1
2352 cgrad            do l=1,3
2353 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2354 cgrad            enddo
2355 cgrad          enddo
2356         enddo ! j
2357       enddo   ! i
2358 cgrad      do i=nnt,nct-1
2359 cgrad        do k=1,3
2360 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2361 cgrad        enddo
2362 cgrad        do j=i+1,nct-1
2363 cgrad          do k=1,3
2364 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2365 cgrad          enddo
2366 cgrad        enddo
2367 cgrad      enddo
2368       return
2369       end
2370 c------------------------------------------------------------------------------
2371       subroutine vec_and_deriv
2372       implicit real*8 (a-h,o-z)
2373       include 'DIMENSIONS'
2374 #ifdef MPI
2375       include 'mpif.h'
2376 #endif
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       include 'COMMON.SETUP'
2384       include 'COMMON.TIME1'
2385       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2386 C Compute the local reference systems. For reference system (i), the
2387 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2388 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2389 #ifdef PARVEC
2390       do i=ivec_start,ivec_end
2391 #else
2392       do i=1,nres-1
2393 #endif
2394           if (i.eq.nres-1) then
2395 C Case of the last full residue
2396 C Compute the Z-axis
2397             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2398             costh=dcos(pi-theta(nres))
2399             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2400             do k=1,3
2401               uz(k,i)=fac*uz(k,i)
2402             enddo
2403 C Compute the derivatives of uz
2404             uzder(1,1,1)= 0.0d0
2405             uzder(2,1,1)=-dc_norm(3,i-1)
2406             uzder(3,1,1)= dc_norm(2,i-1)
2407             uzder(1,2,1)= dc_norm(3,i-1)
2408             uzder(2,2,1)= 0.0d0
2409             uzder(3,2,1)=-dc_norm(1,i-1)
2410             uzder(1,3,1)=-dc_norm(2,i-1)
2411             uzder(2,3,1)= dc_norm(1,i-1)
2412             uzder(3,3,1)= 0.0d0
2413             uzder(1,1,2)= 0.0d0
2414             uzder(2,1,2)= dc_norm(3,i)
2415             uzder(3,1,2)=-dc_norm(2,i)
2416             uzder(1,2,2)=-dc_norm(3,i)
2417             uzder(2,2,2)= 0.0d0
2418             uzder(3,2,2)= dc_norm(1,i)
2419             uzder(1,3,2)= dc_norm(2,i)
2420             uzder(2,3,2)=-dc_norm(1,i)
2421             uzder(3,3,2)= 0.0d0
2422 C Compute the Y-axis
2423             facy=fac
2424             do k=1,3
2425               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2426             enddo
2427 C Compute the derivatives of uy
2428             do j=1,3
2429               do k=1,3
2430                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2431      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2432                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2433               enddo
2434               uyder(j,j,1)=uyder(j,j,1)-costh
2435               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2436             enddo
2437             do j=1,2
2438               do k=1,3
2439                 do l=1,3
2440                   uygrad(l,k,j,i)=uyder(l,k,j)
2441                   uzgrad(l,k,j,i)=uzder(l,k,j)
2442                 enddo
2443               enddo
2444             enddo
2445             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2446             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2447             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2448             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2449           else
2450 C Other residues
2451 C Compute the Z-axis
2452             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2453             costh=dcos(pi-theta(i+2))
2454             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2455             do k=1,3
2456               uz(k,i)=fac*uz(k,i)
2457             enddo
2458 C Compute the derivatives of uz
2459             uzder(1,1,1)= 0.0d0
2460             uzder(2,1,1)=-dc_norm(3,i+1)
2461             uzder(3,1,1)= dc_norm(2,i+1)
2462             uzder(1,2,1)= dc_norm(3,i+1)
2463             uzder(2,2,1)= 0.0d0
2464             uzder(3,2,1)=-dc_norm(1,i+1)
2465             uzder(1,3,1)=-dc_norm(2,i+1)
2466             uzder(2,3,1)= dc_norm(1,i+1)
2467             uzder(3,3,1)= 0.0d0
2468             uzder(1,1,2)= 0.0d0
2469             uzder(2,1,2)= dc_norm(3,i)
2470             uzder(3,1,2)=-dc_norm(2,i)
2471             uzder(1,2,2)=-dc_norm(3,i)
2472             uzder(2,2,2)= 0.0d0
2473             uzder(3,2,2)= dc_norm(1,i)
2474             uzder(1,3,2)= dc_norm(2,i)
2475             uzder(2,3,2)=-dc_norm(1,i)
2476             uzder(3,3,2)= 0.0d0
2477 C Compute the Y-axis
2478             facy=fac
2479             do k=1,3
2480               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2481             enddo
2482 C Compute the derivatives of uy
2483             do j=1,3
2484               do k=1,3
2485                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2486      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2487                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2488               enddo
2489               uyder(j,j,1)=uyder(j,j,1)-costh
2490               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2491             enddo
2492             do j=1,2
2493               do k=1,3
2494                 do l=1,3
2495                   uygrad(l,k,j,i)=uyder(l,k,j)
2496                   uzgrad(l,k,j,i)=uzder(l,k,j)
2497                 enddo
2498               enddo
2499             enddo
2500             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2501             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2502             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2503             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2504           endif
2505       enddo
2506       do i=1,nres-1
2507         vbld_inv_temp(1)=vbld_inv(i+1)
2508         if (i.lt.nres-1) then
2509           vbld_inv_temp(2)=vbld_inv(i+2)
2510           else
2511           vbld_inv_temp(2)=vbld_inv(i)
2512           endif
2513         do j=1,2
2514           do k=1,3
2515             do l=1,3
2516               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2517               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2518             enddo
2519           enddo
2520         enddo
2521       enddo
2522 #if defined(PARVEC) && defined(MPI)
2523       if (nfgtasks1.gt.1) then
2524         time00=MPI_Wtime()
2525 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2526 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2527 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2528         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2529      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2532      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2533      &   FG_COMM1,IERR)
2534         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2535      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2536      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2537         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2538      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2539      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2540         time_gather=time_gather+MPI_Wtime()-time00
2541       endif
2542 c      if (fg_rank.eq.0) then
2543 c        write (iout,*) "Arrays UY and UZ"
2544 c        do i=1,nres-1
2545 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2546 c     &     (uz(k,i),k=1,3)
2547 c        enddo
2548 c      endif
2549 #endif
2550       return
2551       end
2552 C-----------------------------------------------------------------------------
2553       subroutine check_vecgrad
2554       implicit real*8 (a-h,o-z)
2555       include 'DIMENSIONS'
2556       include 'COMMON.IOUNITS'
2557       include 'COMMON.GEO'
2558       include 'COMMON.VAR'
2559       include 'COMMON.LOCAL'
2560       include 'COMMON.CHAIN'
2561       include 'COMMON.VECTORS'
2562       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2563       dimension uyt(3,maxres),uzt(3,maxres)
2564       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2565       double precision delta /1.0d-7/
2566       call vec_and_deriv
2567 cd      do i=1,nres
2568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2569 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2570 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2571 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2572 cd     &     (dc_norm(if90,i),if90=1,3)
2573 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2574 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2575 cd          write(iout,'(a)')
2576 cd      enddo
2577       do i=1,nres
2578         do j=1,2
2579           do k=1,3
2580             do l=1,3
2581               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2582               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2583             enddo
2584           enddo
2585         enddo
2586       enddo
2587       call vec_and_deriv
2588       do i=1,nres
2589         do j=1,3
2590           uyt(j,i)=uy(j,i)
2591           uzt(j,i)=uz(j,i)
2592         enddo
2593       enddo
2594       do i=1,nres
2595 cd        write (iout,*) 'i=',i
2596         do k=1,3
2597           erij(k)=dc_norm(k,i)
2598         enddo
2599         do j=1,3
2600           do k=1,3
2601             dc_norm(k,i)=erij(k)
2602           enddo
2603           dc_norm(j,i)=dc_norm(j,i)+delta
2604 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2605 c          do k=1,3
2606 c            dc_norm(k,i)=dc_norm(k,i)/fac
2607 c          enddo
2608 c          write (iout,*) (dc_norm(k,i),k=1,3)
2609 c          write (iout,*) (erij(k),k=1,3)
2610           call vec_and_deriv
2611           do k=1,3
2612             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2613             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2614             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2615             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2616           enddo
2617 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2618 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2619 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2620         enddo
2621         do k=1,3
2622           dc_norm(k,i)=erij(k)
2623         enddo
2624 cd        do k=1,3
2625 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2626 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2627 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2628 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2629 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2630 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2631 cd          write (iout,'(a)')
2632 cd        enddo
2633       enddo
2634       return
2635       end
2636 C--------------------------------------------------------------------------
2637       subroutine set_matrices
2638       implicit real*8 (a-h,o-z)
2639       include 'DIMENSIONS'
2640 #ifdef MPI
2641       include "mpif.h"
2642       include "COMMON.SETUP"
2643       integer IERR
2644       integer status(MPI_STATUS_SIZE)
2645 #endif
2646       include 'COMMON.IOUNITS'
2647       include 'COMMON.GEO'
2648       include 'COMMON.VAR'
2649       include 'COMMON.LOCAL'
2650       include 'COMMON.CHAIN'
2651       include 'COMMON.DERIV'
2652       include 'COMMON.INTERACT'
2653       include 'COMMON.CONTACTS'
2654       include 'COMMON.TORSION'
2655       include 'COMMON.VECTORS'
2656       include 'COMMON.FFIELD'
2657       double precision auxvec(2),auxmat(2,2)
2658 C
2659 C Compute the virtual-bond-torsional-angle dependent quantities needed
2660 C to calculate the el-loc multibody terms of various order.
2661 C
2662 c      write(iout,*) 'nphi=',nphi,nres
2663 #ifdef PARMAT
2664       do i=ivec_start+2,ivec_end+2
2665 #else
2666       do i=3,nres+1
2667 #endif
2668 #ifdef NEWCORR
2669         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2670           iti = itortyp(itype(i-2))
2671         else
2672           iti=ntortyp+1
2673         endif
2674 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2675         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2676           iti1 = itortyp(itype(i-1))
2677         else
2678           iti1=ntortyp+1
2679         endif
2680 c        write(iout,*),i
2681         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2682      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2683      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2684         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2685      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2686      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2687 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2688 c     &*(cos(theta(i)/2.0)
2689         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2690      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2691      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2692 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2693 c     &*(cos(theta(i)/2.0)
2694         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2695      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2696      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2697 c        if (ggb1(1,i).eq.0.0d0) then
2698 c        write(iout,*) 'i=',i,ggb1(1,i),
2699 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2700 c     &bnew1(2,1,iti)*cos(theta(i)),
2701 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2702 c        endif
2703         b1(2,i-2)=bnew1(1,2,iti)
2704         gtb1(2,i-2)=0.0
2705         b2(2,i-2)=bnew2(1,2,iti)
2706         gtb2(2,i-2)=0.0
2707         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2708         EE(1,2,i-2)=eeold(1,2,iti)
2709         EE(2,1,i-2)=eeold(2,1,iti)
2710         EE(2,2,i-2)=eeold(2,2,iti)
2711         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2712         gtEE(1,2,i-2)=0.0d0
2713         gtEE(2,2,i-2)=0.0d0
2714         gtEE(2,1,i-2)=0.0d0
2715 c        EE(2,2,iti)=0.0d0
2716 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2717 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2718 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2719 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2720        b1tilde(1,i-2)=b1(1,i-2)
2721        b1tilde(2,i-2)=-b1(2,i-2)
2722        b2tilde(1,i-2)=b2(1,i-2)
2723        b2tilde(2,i-2)=-b2(2,i-2)
2724 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2725 c       write(iout,*)  'b1=',b1(1,i-2)
2726 c       write (iout,*) 'theta=', theta(i-1)
2727        enddo
2728 #else
2729         b1(1,i-2)=b(3,iti)
2730         b1(2,i-2)=b(5,iti)
2731         b2(1,i-2)=b(2,iti)
2732         b2(2,i-2)=b(4,iti)
2733        b1tilde(1,i-2)=b1(1,i-2)
2734        b1tilde(2,i-2)=-b1(2,i-2)
2735        b2tilde(1,i-2)=b2(1,i-2)
2736        b2tilde(2,i-2)=-b2(2,i-2)
2737         EE(1,2,i-2)=eeold(1,2,iti)
2738         EE(2,1,i-2)=eeold(2,1,iti)
2739         EE(2,2,i-2)=eeold(2,2,iti)
2740         EE(1,1,i-2)=eeold(1,1,iti)
2741       enddo
2742 #endif
2743 #ifdef PARMAT
2744       do i=ivec_start+2,ivec_end+2
2745 #else
2746       do i=3,nres+1
2747 #endif
2748         if (i .lt. nres+1) then
2749           sin1=dsin(phi(i))
2750           cos1=dcos(phi(i))
2751           sintab(i-2)=sin1
2752           costab(i-2)=cos1
2753           obrot(1,i-2)=cos1
2754           obrot(2,i-2)=sin1
2755           sin2=dsin(2*phi(i))
2756           cos2=dcos(2*phi(i))
2757           sintab2(i-2)=sin2
2758           costab2(i-2)=cos2
2759           obrot2(1,i-2)=cos2
2760           obrot2(2,i-2)=sin2
2761           Ug(1,1,i-2)=-cos1
2762           Ug(1,2,i-2)=-sin1
2763           Ug(2,1,i-2)=-sin1
2764           Ug(2,2,i-2)= cos1
2765           Ug2(1,1,i-2)=-cos2
2766           Ug2(1,2,i-2)=-sin2
2767           Ug2(2,1,i-2)=-sin2
2768           Ug2(2,2,i-2)= cos2
2769         else
2770           costab(i-2)=1.0d0
2771           sintab(i-2)=0.0d0
2772           obrot(1,i-2)=1.0d0
2773           obrot(2,i-2)=0.0d0
2774           obrot2(1,i-2)=0.0d0
2775           obrot2(2,i-2)=0.0d0
2776           Ug(1,1,i-2)=1.0d0
2777           Ug(1,2,i-2)=0.0d0
2778           Ug(2,1,i-2)=0.0d0
2779           Ug(2,2,i-2)=1.0d0
2780           Ug2(1,1,i-2)=0.0d0
2781           Ug2(1,2,i-2)=0.0d0
2782           Ug2(2,1,i-2)=0.0d0
2783           Ug2(2,2,i-2)=0.0d0
2784         endif
2785         if (i .gt. 3 .and. i .lt. nres+1) then
2786           obrot_der(1,i-2)=-sin1
2787           obrot_der(2,i-2)= cos1
2788           Ugder(1,1,i-2)= sin1
2789           Ugder(1,2,i-2)=-cos1
2790           Ugder(2,1,i-2)=-cos1
2791           Ugder(2,2,i-2)=-sin1
2792           dwacos2=cos2+cos2
2793           dwasin2=sin2+sin2
2794           obrot2_der(1,i-2)=-dwasin2
2795           obrot2_der(2,i-2)= dwacos2
2796           Ug2der(1,1,i-2)= dwasin2
2797           Ug2der(1,2,i-2)=-dwacos2
2798           Ug2der(2,1,i-2)=-dwacos2
2799           Ug2der(2,2,i-2)=-dwasin2
2800         else
2801           obrot_der(1,i-2)=0.0d0
2802           obrot_der(2,i-2)=0.0d0
2803           Ugder(1,1,i-2)=0.0d0
2804           Ugder(1,2,i-2)=0.0d0
2805           Ugder(2,1,i-2)=0.0d0
2806           Ugder(2,2,i-2)=0.0d0
2807           obrot2_der(1,i-2)=0.0d0
2808           obrot2_der(2,i-2)=0.0d0
2809           Ug2der(1,1,i-2)=0.0d0
2810           Ug2der(1,2,i-2)=0.0d0
2811           Ug2der(2,1,i-2)=0.0d0
2812           Ug2der(2,2,i-2)=0.0d0
2813         endif
2814 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2815         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2816           iti = itortyp(itype(i-2))
2817         else
2818           iti=ntortyp
2819         endif
2820 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2821         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2822           iti1 = itortyp(itype(i-1))
2823         else
2824           iti1=ntortyp
2825         endif
2826 cd        write (iout,*) '*******i',i,' iti1',iti
2827 cd        write (iout,*) 'b1',b1(:,iti)
2828 cd        write (iout,*) 'b2',b2(:,iti)
2829 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2830 c        if (i .gt. iatel_s+2) then
2831         if (i .gt. nnt+2) then
2832           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2833 #ifdef NEWCORR
2834           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2835 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2836 #endif
2837 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2838 c     &    EE(1,2,iti),EE(2,2,iti)
2839           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2840           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2841 c          write(iout,*) "Macierz EUG",
2842 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2843 c     &    eug(2,2,i-2)
2844           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2845      &    then
2846           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2847           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2848           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2849           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2850           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2851           endif
2852         else
2853           do k=1,2
2854             Ub2(k,i-2)=0.0d0
2855             Ctobr(k,i-2)=0.0d0
2856             Dtobr2(k,i-2)=0.0d0
2857             do l=1,2
2858               EUg(l,k,i-2)=0.0d0
2859               CUg(l,k,i-2)=0.0d0
2860               DUg(l,k,i-2)=0.0d0
2861               DtUg2(l,k,i-2)=0.0d0
2862             enddo
2863           enddo
2864         endif
2865         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2866         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2867         do k=1,2
2868           muder(k,i-2)=Ub2der(k,i-2)
2869         enddo
2870 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2871         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2872           if (itype(i-1).le.ntyp) then
2873             iti1 = itortyp(itype(i-1))
2874           else
2875             iti1=ntortyp
2876           endif
2877         else
2878           iti1=ntortyp
2879         endif
2880         do k=1,2
2881           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2882         enddo
2883 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2884 cd        write (iout,*) 'mu1',mu1(:,i-2)
2885 cd        write (iout,*) 'mu2',mu2(:,i-2)
2886         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2887      &  then
2888         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2889         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2890         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2891         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2892         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2893 C Vectors and matrices dependent on a single virtual-bond dihedral.
2894         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2895         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2896         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2897         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2898         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2899         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2900         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2901         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2902         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2903         endif
2904       enddo
2905 C Matrices dependent on two consecutive virtual-bond dihedrals.
2906 C The order of matrices is from left to right.
2907       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2908      &then
2909 c      do i=max0(ivec_start,2),ivec_end
2910       do i=2,nres-1
2911         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2912         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2913         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2914         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2915         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2916         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2917         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2918         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2919       enddo
2920       endif
2921 #if defined(MPI) && defined(PARMAT)
2922 #ifdef DEBUG
2923 c      if (fg_rank.eq.0) then
2924         write (iout,*) "Arrays UG and UGDER before GATHER"
2925         do i=1,nres-1
2926           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2927      &     ((ug(l,k,i),l=1,2),k=1,2),
2928      &     ((ugder(l,k,i),l=1,2),k=1,2)
2929         enddo
2930         write (iout,*) "Arrays UG2 and UG2DER"
2931         do i=1,nres-1
2932           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2933      &     ((ug2(l,k,i),l=1,2),k=1,2),
2934      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2935         enddo
2936         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2937         do i=1,nres-1
2938           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2939      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2940      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2941         enddo
2942         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2943         do i=1,nres-1
2944           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2945      &     costab(i),sintab(i),costab2(i),sintab2(i)
2946         enddo
2947         write (iout,*) "Array MUDER"
2948         do i=1,nres-1
2949           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2950         enddo
2951 c      endif
2952 #endif
2953       if (nfgtasks.gt.1) then
2954         time00=MPI_Wtime()
2955 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2956 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2957 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2958 #ifdef MATGATHER
2959         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2960      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2961      &   FG_COMM1,IERR)
2962         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2963      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2964      &   FG_COMM1,IERR)
2965         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2966      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2967      &   FG_COMM1,IERR)
2968         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2969      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2970      &   FG_COMM1,IERR)
2971         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2972      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2973      &   FG_COMM1,IERR)
2974         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2975      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2976      &   FG_COMM1,IERR)
2977         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2978      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2979      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2980         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2981      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2982      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2983         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2984      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2985      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2986         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2987      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2988      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2989         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2990      &  then
2991         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2992      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2993      &   FG_COMM1,IERR)
2994         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2995      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2996      &   FG_COMM1,IERR)
2997         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2998      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2999      &   FG_COMM1,IERR)
3000        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3001      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3002      &   FG_COMM1,IERR)
3003         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3004      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3005      &   FG_COMM1,IERR)
3006         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3007      &   ivec_count(fg_rank1),
3008      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3009      &   FG_COMM1,IERR)
3010         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3011      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3012      &   FG_COMM1,IERR)
3013         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3014      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3015      &   FG_COMM1,IERR)
3016         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3017      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3018      &   FG_COMM1,IERR)
3019         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3020      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3021      &   FG_COMM1,IERR)
3022         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3023      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3024      &   FG_COMM1,IERR)
3025         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3026      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3030      &   FG_COMM1,IERR)
3031         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3032      &   ivec_count(fg_rank1),
3033      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3034      &   FG_COMM1,IERR)
3035         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3036      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3037      &   FG_COMM1,IERR)
3038        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3039      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3040      &   FG_COMM1,IERR)
3041         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3042      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3043      &   FG_COMM1,IERR)
3044        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3045      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3046      &   FG_COMM1,IERR)
3047         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3048      &   ivec_count(fg_rank1),
3049      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3050      &   FG_COMM1,IERR)
3051         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3052      &   ivec_count(fg_rank1),
3053      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3054      &   FG_COMM1,IERR)
3055         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3056      &   ivec_count(fg_rank1),
3057      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3058      &   MPI_MAT2,FG_COMM1,IERR)
3059         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3060      &   ivec_count(fg_rank1),
3061      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3062      &   MPI_MAT2,FG_COMM1,IERR)
3063         endif
3064 #else
3065 c Passes matrix info through the ring
3066       isend=fg_rank1
3067       irecv=fg_rank1-1
3068       if (irecv.lt.0) irecv=nfgtasks1-1
3069       iprev=irecv
3070       inext=fg_rank1+1
3071       if (inext.ge.nfgtasks1) inext=0
3072       do i=1,nfgtasks1-1
3073 c        write (iout,*) "isend",isend," irecv",irecv
3074 c        call flush(iout)
3075         lensend=lentyp(isend)
3076         lenrecv=lentyp(irecv)
3077 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3078 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3079 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3080 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3081 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3082 c        write (iout,*) "Gather ROTAT1"
3083 c        call flush(iout)
3084 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3085 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3086 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3087 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3088 c        write (iout,*) "Gather ROTAT2"
3089 c        call flush(iout)
3090         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3091      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3092      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3093      &   iprev,4400+irecv,FG_COMM,status,IERR)
3094 c        write (iout,*) "Gather ROTAT_OLD"
3095 c        call flush(iout)
3096         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3097      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3098      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3099      &   iprev,5500+irecv,FG_COMM,status,IERR)
3100 c        write (iout,*) "Gather PRECOMP11"
3101 c        call flush(iout)
3102         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3103      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3104      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3105      &   iprev,6600+irecv,FG_COMM,status,IERR)
3106 c        write (iout,*) "Gather PRECOMP12"
3107 c        call flush(iout)
3108         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3109      &  then
3110         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3111      &   MPI_ROTAT2(lensend),inext,7700+isend,
3112      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3113      &   iprev,7700+irecv,FG_COMM,status,IERR)
3114 c        write (iout,*) "Gather PRECOMP21"
3115 c        call flush(iout)
3116         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3117      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3118      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3119      &   iprev,8800+irecv,FG_COMM,status,IERR)
3120 c        write (iout,*) "Gather PRECOMP22"
3121 c        call flush(iout)
3122         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3123      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3124      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3125      &   MPI_PRECOMP23(lenrecv),
3126      &   iprev,9900+irecv,FG_COMM,status,IERR)
3127 c        write (iout,*) "Gather PRECOMP23"
3128 c        call flush(iout)
3129         endif
3130         isend=irecv
3131         irecv=irecv-1
3132         if (irecv.lt.0) irecv=nfgtasks1-1
3133       enddo
3134 #endif
3135         time_gather=time_gather+MPI_Wtime()-time00
3136       endif
3137 #ifdef DEBUG
3138 c      if (fg_rank.eq.0) then
3139         write (iout,*) "Arrays UG and UGDER"
3140         do i=1,nres-1
3141           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3142      &     ((ug(l,k,i),l=1,2),k=1,2),
3143      &     ((ugder(l,k,i),l=1,2),k=1,2)
3144         enddo
3145         write (iout,*) "Arrays UG2 and UG2DER"
3146         do i=1,nres-1
3147           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3148      &     ((ug2(l,k,i),l=1,2),k=1,2),
3149      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3150         enddo
3151         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3152         do i=1,nres-1
3153           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3154      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3155      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3156         enddo
3157         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3158         do i=1,nres-1
3159           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3160      &     costab(i),sintab(i),costab2(i),sintab2(i)
3161         enddo
3162         write (iout,*) "Array MUDER"
3163         do i=1,nres-1
3164           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3165         enddo
3166 c      endif
3167 #endif
3168 #endif
3169 cd      do i=1,nres
3170 cd        iti = itortyp(itype(i))
3171 cd        write (iout,*) i
3172 cd        do j=1,2
3173 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3174 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3175 cd        enddo
3176 cd      enddo
3177       return
3178       end
3179 C--------------------------------------------------------------------------
3180       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3181 C
3182 C This subroutine calculates the average interaction energy and its gradient
3183 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3184 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3185 C The potential depends both on the distance of peptide-group centers and on
3186 C the orientation of the CA-CA virtual bonds.
3187 C
3188       implicit real*8 (a-h,o-z)
3189 #ifdef MPI
3190       include 'mpif.h'
3191 #endif
3192       include 'DIMENSIONS'
3193       include 'COMMON.CONTROL'
3194       include 'COMMON.SETUP'
3195       include 'COMMON.IOUNITS'
3196       include 'COMMON.GEO'
3197       include 'COMMON.VAR'
3198       include 'COMMON.LOCAL'
3199       include 'COMMON.CHAIN'
3200       include 'COMMON.DERIV'
3201       include 'COMMON.INTERACT'
3202       include 'COMMON.CONTACTS'
3203       include 'COMMON.TORSION'
3204       include 'COMMON.VECTORS'
3205       include 'COMMON.FFIELD'
3206       include 'COMMON.TIME1'
3207       include 'COMMON.SPLITELE'
3208       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3209      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3210       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3211      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3212       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3213      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3214      &    num_conti,j1,j2
3215 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3216 #ifdef MOMENT
3217       double precision scal_el /1.0d0/
3218 #else
3219       double precision scal_el /0.5d0/
3220 #endif
3221 C 12/13/98
3222 C 13-go grudnia roku pamietnego...
3223       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3224      &                   0.0d0,1.0d0,0.0d0,
3225      &                   0.0d0,0.0d0,1.0d0/
3226 cd      write(iout,*) 'In EELEC'
3227 cd      do i=1,nloctyp
3228 cd        write(iout,*) 'Type',i
3229 cd        write(iout,*) 'B1',B1(:,i)
3230 cd        write(iout,*) 'B2',B2(:,i)
3231 cd        write(iout,*) 'CC',CC(:,:,i)
3232 cd        write(iout,*) 'DD',DD(:,:,i)
3233 cd        write(iout,*) 'EE',EE(:,:,i)
3234 cd      enddo
3235 cd      call check_vecgrad
3236 cd      stop
3237       if (icheckgrad.eq.1) then
3238         do i=1,nres-1
3239           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3240           do k=1,3
3241             dc_norm(k,i)=dc(k,i)*fac
3242           enddo
3243 c          write (iout,*) 'i',i,' fac',fac
3244         enddo
3245       endif
3246       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3247      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3248      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3249 c        call vec_and_deriv
3250 #ifdef TIMING
3251         time01=MPI_Wtime()
3252 #endif
3253         call set_matrices
3254 #ifdef TIMING
3255         time_mat=time_mat+MPI_Wtime()-time01
3256 #endif
3257       endif
3258 cd      do i=1,nres-1
3259 cd        write (iout,*) 'i=',i
3260 cd        do k=1,3
3261 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3262 cd        enddo
3263 cd        do k=1,3
3264 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3265 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3266 cd        enddo
3267 cd      enddo
3268       t_eelecij=0.0d0
3269       ees=0.0D0
3270       evdw1=0.0D0
3271       eel_loc=0.0d0
3272       eello_turn3=0.0d0
3273       eello_turn4=0.0d0
3274       ind=0
3275       do i=1,nres
3276         num_cont_hb(i)=0
3277       enddo
3278 cd      print '(a)','Enter EELEC'
3279 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3280       do i=1,nres
3281         gel_loc_loc(i)=0.0d0
3282         gcorr_loc(i)=0.0d0
3283       enddo
3284 c
3285 c
3286 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3287 C
3288 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3289 C
3290 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3291       do i=iturn3_start,iturn3_end
3292         if (i.le.1) cycle
3293 C        write(iout,*) "tu jest i",i
3294         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3295 C changes suggested by Ana to avoid out of bounds
3296      & .or.((i+4).gt.nres)
3297      & .or.((i-1).le.0)
3298 C end of changes by Ana
3299      &  .or. itype(i+2).eq.ntyp1
3300      &  .or. itype(i+3).eq.ntyp1) cycle
3301         if(i.gt.1)then
3302           if(itype(i-1).eq.ntyp1)cycle
3303         end if
3304         if(i.LT.nres-3)then
3305           if (itype(i+4).eq.ntyp1) cycle
3306         end if
3307         dxi=dc(1,i)
3308         dyi=dc(2,i)
3309         dzi=dc(3,i)
3310         dx_normi=dc_norm(1,i)
3311         dy_normi=dc_norm(2,i)
3312         dz_normi=dc_norm(3,i)
3313         xmedi=c(1,i)+0.5d0*dxi
3314         ymedi=c(2,i)+0.5d0*dyi
3315         zmedi=c(3,i)+0.5d0*dzi
3316           xmedi=mod(xmedi,boxxsize)
3317           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3318           ymedi=mod(ymedi,boxysize)
3319           if (ymedi.lt.0) ymedi=ymedi+boxysize
3320           zmedi=mod(zmedi,boxzsize)
3321           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3322         num_conti=0
3323         call eelecij(i,i+2,ees,evdw1,eel_loc)
3324         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3325         num_cont_hb(i)=num_conti
3326       enddo
3327       do i=iturn4_start,iturn4_end
3328         if (i.le.1) cycle
3329         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3330 C changes suggested by Ana to avoid out of bounds
3331      & .or.((i+5).gt.nres)
3332      & .or.((i-1).le.0)
3333 C end of changes suggested by Ana
3334      &    .or. itype(i+3).eq.ntyp1
3335      &    .or. itype(i+4).eq.ntyp1
3336      &    .or. itype(i+5).eq.ntyp1
3337      &    .or. itype(i).eq.ntyp1
3338      &    .or. itype(i-1).eq.ntyp1
3339      &                             ) cycle
3340         dxi=dc(1,i)
3341         dyi=dc(2,i)
3342         dzi=dc(3,i)
3343         dx_normi=dc_norm(1,i)
3344         dy_normi=dc_norm(2,i)
3345         dz_normi=dc_norm(3,i)
3346         xmedi=c(1,i)+0.5d0*dxi
3347         ymedi=c(2,i)+0.5d0*dyi
3348         zmedi=c(3,i)+0.5d0*dzi
3349 C Return atom into box, boxxsize is size of box in x dimension
3350 c  194   continue
3351 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3352 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3353 C Condition for being inside the proper box
3354 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3355 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3356 c        go to 194
3357 c        endif
3358 c  195   continue
3359 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3360 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3361 C Condition for being inside the proper box
3362 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3363 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3364 c        go to 195
3365 c        endif
3366 c  196   continue
3367 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3368 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3369 C Condition for being inside the proper box
3370 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3371 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3372 c        go to 196
3373 c        endif
3374           xmedi=mod(xmedi,boxxsize)
3375           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3376           ymedi=mod(ymedi,boxysize)
3377           if (ymedi.lt.0) ymedi=ymedi+boxysize
3378           zmedi=mod(zmedi,boxzsize)
3379           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3380
3381         num_conti=num_cont_hb(i)
3382 c        write(iout,*) "JESTEM W PETLI"
3383         call eelecij(i,i+3,ees,evdw1,eel_loc)
3384         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3385      &   call eturn4(i,eello_turn4)
3386         num_cont_hb(i)=num_conti
3387       enddo   ! i
3388 C Loop over all neighbouring boxes
3389 C      do xshift=-1,1
3390 C      do yshift=-1,1
3391 C      do zshift=-1,1
3392 c
3393 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3394 c
3395       do i=iatel_s,iatel_e
3396         if (i.le.1) cycle
3397         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3398 C changes suggested by Ana to avoid out of bounds
3399      & .or.((i+2).gt.nres)
3400      & .or.((i-1).le.0)
3401 C end of changes by Ana
3402      &  .or. itype(i+2).eq.ntyp1
3403      &  .or. itype(i-1).eq.ntyp1
3404      &                ) cycle
3405         dxi=dc(1,i)
3406         dyi=dc(2,i)
3407         dzi=dc(3,i)
3408         dx_normi=dc_norm(1,i)
3409         dy_normi=dc_norm(2,i)
3410         dz_normi=dc_norm(3,i)
3411         xmedi=c(1,i)+0.5d0*dxi
3412         ymedi=c(2,i)+0.5d0*dyi
3413         zmedi=c(3,i)+0.5d0*dzi
3414           xmedi=mod(xmedi,boxxsize)
3415           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3416           ymedi=mod(ymedi,boxysize)
3417           if (ymedi.lt.0) ymedi=ymedi+boxysize
3418           zmedi=mod(zmedi,boxzsize)
3419           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3420 C          xmedi=xmedi+xshift*boxxsize
3421 C          ymedi=ymedi+yshift*boxysize
3422 C          zmedi=zmedi+zshift*boxzsize
3423
3424 C Return tom into box, boxxsize is size of box in x dimension
3425 c  164   continue
3426 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3427 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3428 C Condition for being inside the proper box
3429 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3430 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3431 c        go to 164
3432 c        endif
3433 c  165   continue
3434 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3435 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3436 C Condition for being inside the proper box
3437 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3438 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3439 c        go to 165
3440 c        endif
3441 c  166   continue
3442 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3443 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3444 cC Condition for being inside the proper box
3445 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3446 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3447 c        go to 166
3448 c        endif
3449
3450 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3451         num_conti=num_cont_hb(i)
3452         do j=ielstart(i),ielend(i)
3453 C          write (iout,*) i,j
3454          if (j.le.1) cycle
3455           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3456 C changes suggested by Ana to avoid out of bounds
3457      & .or.((j+2).gt.nres)
3458      & .or.((j-1).le.0)
3459 C end of changes by Ana
3460      & .or.itype(j+2).eq.ntyp1
3461      & .or.itype(j-1).eq.ntyp1
3462      &) cycle
3463           call eelecij(i,j,ees,evdw1,eel_loc)
3464         enddo ! j
3465         num_cont_hb(i)=num_conti
3466       enddo   ! i
3467 C     enddo   ! zshift
3468 C      enddo   ! yshift
3469 C      enddo   ! xshift
3470
3471 c      write (iout,*) "Number of loop steps in EELEC:",ind
3472 cd      do i=1,nres
3473 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3474 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3475 cd      enddo
3476 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3477 ccc      eel_loc=eel_loc+eello_turn3
3478 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3479       return
3480       end
3481 C-------------------------------------------------------------------------------
3482       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3483       implicit real*8 (a-h,o-z)
3484       include 'DIMENSIONS'
3485 #ifdef MPI
3486       include "mpif.h"
3487 #endif
3488       include 'COMMON.CONTROL'
3489       include 'COMMON.IOUNITS'
3490       include 'COMMON.GEO'
3491       include 'COMMON.VAR'
3492       include 'COMMON.LOCAL'
3493       include 'COMMON.CHAIN'
3494       include 'COMMON.DERIV'
3495       include 'COMMON.INTERACT'
3496       include 'COMMON.CONTACTS'
3497       include 'COMMON.TORSION'
3498       include 'COMMON.VECTORS'
3499       include 'COMMON.FFIELD'
3500       include 'COMMON.TIME1'
3501       include 'COMMON.SPLITELE'
3502       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3503      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3504       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3505      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3506      &    gmuij2(4),gmuji2(4)
3507       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3508      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3509      &    num_conti,j1,j2
3510 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3511 #ifdef MOMENT
3512       double precision scal_el /1.0d0/
3513 #else
3514       double precision scal_el /0.5d0/
3515 #endif
3516 C 12/13/98
3517 C 13-go grudnia roku pamietnego...
3518       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3519      &                   0.0d0,1.0d0,0.0d0,
3520      &                   0.0d0,0.0d0,1.0d0/
3521 c          time00=MPI_Wtime()
3522 cd      write (iout,*) "eelecij",i,j
3523 c          ind=ind+1
3524           iteli=itel(i)
3525           itelj=itel(j)
3526           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3527           aaa=app(iteli,itelj)
3528           bbb=bpp(iteli,itelj)
3529           ael6i=ael6(iteli,itelj)
3530           ael3i=ael3(iteli,itelj)
3531           dxj=dc(1,j)
3532           dyj=dc(2,j)
3533           dzj=dc(3,j)
3534           dx_normj=dc_norm(1,j)
3535           dy_normj=dc_norm(2,j)
3536           dz_normj=dc_norm(3,j)
3537 C          xj=c(1,j)+0.5D0*dxj-xmedi
3538 C          yj=c(2,j)+0.5D0*dyj-ymedi
3539 C          zj=c(3,j)+0.5D0*dzj-zmedi
3540           xj=c(1,j)+0.5D0*dxj
3541           yj=c(2,j)+0.5D0*dyj
3542           zj=c(3,j)+0.5D0*dzj
3543           xj=mod(xj,boxxsize)
3544           if (xj.lt.0) xj=xj+boxxsize
3545           yj=mod(yj,boxysize)
3546           if (yj.lt.0) yj=yj+boxysize
3547           zj=mod(zj,boxzsize)
3548           if (zj.lt.0) zj=zj+boxzsize
3549           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3550       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3551       xj_safe=xj
3552       yj_safe=yj
3553       zj_safe=zj
3554       isubchap=0
3555       do xshift=-1,1
3556       do yshift=-1,1
3557       do zshift=-1,1
3558           xj=xj_safe+xshift*boxxsize
3559           yj=yj_safe+yshift*boxysize
3560           zj=zj_safe+zshift*boxzsize
3561           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3562           if(dist_temp.lt.dist_init) then
3563             dist_init=dist_temp
3564             xj_temp=xj
3565             yj_temp=yj
3566             zj_temp=zj
3567             isubchap=1
3568           endif
3569        enddo
3570        enddo
3571        enddo
3572        if (isubchap.eq.1) then
3573           xj=xj_temp-xmedi
3574           yj=yj_temp-ymedi
3575           zj=zj_temp-zmedi
3576        else
3577           xj=xj_safe-xmedi
3578           yj=yj_safe-ymedi
3579           zj=zj_safe-zmedi
3580        endif
3581 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3582 c  174   continue
3583 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3584 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3585 C Condition for being inside the proper box
3586 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3587 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3588 c        go to 174
3589 c        endif
3590 c  175   continue
3591 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3592 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3593 C Condition for being inside the proper box
3594 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3595 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3596 c        go to 175
3597 c        endif
3598 c  176   continue
3599 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3600 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3601 C Condition for being inside the proper box
3602 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3603 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3604 c        go to 176
3605 c        endif
3606 C        endif !endPBC condintion
3607 C        xj=xj-xmedi
3608 C        yj=yj-ymedi
3609 C        zj=zj-zmedi
3610           rij=xj*xj+yj*yj+zj*zj
3611
3612             sss=sscale(sqrt(rij))
3613             sssgrad=sscagrad(sqrt(rij))
3614 c            if (sss.gt.0.0d0) then
3615           rrmij=1.0D0/rij
3616           rij=dsqrt(rij)
3617           rmij=1.0D0/rij
3618           r3ij=rrmij*rmij
3619           r6ij=r3ij*r3ij
3620           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3621           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3622           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3623           fac=cosa-3.0D0*cosb*cosg
3624           ev1=aaa*r6ij*r6ij
3625 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3626           if (j.eq.i+2) ev1=scal_el*ev1
3627           ev2=bbb*r6ij
3628           fac3=ael6i*r6ij
3629           fac4=ael3i*r3ij
3630           evdwij=(ev1+ev2)
3631           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3632           el2=fac4*fac
3633 C MARYSIA
3634           eesij=(el1+el2)
3635 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3636           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3637           ees=ees+eesij
3638           evdw1=evdw1+evdwij*sss
3639 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3640 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3641 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3642 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3643
3644           if (energy_dec) then
3645               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3646      &'evdw1',i,j,evdwij
3647      &,iteli,itelj,aaa,evdw1
3648               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3649           endif
3650
3651 C
3652 C Calculate contributions to the Cartesian gradient.
3653 C
3654 #ifdef SPLITELE
3655           facvdw=-6*rrmij*(ev1+evdwij)*sss
3656           facel=-3*rrmij*(el1+eesij)
3657           fac1=fac
3658           erij(1)=xj*rmij
3659           erij(2)=yj*rmij
3660           erij(3)=zj*rmij
3661 *
3662 * Radial derivatives. First process both termini of the fragment (i,j)
3663 *
3664           ggg(1)=facel*xj
3665           ggg(2)=facel*yj
3666           ggg(3)=facel*zj
3667 c          do k=1,3
3668 c            ghalf=0.5D0*ggg(k)
3669 c            gelc(k,i)=gelc(k,i)+ghalf
3670 c            gelc(k,j)=gelc(k,j)+ghalf
3671 c          enddo
3672 c 9/28/08 AL Gradient compotents will be summed only at the end
3673           do k=1,3
3674             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3675             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3676           enddo
3677 *
3678 * Loop over residues i+1 thru j-1.
3679 *
3680 cgrad          do k=i+1,j-1
3681 cgrad            do l=1,3
3682 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3683 cgrad            enddo
3684 cgrad          enddo
3685           if (sss.gt.0.0) then
3686           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3687           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3688           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3689           else
3690           ggg(1)=0.0
3691           ggg(2)=0.0
3692           ggg(3)=0.0
3693           endif
3694 c          do k=1,3
3695 c            ghalf=0.5D0*ggg(k)
3696 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3697 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3698 c          enddo
3699 c 9/28/08 AL Gradient compotents will be summed only at the end
3700           do k=1,3
3701             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3702             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3703           enddo
3704 *
3705 * Loop over residues i+1 thru j-1.
3706 *
3707 cgrad          do k=i+1,j-1
3708 cgrad            do l=1,3
3709 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3710 cgrad            enddo
3711 cgrad          enddo
3712 #else
3713 C MARYSIA
3714           facvdw=(ev1+evdwij)*sss
3715           facel=(el1+eesij)
3716           fac1=fac
3717           fac=-3*rrmij*(facvdw+facvdw+facel)
3718           erij(1)=xj*rmij
3719           erij(2)=yj*rmij
3720           erij(3)=zj*rmij
3721 *
3722 * Radial derivatives. First process both termini of the fragment (i,j)
3723 *
3724           ggg(1)=fac*xj
3725           ggg(2)=fac*yj
3726           ggg(3)=fac*zj
3727 c          do k=1,3
3728 c            ghalf=0.5D0*ggg(k)
3729 c            gelc(k,i)=gelc(k,i)+ghalf
3730 c            gelc(k,j)=gelc(k,j)+ghalf
3731 c          enddo
3732 c 9/28/08 AL Gradient compotents will be summed only at the end
3733           do k=1,3
3734             gelc_long(k,j)=gelc(k,j)+ggg(k)
3735             gelc_long(k,i)=gelc(k,i)-ggg(k)
3736           enddo
3737 *
3738 * Loop over residues i+1 thru j-1.
3739 *
3740 cgrad          do k=i+1,j-1
3741 cgrad            do l=1,3
3742 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3743 cgrad            enddo
3744 cgrad          enddo
3745 c 9/28/08 AL Gradient compotents will be summed only at the end
3746           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3747           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3748           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3749           do k=1,3
3750             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3751             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3752           enddo
3753 #endif
3754 *
3755 * Angular part
3756 *
3757           ecosa=2.0D0*fac3*fac1+fac4
3758           fac4=-3.0D0*fac4
3759           fac3=-6.0D0*fac3
3760           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3761           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3762           do k=1,3
3763             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3764             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3765           enddo
3766 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3767 cd   &          (dcosg(k),k=1,3)
3768           do k=1,3
3769             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3770           enddo
3771 c          do k=1,3
3772 c            ghalf=0.5D0*ggg(k)
3773 c            gelc(k,i)=gelc(k,i)+ghalf
3774 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3775 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3776 c            gelc(k,j)=gelc(k,j)+ghalf
3777 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3778 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3779 c          enddo
3780 cgrad          do k=i+1,j-1
3781 cgrad            do l=1,3
3782 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3783 cgrad            enddo
3784 cgrad          enddo
3785           do k=1,3
3786             gelc(k,i)=gelc(k,i)
3787      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3788      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3789             gelc(k,j)=gelc(k,j)
3790      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3791      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3792             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3793             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3794           enddo
3795 C MARYSIA
3796 c          endif !sscale
3797           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3798      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3799      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3800 C
3801 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3802 C   energy of a peptide unit is assumed in the form of a second-order
3803 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3804 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3805 C   are computed for EVERY pair of non-contiguous peptide groups.
3806 C
3807
3808           if (j.lt.nres-1) then
3809             j1=j+1
3810             j2=j-1
3811           else
3812             j1=j-1
3813             j2=j-2
3814           endif
3815           kkk=0
3816           lll=0
3817           do k=1,2
3818             do l=1,2
3819               kkk=kkk+1
3820               muij(kkk)=mu(k,i)*mu(l,j)
3821 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3822 #ifdef NEWCORR
3823              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3824 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3825              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3826              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3827 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3828              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3829 #endif
3830             enddo
3831           enddo
3832 cd         write (iout,*) 'EELEC: i',i,' j',j
3833 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3834 cd          write(iout,*) 'muij',muij
3835           ury=scalar(uy(1,i),erij)
3836           urz=scalar(uz(1,i),erij)
3837           vry=scalar(uy(1,j),erij)
3838           vrz=scalar(uz(1,j),erij)
3839           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3840           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3841           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3842           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3843           fac=dsqrt(-ael6i)*r3ij
3844           a22=a22*fac
3845           a23=a23*fac
3846           a32=a32*fac
3847           a33=a33*fac
3848 cd          write (iout,'(4i5,4f10.5)')
3849 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3850 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3851 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3852 cd     &      uy(:,j),uz(:,j)
3853 cd          write (iout,'(4f10.5)')
3854 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3855 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3856 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3857 cd           write (iout,'(9f10.5/)')
3858 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3859 C Derivatives of the elements of A in virtual-bond vectors
3860           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3861           do k=1,3
3862             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3863             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3864             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3865             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3866             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3867             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3868             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3869             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3870             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3871             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3872             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3873             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3874           enddo
3875 C Compute radial contributions to the gradient
3876           facr=-3.0d0*rrmij
3877           a22der=a22*facr
3878           a23der=a23*facr
3879           a32der=a32*facr
3880           a33der=a33*facr
3881           agg(1,1)=a22der*xj
3882           agg(2,1)=a22der*yj
3883           agg(3,1)=a22der*zj
3884           agg(1,2)=a23der*xj
3885           agg(2,2)=a23der*yj
3886           agg(3,2)=a23der*zj
3887           agg(1,3)=a32der*xj
3888           agg(2,3)=a32der*yj
3889           agg(3,3)=a32der*zj
3890           agg(1,4)=a33der*xj
3891           agg(2,4)=a33der*yj
3892           agg(3,4)=a33der*zj
3893 C Add the contributions coming from er
3894           fac3=-3.0d0*fac
3895           do k=1,3
3896             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3897             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3898             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3899             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3900           enddo
3901           do k=1,3
3902 C Derivatives in DC(i)
3903 cgrad            ghalf1=0.5d0*agg(k,1)
3904 cgrad            ghalf2=0.5d0*agg(k,2)
3905 cgrad            ghalf3=0.5d0*agg(k,3)
3906 cgrad            ghalf4=0.5d0*agg(k,4)
3907             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3908      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3909             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3910      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3911             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3912      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3913             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3914      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3915 C Derivatives in DC(i+1)
3916             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3917      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3918             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3919      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3920             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3921      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3922             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3923      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3924 C Derivatives in DC(j)
3925             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3926      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3927             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3928      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3929             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3930      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3931             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3932      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3933 C Derivatives in DC(j+1) or DC(nres-1)
3934             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3935      &      -3.0d0*vryg(k,3)*ury)
3936             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3937      &      -3.0d0*vrzg(k,3)*ury)
3938             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3939      &      -3.0d0*vryg(k,3)*urz)
3940             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3941      &      -3.0d0*vrzg(k,3)*urz)
3942 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3943 cgrad              do l=1,4
3944 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3945 cgrad              enddo
3946 cgrad            endif
3947           enddo
3948           acipa(1,1)=a22
3949           acipa(1,2)=a23
3950           acipa(2,1)=a32
3951           acipa(2,2)=a33
3952           a22=-a22
3953           a23=-a23
3954           do l=1,2
3955             do k=1,3
3956               agg(k,l)=-agg(k,l)
3957               aggi(k,l)=-aggi(k,l)
3958               aggi1(k,l)=-aggi1(k,l)
3959               aggj(k,l)=-aggj(k,l)
3960               aggj1(k,l)=-aggj1(k,l)
3961             enddo
3962           enddo
3963           if (j.lt.nres-1) then
3964             a22=-a22
3965             a32=-a32
3966             do l=1,3,2
3967               do k=1,3
3968                 agg(k,l)=-agg(k,l)
3969                 aggi(k,l)=-aggi(k,l)
3970                 aggi1(k,l)=-aggi1(k,l)
3971                 aggj(k,l)=-aggj(k,l)
3972                 aggj1(k,l)=-aggj1(k,l)
3973               enddo
3974             enddo
3975           else
3976             a22=-a22
3977             a23=-a23
3978             a32=-a32
3979             a33=-a33
3980             do l=1,4
3981               do k=1,3
3982                 agg(k,l)=-agg(k,l)
3983                 aggi(k,l)=-aggi(k,l)
3984                 aggi1(k,l)=-aggi1(k,l)
3985                 aggj(k,l)=-aggj(k,l)
3986                 aggj1(k,l)=-aggj1(k,l)
3987               enddo
3988             enddo
3989           endif
3990           ENDIF ! WCORR
3991           IF (wel_loc.gt.0.0d0) THEN
3992 C Contribution to the local-electrostatic energy coming from the i-j pair
3993           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3994      &     +a33*muij(4)
3995 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3996 c     &                     ' eel_loc_ij',eel_loc_ij
3997 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3998 C Calculate patrial derivative for theta angle
3999 #ifdef NEWCORR
4000          geel_loc_ij=a22*gmuij1(1)
4001      &     +a23*gmuij1(2)
4002      &     +a32*gmuij1(3)
4003      &     +a33*gmuij1(4)
4004 c         write(iout,*) "derivative over thatai"
4005 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4006 c     &   a33*gmuij1(4)
4007          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4008      &      geel_loc_ij*wel_loc
4009 c         write(iout,*) "derivative over thatai-1"
4010 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4011 c     &   a33*gmuij2(4)
4012          geel_loc_ij=
4013      &     a22*gmuij2(1)
4014      &     +a23*gmuij2(2)
4015      &     +a32*gmuij2(3)
4016      &     +a33*gmuij2(4)
4017          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4018      &      geel_loc_ij*wel_loc
4019 c  Derivative over j residue
4020          geel_loc_ji=a22*gmuji1(1)
4021      &     +a23*gmuji1(2)
4022      &     +a32*gmuji1(3)
4023      &     +a33*gmuji1(4)
4024 c         write(iout,*) "derivative over thataj"
4025 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4026 c     &   a33*gmuji1(4)
4027
4028         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4029      &      geel_loc_ji*wel_loc
4030          geel_loc_ji=
4031      &     +a22*gmuji2(1)
4032      &     +a23*gmuji2(2)
4033      &     +a32*gmuji2(3)
4034      &     +a33*gmuji2(4)
4035 c         write(iout,*) "derivative over thataj-1"
4036 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4037 c     &   a33*gmuji2(4)
4038          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4039      &      geel_loc_ji*wel_loc
4040 #endif
4041 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4042
4043           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4044      &            'eelloc',i,j,eel_loc_ij
4045 c           if (eel_loc_ij.ne.0)
4046 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4047 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4048
4049           eel_loc=eel_loc+eel_loc_ij
4050 C Partial derivatives in virtual-bond dihedral angles gamma
4051           if (i.gt.1)
4052      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4053      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4054      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4055           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4056      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4057      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4058 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4059           do l=1,3
4060             ggg(l)=agg(l,1)*muij(1)+
4061      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4062             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4063             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4064 cgrad            ghalf=0.5d0*ggg(l)
4065 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4066 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4067           enddo
4068 cgrad          do k=i+1,j2
4069 cgrad            do l=1,3
4070 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4071 cgrad            enddo
4072 cgrad          enddo
4073 C Remaining derivatives of eello
4074           do l=1,3
4075             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4076      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4077             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4078      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4079             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4080      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4081             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4082      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4083           enddo
4084           ENDIF
4085 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4086 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4087           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4088      &       .and. num_conti.le.maxconts) then
4089 c            write (iout,*) i,j," entered corr"
4090 C
4091 C Calculate the contact function. The ith column of the array JCONT will
4092 C contain the numbers of atoms that make contacts with the atom I (of numbers
4093 C greater than I). The arrays FACONT and GACONT will contain the values of
4094 C the contact function and its derivative.
4095 c           r0ij=1.02D0*rpp(iteli,itelj)
4096 c           r0ij=1.11D0*rpp(iteli,itelj)
4097             r0ij=2.20D0*rpp(iteli,itelj)
4098 c           r0ij=1.55D0*rpp(iteli,itelj)
4099             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4100             if (fcont.gt.0.0D0) then
4101               num_conti=num_conti+1
4102               if (num_conti.gt.maxconts) then
4103                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4104      &                         ' will skip next contacts for this conf.'
4105               else
4106                 jcont_hb(num_conti,i)=j
4107 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4108 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4109                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4110      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4111 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4112 C  terms.
4113                 d_cont(num_conti,i)=rij
4114 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4115 C     --- Electrostatic-interaction matrix ---
4116                 a_chuj(1,1,num_conti,i)=a22
4117                 a_chuj(1,2,num_conti,i)=a23
4118                 a_chuj(2,1,num_conti,i)=a32
4119                 a_chuj(2,2,num_conti,i)=a33
4120 C     --- Gradient of rij
4121                 do kkk=1,3
4122                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4123                 enddo
4124                 kkll=0
4125                 do k=1,2
4126                   do l=1,2
4127                     kkll=kkll+1
4128                     do m=1,3
4129                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4130                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4131                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4132                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4133                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4134                     enddo
4135                   enddo
4136                 enddo
4137                 ENDIF
4138                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4139 C Calculate contact energies
4140                 cosa4=4.0D0*cosa
4141                 wij=cosa-3.0D0*cosb*cosg
4142                 cosbg1=cosb+cosg
4143                 cosbg2=cosb-cosg
4144 c               fac3=dsqrt(-ael6i)/r0ij**3
4145                 fac3=dsqrt(-ael6i)*r3ij
4146 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4147                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4148                 if (ees0tmp.gt.0) then
4149                   ees0pij=dsqrt(ees0tmp)
4150                 else
4151                   ees0pij=0
4152                 endif
4153 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4154                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4155                 if (ees0tmp.gt.0) then
4156                   ees0mij=dsqrt(ees0tmp)
4157                 else
4158                   ees0mij=0
4159                 endif
4160 c               ees0mij=0.0D0
4161                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4162                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4163 C Diagnostics. Comment out or remove after debugging!
4164 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4165 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4166 c               ees0m(num_conti,i)=0.0D0
4167 C End diagnostics.
4168 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4169 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4170 C Angular derivatives of the contact function
4171                 ees0pij1=fac3/ees0pij
4172                 ees0mij1=fac3/ees0mij
4173                 fac3p=-3.0D0*fac3*rrmij
4174                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4175                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4176 c               ees0mij1=0.0D0
4177                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4178                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4179                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4180                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4181                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4182                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4183                 ecosap=ecosa1+ecosa2
4184                 ecosbp=ecosb1+ecosb2
4185                 ecosgp=ecosg1+ecosg2
4186                 ecosam=ecosa1-ecosa2
4187                 ecosbm=ecosb1-ecosb2
4188                 ecosgm=ecosg1-ecosg2
4189 C Diagnostics
4190 c               ecosap=ecosa1
4191 c               ecosbp=ecosb1
4192 c               ecosgp=ecosg1
4193 c               ecosam=0.0D0
4194 c               ecosbm=0.0D0
4195 c               ecosgm=0.0D0
4196 C End diagnostics
4197                 facont_hb(num_conti,i)=fcont
4198                 fprimcont=fprimcont/rij
4199 cd              facont_hb(num_conti,i)=1.0D0
4200 C Following line is for diagnostics.
4201 cd              fprimcont=0.0D0
4202                 do k=1,3
4203                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4204                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4205                 enddo
4206                 do k=1,3
4207                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4208                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4209                 enddo
4210                 gggp(1)=gggp(1)+ees0pijp*xj
4211                 gggp(2)=gggp(2)+ees0pijp*yj
4212                 gggp(3)=gggp(3)+ees0pijp*zj
4213                 gggm(1)=gggm(1)+ees0mijp*xj
4214                 gggm(2)=gggm(2)+ees0mijp*yj
4215                 gggm(3)=gggm(3)+ees0mijp*zj
4216 C Derivatives due to the contact function
4217                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4218                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4219                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4220                 do k=1,3
4221 c
4222 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4223 c          following the change of gradient-summation algorithm.
4224 c
4225 cgrad                  ghalfp=0.5D0*gggp(k)
4226 cgrad                  ghalfm=0.5D0*gggm(k)
4227                   gacontp_hb1(k,num_conti,i)=!ghalfp
4228      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4229      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4230                   gacontp_hb2(k,num_conti,i)=!ghalfp
4231      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4232      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4233                   gacontp_hb3(k,num_conti,i)=gggp(k)
4234                   gacontm_hb1(k,num_conti,i)=!ghalfm
4235      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4236      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4237                   gacontm_hb2(k,num_conti,i)=!ghalfm
4238      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4239      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4240                   gacontm_hb3(k,num_conti,i)=gggm(k)
4241                 enddo
4242 C Diagnostics. Comment out or remove after debugging!
4243 cdiag           do k=1,3
4244 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4245 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4246 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4247 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4248 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4249 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4250 cdiag           enddo
4251               ENDIF ! wcorr
4252               endif  ! num_conti.le.maxconts
4253             endif  ! fcont.gt.0
4254           endif    ! j.gt.i+1
4255           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4256             do k=1,4
4257               do l=1,3
4258                 ghalf=0.5d0*agg(l,k)
4259                 aggi(l,k)=aggi(l,k)+ghalf
4260                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4261                 aggj(l,k)=aggj(l,k)+ghalf
4262               enddo
4263             enddo
4264             if (j.eq.nres-1 .and. i.lt.j-2) then
4265               do k=1,4
4266                 do l=1,3
4267                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4268                 enddo
4269               enddo
4270             endif
4271           endif
4272 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4273       return
4274       end
4275 C-----------------------------------------------------------------------------
4276       subroutine eturn3(i,eello_turn3)
4277 C Third- and fourth-order contributions from turns
4278       implicit real*8 (a-h,o-z)
4279       include 'DIMENSIONS'
4280       include 'COMMON.IOUNITS'
4281       include 'COMMON.GEO'
4282       include 'COMMON.VAR'
4283       include 'COMMON.LOCAL'
4284       include 'COMMON.CHAIN'
4285       include 'COMMON.DERIV'
4286       include 'COMMON.INTERACT'
4287       include 'COMMON.CONTACTS'
4288       include 'COMMON.TORSION'
4289       include 'COMMON.VECTORS'
4290       include 'COMMON.FFIELD'
4291       include 'COMMON.CONTROL'
4292       dimension ggg(3)
4293       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4294      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4295      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4296      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4297      &  auxgmat2(2,2),auxgmatt2(2,2)
4298       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4299      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4300       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4301      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4302      &    num_conti,j1,j2
4303       j=i+2
4304 c      write (iout,*) "eturn3",i,j,j1,j2
4305       a_temp(1,1)=a22
4306       a_temp(1,2)=a23
4307       a_temp(2,1)=a32
4308       a_temp(2,2)=a33
4309 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4310 C
4311 C               Third-order contributions
4312 C
4313 C                 (i+2)o----(i+3)
4314 C                      | |
4315 C                      | |
4316 C                 (i+1)o----i
4317 C
4318 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4319 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4320         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4321 c auxalary matices for theta gradient
4322 c auxalary matrix for i+1 and constant i+2
4323         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4324 c auxalary matrix for i+2 and constant i+1
4325         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4326         call transpose2(auxmat(1,1),auxmat1(1,1))
4327         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4328         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4329         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4330         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4331         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4332         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4333 C Derivatives in theta
4334         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4335      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4336         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4337      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4338
4339         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4340      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4341 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4342 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4343 cd     &    ' eello_turn3_num',4*eello_turn3_num
4344 C Derivatives in gamma(i)
4345         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4346         call transpose2(auxmat2(1,1),auxmat3(1,1))
4347         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4348         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4349 C Derivatives in gamma(i+1)
4350         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4351         call transpose2(auxmat2(1,1),auxmat3(1,1))
4352         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4353         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4354      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4355 C Cartesian derivatives
4356         do l=1,3
4357 c            ghalf1=0.5d0*agg(l,1)
4358 c            ghalf2=0.5d0*agg(l,2)
4359 c            ghalf3=0.5d0*agg(l,3)
4360 c            ghalf4=0.5d0*agg(l,4)
4361           a_temp(1,1)=aggi(l,1)!+ghalf1
4362           a_temp(1,2)=aggi(l,2)!+ghalf2
4363           a_temp(2,1)=aggi(l,3)!+ghalf3
4364           a_temp(2,2)=aggi(l,4)!+ghalf4
4365           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4366           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4367      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4368           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4369           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4370           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4371           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4372           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4373           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4374      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4375           a_temp(1,1)=aggj(l,1)!+ghalf1
4376           a_temp(1,2)=aggj(l,2)!+ghalf2
4377           a_temp(2,1)=aggj(l,3)!+ghalf3
4378           a_temp(2,2)=aggj(l,4)!+ghalf4
4379           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4380           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4381      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4382           a_temp(1,1)=aggj1(l,1)
4383           a_temp(1,2)=aggj1(l,2)
4384           a_temp(2,1)=aggj1(l,3)
4385           a_temp(2,2)=aggj1(l,4)
4386           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4387           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4388      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4389         enddo
4390       return
4391       end
4392 C-------------------------------------------------------------------------------
4393       subroutine eturn4(i,eello_turn4)
4394 C Third- and fourth-order contributions from turns
4395       implicit real*8 (a-h,o-z)
4396       include 'DIMENSIONS'
4397       include 'COMMON.IOUNITS'
4398       include 'COMMON.GEO'
4399       include 'COMMON.VAR'
4400       include 'COMMON.LOCAL'
4401       include 'COMMON.CHAIN'
4402       include 'COMMON.DERIV'
4403       include 'COMMON.INTERACT'
4404       include 'COMMON.CONTACTS'
4405       include 'COMMON.TORSION'
4406       include 'COMMON.VECTORS'
4407       include 'COMMON.FFIELD'
4408       include 'COMMON.CONTROL'
4409       dimension ggg(3)
4410       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4411      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4412      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4413      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4414      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4415      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4416      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4417       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4418      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4419       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4420      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4421      &    num_conti,j1,j2
4422       j=i+3
4423 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4424 C
4425 C               Fourth-order contributions
4426 C
4427 C                 (i+3)o----(i+4)
4428 C                     /  |
4429 C               (i+2)o   |
4430 C                     \  |
4431 C                 (i+1)o----i
4432 C
4433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4434 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4435 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4436 c        write(iout,*)"WCHODZE W PROGRAM"
4437         a_temp(1,1)=a22
4438         a_temp(1,2)=a23
4439         a_temp(2,1)=a32
4440         a_temp(2,2)=a33
4441         iti1=itortyp(itype(i+1))
4442         iti2=itortyp(itype(i+2))
4443         iti3=itortyp(itype(i+3))
4444 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4445         call transpose2(EUg(1,1,i+1),e1t(1,1))
4446         call transpose2(Eug(1,1,i+2),e2t(1,1))
4447         call transpose2(Eug(1,1,i+3),e3t(1,1))
4448 C Ematrix derivative in theta
4449         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4450         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4451         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4452         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4453 c       eta1 in derivative theta
4454         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4455         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4456 c       auxgvec is derivative of Ub2 so i+3 theta
4457         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4458 c       auxalary matrix of E i+1
4459         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4460 c        s1=0.0
4461 c        gs1=0.0
4462         s1=scalar2(b1(1,i+2),auxvec(1))
4463 c derivative of theta i+2 with constant i+3
4464         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4465 c derivative of theta i+2 with constant i+2
4466         gs32=scalar2(b1(1,i+2),auxgvec(1))
4467 c derivative of E matix in theta of i+1
4468         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4469
4470         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4471 c       ea31 in derivative theta
4472         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4473         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4474 c auxilary matrix auxgvec of Ub2 with constant E matirx
4475         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4476 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4477         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4478
4479 c        s2=0.0
4480 c        gs2=0.0
4481         s2=scalar2(b1(1,i+1),auxvec(1))
4482 c derivative of theta i+1 with constant i+3
4483         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4484 c derivative of theta i+2 with constant i+1
4485         gs21=scalar2(b1(1,i+1),auxgvec(1))
4486 c derivative of theta i+3 with constant i+1
4487         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4488 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4489 c     &  gtb1(1,i+1)
4490         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4491 c two derivatives over diffetent matrices
4492 c gtae3e2 is derivative over i+3
4493         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4494 c ae3gte2 is derivative over i+2
4495         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4496         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4497 c three possible derivative over theta E matices
4498 c i+1
4499         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4500 c i+2
4501         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4502 c i+3
4503         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4504         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4505
4506         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4507         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4508         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4509
4510         eello_turn4=eello_turn4-(s1+s2+s3)
4511 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4512         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4513      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4514 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4515 cd     &    ' eello_turn4_num',8*eello_turn4_num
4516 #ifdef NEWCORR
4517         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4518      &                  -(gs13+gsE13+gsEE1)*wturn4
4519         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4520      &                    -(gs23+gs21+gsEE2)*wturn4
4521         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4522      &                    -(gs32+gsE31+gsEE3)*wturn4
4523 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4524 c     &   gs2
4525 #endif
4526         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4527      &      'eturn4',i,j,-(s1+s2+s3)
4528 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4529 c     &    ' eello_turn4_num',8*eello_turn4_num
4530 C Derivatives in gamma(i)
4531         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4532         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4533         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4534         s1=scalar2(b1(1,i+2),auxvec(1))
4535         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4536         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4537         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4538 C Derivatives in gamma(i+1)
4539         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4540         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4541         s2=scalar2(b1(1,i+1),auxvec(1))
4542         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4543         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4544         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4545         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4546 C Derivatives in gamma(i+2)
4547         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4548         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4549         s1=scalar2(b1(1,i+2),auxvec(1))
4550         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4551         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4552         s2=scalar2(b1(1,i+1),auxvec(1))
4553         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4554         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4555         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4556         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4557 C Cartesian derivatives
4558 C Derivatives of this turn contributions in DC(i+2)
4559         if (j.lt.nres-1) then
4560           do l=1,3
4561             a_temp(1,1)=agg(l,1)
4562             a_temp(1,2)=agg(l,2)
4563             a_temp(2,1)=agg(l,3)
4564             a_temp(2,2)=agg(l,4)
4565             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4566             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4567             s1=scalar2(b1(1,i+2),auxvec(1))
4568             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4569             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4570             s2=scalar2(b1(1,i+1),auxvec(1))
4571             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4572             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4573             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4574             ggg(l)=-(s1+s2+s3)
4575             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4576           enddo
4577         endif
4578 C Remaining derivatives of this turn contribution
4579         do l=1,3
4580           a_temp(1,1)=aggi(l,1)
4581           a_temp(1,2)=aggi(l,2)
4582           a_temp(2,1)=aggi(l,3)
4583           a_temp(2,2)=aggi(l,4)
4584           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4585           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4586           s1=scalar2(b1(1,i+2),auxvec(1))
4587           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4588           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4589           s2=scalar2(b1(1,i+1),auxvec(1))
4590           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4591           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4592           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4593           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4594           a_temp(1,1)=aggi1(l,1)
4595           a_temp(1,2)=aggi1(l,2)
4596           a_temp(2,1)=aggi1(l,3)
4597           a_temp(2,2)=aggi1(l,4)
4598           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4599           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4600           s1=scalar2(b1(1,i+2),auxvec(1))
4601           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4602           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4603           s2=scalar2(b1(1,i+1),auxvec(1))
4604           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4605           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4606           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4607           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4608           a_temp(1,1)=aggj(l,1)
4609           a_temp(1,2)=aggj(l,2)
4610           a_temp(2,1)=aggj(l,3)
4611           a_temp(2,2)=aggj(l,4)
4612           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4613           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4614           s1=scalar2(b1(1,i+2),auxvec(1))
4615           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4616           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4617           s2=scalar2(b1(1,i+1),auxvec(1))
4618           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4619           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4620           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4621           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4622           a_temp(1,1)=aggj1(l,1)
4623           a_temp(1,2)=aggj1(l,2)
4624           a_temp(2,1)=aggj1(l,3)
4625           a_temp(2,2)=aggj1(l,4)
4626           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4627           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4628           s1=scalar2(b1(1,i+2),auxvec(1))
4629           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4630           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4631           s2=scalar2(b1(1,i+1),auxvec(1))
4632           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4633           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4634           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4635 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4636           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4637         enddo
4638       return
4639       end
4640 C-----------------------------------------------------------------------------
4641       subroutine vecpr(u,v,w)
4642       implicit real*8(a-h,o-z)
4643       dimension u(3),v(3),w(3)
4644       w(1)=u(2)*v(3)-u(3)*v(2)
4645       w(2)=-u(1)*v(3)+u(3)*v(1)
4646       w(3)=u(1)*v(2)-u(2)*v(1)
4647       return
4648       end
4649 C-----------------------------------------------------------------------------
4650       subroutine unormderiv(u,ugrad,unorm,ungrad)
4651 C This subroutine computes the derivatives of a normalized vector u, given
4652 C the derivatives computed without normalization conditions, ugrad. Returns
4653 C ungrad.
4654       implicit none
4655       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4656       double precision vec(3)
4657       double precision scalar
4658       integer i,j
4659 c      write (2,*) 'ugrad',ugrad
4660 c      write (2,*) 'u',u
4661       do i=1,3
4662         vec(i)=scalar(ugrad(1,i),u(1))
4663       enddo
4664 c      write (2,*) 'vec',vec
4665       do i=1,3
4666         do j=1,3
4667           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4668         enddo
4669       enddo
4670 c      write (2,*) 'ungrad',ungrad
4671       return
4672       end
4673 C-----------------------------------------------------------------------------
4674       subroutine escp_soft_sphere(evdw2,evdw2_14)
4675 C
4676 C This subroutine calculates the excluded-volume interaction energy between
4677 C peptide-group centers and side chains and its gradient in virtual-bond and
4678 C side-chain vectors.
4679 C
4680       implicit real*8 (a-h,o-z)
4681       include 'DIMENSIONS'
4682       include 'COMMON.GEO'
4683       include 'COMMON.VAR'
4684       include 'COMMON.LOCAL'
4685       include 'COMMON.CHAIN'
4686       include 'COMMON.DERIV'
4687       include 'COMMON.INTERACT'
4688       include 'COMMON.FFIELD'
4689       include 'COMMON.IOUNITS'
4690       include 'COMMON.CONTROL'
4691       dimension ggg(3)
4692       evdw2=0.0D0
4693       evdw2_14=0.0d0
4694       r0_scp=4.5d0
4695 cd    print '(a)','Enter ESCP'
4696 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4697 C      do xshift=-1,1
4698 C      do yshift=-1,1
4699 C      do zshift=-1,1
4700       do i=iatscp_s,iatscp_e
4701         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4702         iteli=itel(i)
4703         xi=0.5D0*(c(1,i)+c(1,i+1))
4704         yi=0.5D0*(c(2,i)+c(2,i+1))
4705         zi=0.5D0*(c(3,i)+c(3,i+1))
4706 C Return atom into box, boxxsize is size of box in x dimension
4707 c  134   continue
4708 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4709 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4710 C Condition for being inside the proper box
4711 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4712 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4713 c        go to 134
4714 c        endif
4715 c  135   continue
4716 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4717 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4718 C Condition for being inside the proper box
4719 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4720 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4721 c        go to 135
4722 c c       endif
4723 c  136   continue
4724 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4725 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4726 cC Condition for being inside the proper box
4727 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4728 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4729 c        go to 136
4730 c        endif
4731           xi=mod(xi,boxxsize)
4732           if (xi.lt.0) xi=xi+boxxsize
4733           yi=mod(yi,boxysize)
4734           if (yi.lt.0) yi=yi+boxysize
4735           zi=mod(zi,boxzsize)
4736           if (zi.lt.0) zi=zi+boxzsize
4737 C          xi=xi+xshift*boxxsize
4738 C          yi=yi+yshift*boxysize
4739 C          zi=zi+zshift*boxzsize
4740         do iint=1,nscp_gr(i)
4741
4742         do j=iscpstart(i,iint),iscpend(i,iint)
4743           if (itype(j).eq.ntyp1) cycle
4744           itypj=iabs(itype(j))
4745 C Uncomment following three lines for SC-p interactions
4746 c         xj=c(1,nres+j)-xi
4747 c         yj=c(2,nres+j)-yi
4748 c         zj=c(3,nres+j)-zi
4749 C Uncomment following three lines for Ca-p interactions
4750           xj=c(1,j)
4751           yj=c(2,j)
4752           zj=c(3,j)
4753 c  174   continue
4754 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4755 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4756 C Condition for being inside the proper box
4757 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4758 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4759 c        go to 174
4760 c        endif
4761 c  175   continue
4762 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4763 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4764 cC Condition for being inside the proper box
4765 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4766 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4767 c        go to 175
4768 c        endif
4769 c  176   continue
4770 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4771 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4772 C Condition for being inside the proper box
4773 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4774 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4775 c        go to 176
4776           xj=mod(xj,boxxsize)
4777           if (xj.lt.0) xj=xj+boxxsize
4778           yj=mod(yj,boxysize)
4779           if (yj.lt.0) yj=yj+boxysize
4780           zj=mod(zj,boxzsize)
4781           if (zj.lt.0) zj=zj+boxzsize
4782       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4783       xj_safe=xj
4784       yj_safe=yj
4785       zj_safe=zj
4786       subchap=0
4787       do xshift=-1,1
4788       do yshift=-1,1
4789       do zshift=-1,1
4790           xj=xj_safe+xshift*boxxsize
4791           yj=yj_safe+yshift*boxysize
4792           zj=zj_safe+zshift*boxzsize
4793           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4794           if(dist_temp.lt.dist_init) then
4795             dist_init=dist_temp
4796             xj_temp=xj
4797             yj_temp=yj
4798             zj_temp=zj
4799             subchap=1
4800           endif
4801        enddo
4802        enddo
4803        enddo
4804        if (subchap.eq.1) then
4805           xj=xj_temp-xi
4806           yj=yj_temp-yi
4807           zj=zj_temp-zi
4808        else
4809           xj=xj_safe-xi
4810           yj=yj_safe-yi
4811           zj=zj_safe-zi
4812        endif
4813 c c       endif
4814 C          xj=xj-xi
4815 C          yj=yj-yi
4816 C          zj=zj-zi
4817           rij=xj*xj+yj*yj+zj*zj
4818
4819           r0ij=r0_scp
4820           r0ijsq=r0ij*r0ij
4821           if (rij.lt.r0ijsq) then
4822             evdwij=0.25d0*(rij-r0ijsq)**2
4823             fac=rij-r0ijsq
4824           else
4825             evdwij=0.0d0
4826             fac=0.0d0
4827           endif
4828           evdw2=evdw2+evdwij
4829 C
4830 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4831 C
4832           ggg(1)=xj*fac
4833           ggg(2)=yj*fac
4834           ggg(3)=zj*fac
4835 cgrad          if (j.lt.i) then
4836 cd          write (iout,*) 'j<i'
4837 C Uncomment following three lines for SC-p interactions
4838 c           do k=1,3
4839 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4840 c           enddo
4841 cgrad          else
4842 cd          write (iout,*) 'j>i'
4843 cgrad            do k=1,3
4844 cgrad              ggg(k)=-ggg(k)
4845 C Uncomment following line for SC-p interactions
4846 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4847 cgrad            enddo
4848 cgrad          endif
4849 cgrad          do k=1,3
4850 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4851 cgrad          enddo
4852 cgrad          kstart=min0(i+1,j)
4853 cgrad          kend=max0(i-1,j-1)
4854 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4855 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4856 cgrad          do k=kstart,kend
4857 cgrad            do l=1,3
4858 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4859 cgrad            enddo
4860 cgrad          enddo
4861           do k=1,3
4862             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4863             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4864           enddo
4865         enddo
4866
4867         enddo ! iint
4868       enddo ! i
4869 C      enddo !zshift
4870 C      enddo !yshift
4871 C      enddo !xshift
4872       return
4873       end
4874 C-----------------------------------------------------------------------------
4875       subroutine escp(evdw2,evdw2_14)
4876 C
4877 C This subroutine calculates the excluded-volume interaction energy between
4878 C peptide-group centers and side chains and its gradient in virtual-bond and
4879 C side-chain vectors.
4880 C
4881       implicit real*8 (a-h,o-z)
4882       include 'DIMENSIONS'
4883       include 'COMMON.GEO'
4884       include 'COMMON.VAR'
4885       include 'COMMON.LOCAL'
4886       include 'COMMON.CHAIN'
4887       include 'COMMON.DERIV'
4888       include 'COMMON.INTERACT'
4889       include 'COMMON.FFIELD'
4890       include 'COMMON.IOUNITS'
4891       include 'COMMON.CONTROL'
4892       include 'COMMON.SPLITELE'
4893       dimension ggg(3)
4894       evdw2=0.0D0
4895       evdw2_14=0.0d0
4896 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4897 cd    print '(a)','Enter ESCP'
4898 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4899 C      do xshift=-1,1
4900 C      do yshift=-1,1
4901 C      do zshift=-1,1
4902       do i=iatscp_s,iatscp_e
4903         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4904         iteli=itel(i)
4905         xi=0.5D0*(c(1,i)+c(1,i+1))
4906         yi=0.5D0*(c(2,i)+c(2,i+1))
4907         zi=0.5D0*(c(3,i)+c(3,i+1))
4908           xi=mod(xi,boxxsize)
4909           if (xi.lt.0) xi=xi+boxxsize
4910           yi=mod(yi,boxysize)
4911           if (yi.lt.0) yi=yi+boxysize
4912           zi=mod(zi,boxzsize)
4913           if (zi.lt.0) zi=zi+boxzsize
4914 c          xi=xi+xshift*boxxsize
4915 c          yi=yi+yshift*boxysize
4916 c          zi=zi+zshift*boxzsize
4917 c        print *,xi,yi,zi,'polozenie i'
4918 C Return atom into box, boxxsize is size of box in x dimension
4919 c  134   continue
4920 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4921 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4922 C Condition for being inside the proper box
4923 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4924 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4925 c        go to 134
4926 c        endif
4927 c  135   continue
4928 c          print *,xi,boxxsize,"pierwszy"
4929
4930 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4931 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4932 C Condition for being inside the proper box
4933 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4934 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4935 c        go to 135
4936 c        endif
4937 c  136   continue
4938 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4939 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4940 C Condition for being inside the proper box
4941 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4942 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4943 c        go to 136
4944 c        endif
4945         do iint=1,nscp_gr(i)
4946
4947         do j=iscpstart(i,iint),iscpend(i,iint)
4948           itypj=iabs(itype(j))
4949           if (itypj.eq.ntyp1) cycle
4950 C Uncomment following three lines for SC-p interactions
4951 c         xj=c(1,nres+j)-xi
4952 c         yj=c(2,nres+j)-yi
4953 c         zj=c(3,nres+j)-zi
4954 C Uncomment following three lines for Ca-p interactions
4955           xj=c(1,j)
4956           yj=c(2,j)
4957           zj=c(3,j)
4958           xj=mod(xj,boxxsize)
4959           if (xj.lt.0) xj=xj+boxxsize
4960           yj=mod(yj,boxysize)
4961           if (yj.lt.0) yj=yj+boxysize
4962           zj=mod(zj,boxzsize)
4963           if (zj.lt.0) zj=zj+boxzsize
4964 c  174   continue
4965 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4966 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4967 C Condition for being inside the proper box
4968 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4969 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4970 c        go to 174
4971 c        endif
4972 c  175   continue
4973 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4974 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4975 cC Condition for being inside the proper box
4976 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4977 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4978 c        go to 175
4979 c        endif
4980 c  176   continue
4981 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4982 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4983 C Condition for being inside the proper box
4984 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4985 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4986 c        go to 176
4987 c        endif
4988 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4989       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4990       xj_safe=xj
4991       yj_safe=yj
4992       zj_safe=zj
4993       subchap=0
4994       do xshift=-1,1
4995       do yshift=-1,1
4996       do zshift=-1,1
4997           xj=xj_safe+xshift*boxxsize
4998           yj=yj_safe+yshift*boxysize
4999           zj=zj_safe+zshift*boxzsize
5000           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5001           if(dist_temp.lt.dist_init) then
5002             dist_init=dist_temp
5003             xj_temp=xj
5004             yj_temp=yj
5005             zj_temp=zj
5006             subchap=1
5007           endif
5008        enddo
5009        enddo
5010        enddo
5011        if (subchap.eq.1) then
5012           xj=xj_temp-xi
5013           yj=yj_temp-yi
5014           zj=zj_temp-zi
5015        else
5016           xj=xj_safe-xi
5017           yj=yj_safe-yi
5018           zj=zj_safe-zi
5019        endif
5020 c          print *,xj,yj,zj,'polozenie j'
5021           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5022 c          print *,rrij
5023           sss=sscale(1.0d0/(dsqrt(rrij)))
5024 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5025 c          if (sss.eq.0) print *,'czasem jest OK'
5026           if (sss.le.0.0d0) cycle
5027           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5028           fac=rrij**expon2
5029           e1=fac*fac*aad(itypj,iteli)
5030           e2=fac*bad(itypj,iteli)
5031           if (iabs(j-i) .le. 2) then
5032             e1=scal14*e1
5033             e2=scal14*e2
5034             evdw2_14=evdw2_14+(e1+e2)*sss
5035           endif
5036           evdwij=e1+e2
5037           evdw2=evdw2+evdwij*sss
5038           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5039      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5040      &       bad(itypj,iteli)
5041 C
5042 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5043 C
5044           fac=-(evdwij+e1)*rrij*sss
5045           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5046           ggg(1)=xj*fac
5047           ggg(2)=yj*fac
5048           ggg(3)=zj*fac
5049 cgrad          if (j.lt.i) then
5050 cd          write (iout,*) 'j<i'
5051 C Uncomment following three lines for SC-p interactions
5052 c           do k=1,3
5053 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5054 c           enddo
5055 cgrad          else
5056 cd          write (iout,*) 'j>i'
5057 cgrad            do k=1,3
5058 cgrad              ggg(k)=-ggg(k)
5059 C Uncomment following line for SC-p interactions
5060 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5061 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5062 cgrad            enddo
5063 cgrad          endif
5064 cgrad          do k=1,3
5065 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5066 cgrad          enddo
5067 cgrad          kstart=min0(i+1,j)
5068 cgrad          kend=max0(i-1,j-1)
5069 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5070 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5071 cgrad          do k=kstart,kend
5072 cgrad            do l=1,3
5073 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5074 cgrad            enddo
5075 cgrad          enddo
5076           do k=1,3
5077             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5078             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5079           enddo
5080 c        endif !endif for sscale cutoff
5081         enddo ! j
5082
5083         enddo ! iint
5084       enddo ! i
5085 c      enddo !zshift
5086 c      enddo !yshift
5087 c      enddo !xshift
5088       do i=1,nct
5089         do j=1,3
5090           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5091           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5092           gradx_scp(j,i)=expon*gradx_scp(j,i)
5093         enddo
5094       enddo
5095 C******************************************************************************
5096 C
5097 C                              N O T E !!!
5098 C
5099 C To save time the factor EXPON has been extracted from ALL components
5100 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5101 C use!
5102 C
5103 C******************************************************************************
5104       return
5105       end
5106 C--------------------------------------------------------------------------
5107       subroutine edis(ehpb)
5108 C
5109 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5110 C
5111       implicit real*8 (a-h,o-z)
5112       include 'DIMENSIONS'
5113       include 'COMMON.SBRIDGE'
5114       include 'COMMON.CHAIN'
5115       include 'COMMON.DERIV'
5116       include 'COMMON.VAR'
5117       include 'COMMON.INTERACT'
5118       include 'COMMON.IOUNITS'
5119       dimension ggg(3)
5120       ehpb=0.0D0
5121 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5122 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5123       if (link_end.eq.0) return
5124       do i=link_start,link_end
5125 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5126 C CA-CA distance used in regularization of structure.
5127         ii=ihpb(i)
5128         jj=jhpb(i)
5129 C iii and jjj point to the residues for which the distance is assigned.
5130         if (ii.gt.nres) then
5131           iii=ii-nres
5132           jjj=jj-nres
5133         else
5134           iii=ii
5135           jjj=jj
5136         endif
5137 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5138 c     &    dhpb(i),dhpb1(i),forcon(i)
5139 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5140 C    distance and angle dependent SS bond potential.
5141 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5142 C     & iabs(itype(jjj)).eq.1) then
5143 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5144 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5145         if (.not.dyn_ss .and. i.le.nss) then
5146 C 15/02/13 CC dynamic SSbond - additional check
5147          if (ii.gt.nres
5148      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5149           call ssbond_ene(iii,jjj,eij)
5150           ehpb=ehpb+2*eij
5151          endif
5152 cd          write (iout,*) "eij",eij
5153         else
5154 C Calculate the distance between the two points and its difference from the
5155 C target distance.
5156           dd=dist(ii,jj)
5157             rdis=dd-dhpb(i)
5158 C Get the force constant corresponding to this distance.
5159             waga=forcon(i)
5160 C Calculate the contribution to energy.
5161             ehpb=ehpb+waga*rdis*rdis
5162 C
5163 C Evaluate gradient.
5164 C
5165             fac=waga*rdis/dd
5166 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5167 cd   &   ' waga=',waga,' fac=',fac
5168             do j=1,3
5169               ggg(j)=fac*(c(j,jj)-c(j,ii))
5170             enddo
5171 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5172 C If this is a SC-SC distance, we need to calculate the contributions to the
5173 C Cartesian gradient in the SC vectors (ghpbx).
5174           if (iii.lt.ii) then
5175           do j=1,3
5176             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5177             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5178           enddo
5179           endif
5180 cgrad        do j=iii,jjj-1
5181 cgrad          do k=1,3
5182 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5183 cgrad          enddo
5184 cgrad        enddo
5185           do k=1,3
5186             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5187             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5188           enddo
5189         endif
5190       enddo
5191       ehpb=0.5D0*ehpb
5192       return
5193       end
5194 C--------------------------------------------------------------------------
5195       subroutine ssbond_ene(i,j,eij)
5196 C
5197 C Calculate the distance and angle dependent SS-bond potential energy
5198 C using a free-energy function derived based on RHF/6-31G** ab initio
5199 C calculations of diethyl disulfide.
5200 C
5201 C A. Liwo and U. Kozlowska, 11/24/03
5202 C
5203       implicit real*8 (a-h,o-z)
5204       include 'DIMENSIONS'
5205       include 'COMMON.SBRIDGE'
5206       include 'COMMON.CHAIN'
5207       include 'COMMON.DERIV'
5208       include 'COMMON.LOCAL'
5209       include 'COMMON.INTERACT'
5210       include 'COMMON.VAR'
5211       include 'COMMON.IOUNITS'
5212       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5213       itypi=iabs(itype(i))
5214       xi=c(1,nres+i)
5215       yi=c(2,nres+i)
5216       zi=c(3,nres+i)
5217       dxi=dc_norm(1,nres+i)
5218       dyi=dc_norm(2,nres+i)
5219       dzi=dc_norm(3,nres+i)
5220 c      dsci_inv=dsc_inv(itypi)
5221       dsci_inv=vbld_inv(nres+i)
5222       itypj=iabs(itype(j))
5223 c      dscj_inv=dsc_inv(itypj)
5224       dscj_inv=vbld_inv(nres+j)
5225       xj=c(1,nres+j)-xi
5226       yj=c(2,nres+j)-yi
5227       zj=c(3,nres+j)-zi
5228       dxj=dc_norm(1,nres+j)
5229       dyj=dc_norm(2,nres+j)
5230       dzj=dc_norm(3,nres+j)
5231       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5232       rij=dsqrt(rrij)
5233       erij(1)=xj*rij
5234       erij(2)=yj*rij
5235       erij(3)=zj*rij
5236       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5237       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5238       om12=dxi*dxj+dyi*dyj+dzi*dzj
5239       do k=1,3
5240         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5241         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5242       enddo
5243       rij=1.0d0/rij
5244       deltad=rij-d0cm
5245       deltat1=1.0d0-om1
5246       deltat2=1.0d0+om2
5247       deltat12=om2-om1+2.0d0
5248       cosphi=om12-om1*om2
5249       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5250      &  +akct*deltad*deltat12
5251      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5252 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5253 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5254 c     &  " deltat12",deltat12," eij",eij
5255       ed=2*akcm*deltad+akct*deltat12
5256       pom1=akct*deltad
5257       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5258       eom1=-2*akth*deltat1-pom1-om2*pom2
5259       eom2= 2*akth*deltat2+pom1-om1*pom2
5260       eom12=pom2
5261       do k=1,3
5262         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5263         ghpbx(k,i)=ghpbx(k,i)-ggk
5264      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5265      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5266         ghpbx(k,j)=ghpbx(k,j)+ggk
5267      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5268      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5269         ghpbc(k,i)=ghpbc(k,i)-ggk
5270         ghpbc(k,j)=ghpbc(k,j)+ggk
5271       enddo
5272 C
5273 C Calculate the components of the gradient in DC and X
5274 C
5275 cgrad      do k=i,j-1
5276 cgrad        do l=1,3
5277 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5278 cgrad        enddo
5279 cgrad      enddo
5280       return
5281       end
5282 C--------------------------------------------------------------------------
5283       subroutine ebond(estr)
5284 c
5285 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5286 c
5287       implicit real*8 (a-h,o-z)
5288       include 'DIMENSIONS'
5289       include 'COMMON.LOCAL'
5290       include 'COMMON.GEO'
5291       include 'COMMON.INTERACT'
5292       include 'COMMON.DERIV'
5293       include 'COMMON.VAR'
5294       include 'COMMON.CHAIN'
5295       include 'COMMON.IOUNITS'
5296       include 'COMMON.NAMES'
5297       include 'COMMON.FFIELD'
5298       include 'COMMON.CONTROL'
5299       include 'COMMON.SETUP'
5300       double precision u(3),ud(3)
5301       estr=0.0d0
5302       estr1=0.0d0
5303       do i=ibondp_start,ibondp_end
5304         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5305 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5306 c          do j=1,3
5307 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5308 c     &      *dc(j,i-1)/vbld(i)
5309 c          enddo
5310 c          if (energy_dec) write(iout,*)
5311 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5312 c        else
5313 C       Checking if it involves dummy (NH3+ or COO-) group
5314          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5315 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5316         diff = vbld(i)-vbldpDUM
5317          else
5318 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5319         diff = vbld(i)-vbldp0
5320          endif
5321         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5322      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5323         estr=estr+diff*diff
5324         do j=1,3
5325           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5326         enddo
5327 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5328 c        endif
5329       enddo
5330       estr=0.5d0*AKP*estr+estr1
5331 c
5332 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5333 c
5334       do i=ibond_start,ibond_end
5335         iti=iabs(itype(i))
5336         if (iti.ne.10 .and. iti.ne.ntyp1) then
5337           nbi=nbondterm(iti)
5338           if (nbi.eq.1) then
5339             diff=vbld(i+nres)-vbldsc0(1,iti)
5340             if (energy_dec)  write (iout,*)
5341      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5342      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5343             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5344             do j=1,3
5345               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5346             enddo
5347           else
5348             do j=1,nbi
5349               diff=vbld(i+nres)-vbldsc0(j,iti)
5350               ud(j)=aksc(j,iti)*diff
5351               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5352             enddo
5353             uprod=u(1)
5354             do j=2,nbi
5355               uprod=uprod*u(j)
5356             enddo
5357             usum=0.0d0
5358             usumsqder=0.0d0
5359             do j=1,nbi
5360               uprod1=1.0d0
5361               uprod2=1.0d0
5362               do k=1,nbi
5363                 if (k.ne.j) then
5364                   uprod1=uprod1*u(k)
5365                   uprod2=uprod2*u(k)*u(k)
5366                 endif
5367               enddo
5368               usum=usum+uprod1
5369               usumsqder=usumsqder+ud(j)*uprod2
5370             enddo
5371             estr=estr+uprod/usum
5372             do j=1,3
5373              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5374             enddo
5375           endif
5376         endif
5377       enddo
5378       return
5379       end
5380 #ifdef CRYST_THETA
5381 C--------------------------------------------------------------------------
5382       subroutine ebend(etheta)
5383 C
5384 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5385 C angles gamma and its derivatives in consecutive thetas and gammas.
5386 C
5387       implicit real*8 (a-h,o-z)
5388       include 'DIMENSIONS'
5389       include 'COMMON.LOCAL'
5390       include 'COMMON.GEO'
5391       include 'COMMON.INTERACT'
5392       include 'COMMON.DERIV'
5393       include 'COMMON.VAR'
5394       include 'COMMON.CHAIN'
5395       include 'COMMON.IOUNITS'
5396       include 'COMMON.NAMES'
5397       include 'COMMON.FFIELD'
5398       include 'COMMON.CONTROL'
5399       common /calcthet/ term1,term2,termm,diffak,ratak,
5400      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5401      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5402       double precision y(2),z(2)
5403       delta=0.02d0*pi
5404 c      time11=dexp(-2*time)
5405 c      time12=1.0d0
5406       etheta=0.0D0
5407 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5408       do i=ithet_start,ithet_end
5409         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5410      &  .or.itype(i).eq.ntyp1) cycle
5411 C Zero the energy function and its derivative at 0 or pi.
5412         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5413         it=itype(i-1)
5414         ichir1=isign(1,itype(i-2))
5415         ichir2=isign(1,itype(i))
5416          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5417          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5418          if (itype(i-1).eq.10) then
5419           itype1=isign(10,itype(i-2))
5420           ichir11=isign(1,itype(i-2))
5421           ichir12=isign(1,itype(i-2))
5422           itype2=isign(10,itype(i))
5423           ichir21=isign(1,itype(i))
5424           ichir22=isign(1,itype(i))
5425          endif
5426
5427         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5428 #ifdef OSF
5429           phii=phi(i)
5430           if (phii.ne.phii) phii=150.0
5431 #else
5432           phii=phi(i)
5433 #endif
5434           y(1)=dcos(phii)
5435           y(2)=dsin(phii)
5436         else
5437           y(1)=0.0D0
5438           y(2)=0.0D0
5439         endif
5440         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5441 #ifdef OSF
5442           phii1=phi(i+1)
5443           if (phii1.ne.phii1) phii1=150.0
5444           phii1=pinorm(phii1)
5445           z(1)=cos(phii1)
5446 #else
5447           phii1=phi(i+1)
5448 #endif
5449           z(1)=dcos(phii1)
5450           z(2)=dsin(phii1)
5451         else
5452           z(1)=0.0D0
5453           z(2)=0.0D0
5454         endif
5455 C Calculate the "mean" value of theta from the part of the distribution
5456 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5457 C In following comments this theta will be referred to as t_c.
5458         thet_pred_mean=0.0d0
5459         do k=1,2
5460             athetk=athet(k,it,ichir1,ichir2)
5461             bthetk=bthet(k,it,ichir1,ichir2)
5462           if (it.eq.10) then
5463              athetk=athet(k,itype1,ichir11,ichir12)
5464              bthetk=bthet(k,itype2,ichir21,ichir22)
5465           endif
5466          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5467 c         write(iout,*) 'chuj tu', y(k),z(k)
5468         enddo
5469         dthett=thet_pred_mean*ssd
5470         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5471 C Derivatives of the "mean" values in gamma1 and gamma2.
5472         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5473      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5474          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5475      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5476          if (it.eq.10) then
5477       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5478      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5479         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5480      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5481          endif
5482         if (theta(i).gt.pi-delta) then
5483           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5484      &         E_tc0)
5485           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5486           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5487           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5488      &        E_theta)
5489           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5490      &        E_tc)
5491         else if (theta(i).lt.delta) then
5492           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5493           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5494           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5495      &        E_theta)
5496           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5497           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5498      &        E_tc)
5499         else
5500           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5501      &        E_theta,E_tc)
5502         endif
5503         etheta=etheta+ethetai
5504         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5505      &      'ebend',i,ethetai,theta(i),itype(i)
5506         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5507         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5508         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5509       enddo
5510 C Ufff.... We've done all this!!!
5511       return
5512       end
5513 C---------------------------------------------------------------------------
5514       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5515      &     E_tc)
5516       implicit real*8 (a-h,o-z)
5517       include 'DIMENSIONS'
5518       include 'COMMON.LOCAL'
5519       include 'COMMON.IOUNITS'
5520       common /calcthet/ term1,term2,termm,diffak,ratak,
5521      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5522      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5523 C Calculate the contributions to both Gaussian lobes.
5524 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5525 C The "polynomial part" of the "standard deviation" of this part of
5526 C the distributioni.
5527 ccc        write (iout,*) thetai,thet_pred_mean
5528         sig=polthet(3,it)
5529         do j=2,0,-1
5530           sig=sig*thet_pred_mean+polthet(j,it)
5531         enddo
5532 C Derivative of the "interior part" of the "standard deviation of the"
5533 C gamma-dependent Gaussian lobe in t_c.
5534         sigtc=3*polthet(3,it)
5535         do j=2,1,-1
5536           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5537         enddo
5538         sigtc=sig*sigtc
5539 C Set the parameters of both Gaussian lobes of the distribution.
5540 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5541         fac=sig*sig+sigc0(it)
5542         sigcsq=fac+fac
5543         sigc=1.0D0/sigcsq
5544 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5545         sigsqtc=-4.0D0*sigcsq*sigtc
5546 c       print *,i,sig,sigtc,sigsqtc
5547 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5548         sigtc=-sigtc/(fac*fac)
5549 C Following variable is sigma(t_c)**(-2)
5550         sigcsq=sigcsq*sigcsq
5551         sig0i=sig0(it)
5552         sig0inv=1.0D0/sig0i**2
5553         delthec=thetai-thet_pred_mean
5554         delthe0=thetai-theta0i
5555         term1=-0.5D0*sigcsq*delthec*delthec
5556         term2=-0.5D0*sig0inv*delthe0*delthe0
5557 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5558 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5559 C NaNs in taking the logarithm. We extract the largest exponent which is added
5560 C to the energy (this being the log of the distribution) at the end of energy
5561 C term evaluation for this virtual-bond angle.
5562         if (term1.gt.term2) then
5563           termm=term1
5564           term2=dexp(term2-termm)
5565           term1=1.0d0
5566         else
5567           termm=term2
5568           term1=dexp(term1-termm)
5569           term2=1.0d0
5570         endif
5571 C The ratio between the gamma-independent and gamma-dependent lobes of
5572 C the distribution is a Gaussian function of thet_pred_mean too.
5573         diffak=gthet(2,it)-thet_pred_mean
5574         ratak=diffak/gthet(3,it)**2
5575         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5576 C Let's differentiate it in thet_pred_mean NOW.
5577         aktc=ak*ratak
5578 C Now put together the distribution terms to make complete distribution.
5579         termexp=term1+ak*term2
5580         termpre=sigc+ak*sig0i
5581 C Contribution of the bending energy from this theta is just the -log of
5582 C the sum of the contributions from the two lobes and the pre-exponential
5583 C factor. Simple enough, isn't it?
5584         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5585 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5586 C NOW the derivatives!!!
5587 C 6/6/97 Take into account the deformation.
5588         E_theta=(delthec*sigcsq*term1
5589      &       +ak*delthe0*sig0inv*term2)/termexp
5590         E_tc=((sigtc+aktc*sig0i)/termpre
5591      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5592      &       aktc*term2)/termexp)
5593       return
5594       end
5595 c-----------------------------------------------------------------------------
5596       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5597       implicit real*8 (a-h,o-z)
5598       include 'DIMENSIONS'
5599       include 'COMMON.LOCAL'
5600       include 'COMMON.IOUNITS'
5601       common /calcthet/ term1,term2,termm,diffak,ratak,
5602      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5603      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5604       delthec=thetai-thet_pred_mean
5605       delthe0=thetai-theta0i
5606 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5607       t3 = thetai-thet_pred_mean
5608       t6 = t3**2
5609       t9 = term1
5610       t12 = t3*sigcsq
5611       t14 = t12+t6*sigsqtc
5612       t16 = 1.0d0
5613       t21 = thetai-theta0i
5614       t23 = t21**2
5615       t26 = term2
5616       t27 = t21*t26
5617       t32 = termexp
5618       t40 = t32**2
5619       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5620      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5621      & *(-t12*t9-ak*sig0inv*t27)
5622       return
5623       end
5624 #else
5625 C--------------------------------------------------------------------------
5626       subroutine ebend(etheta)
5627 C
5628 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5629 C angles gamma and its derivatives in consecutive thetas and gammas.
5630 C ab initio-derived potentials from
5631 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5632 C
5633       implicit real*8 (a-h,o-z)
5634       include 'DIMENSIONS'
5635       include 'COMMON.LOCAL'
5636       include 'COMMON.GEO'
5637       include 'COMMON.INTERACT'
5638       include 'COMMON.DERIV'
5639       include 'COMMON.VAR'
5640       include 'COMMON.CHAIN'
5641       include 'COMMON.IOUNITS'
5642       include 'COMMON.NAMES'
5643       include 'COMMON.FFIELD'
5644       include 'COMMON.CONTROL'
5645       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5646      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5647      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5648      & sinph1ph2(maxdouble,maxdouble)
5649       logical lprn /.false./, lprn1 /.false./
5650       etheta=0.0D0
5651       do i=ithet_start,ithet_end
5652 c        print *,i,itype(i-1),itype(i),itype(i-2)
5653         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5654      &  .or.itype(i).eq.ntyp1) cycle
5655 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5656
5657         if (iabs(itype(i+1)).eq.20) iblock=2
5658         if (iabs(itype(i+1)).ne.20) iblock=1
5659         dethetai=0.0d0
5660         dephii=0.0d0
5661         dephii1=0.0d0
5662         theti2=0.5d0*theta(i)
5663         ityp2=ithetyp((itype(i-1)))
5664         do k=1,nntheterm
5665           coskt(k)=dcos(k*theti2)
5666           sinkt(k)=dsin(k*theti2)
5667         enddo
5668         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5669 #ifdef OSF
5670           phii=phi(i)
5671           if (phii.ne.phii) phii=150.0
5672 #else
5673           phii=phi(i)
5674 #endif
5675           ityp1=ithetyp((itype(i-2)))
5676 C propagation of chirality for glycine type
5677           do k=1,nsingle
5678             cosph1(k)=dcos(k*phii)
5679             sinph1(k)=dsin(k*phii)
5680           enddo
5681         else
5682           phii=0.0d0
5683           ityp1=nthetyp+1
5684           do k=1,nsingle
5685             cosph1(k)=0.0d0
5686             sinph1(k)=0.0d0
5687           enddo
5688         endif
5689         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5690 #ifdef OSF
5691           phii1=phi(i+1)
5692           if (phii1.ne.phii1) phii1=150.0
5693           phii1=pinorm(phii1)
5694 #else
5695           phii1=phi(i+1)
5696 #endif
5697           ityp3=ithetyp((itype(i)))
5698           do k=1,nsingle
5699             cosph2(k)=dcos(k*phii1)
5700             sinph2(k)=dsin(k*phii1)
5701           enddo
5702         else
5703           phii1=0.0d0
5704           ityp3=nthetyp+1
5705           do k=1,nsingle
5706             cosph2(k)=0.0d0
5707             sinph2(k)=0.0d0
5708           enddo
5709         endif
5710         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5711         do k=1,ndouble
5712           do l=1,k-1
5713             ccl=cosph1(l)*cosph2(k-l)
5714             ssl=sinph1(l)*sinph2(k-l)
5715             scl=sinph1(l)*cosph2(k-l)
5716             csl=cosph1(l)*sinph2(k-l)
5717             cosph1ph2(l,k)=ccl-ssl
5718             cosph1ph2(k,l)=ccl+ssl
5719             sinph1ph2(l,k)=scl+csl
5720             sinph1ph2(k,l)=scl-csl
5721           enddo
5722         enddo
5723         if (lprn) then
5724         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5725      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5726         write (iout,*) "coskt and sinkt"
5727         do k=1,nntheterm
5728           write (iout,*) k,coskt(k),sinkt(k)
5729         enddo
5730         endif
5731         do k=1,ntheterm
5732           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5733           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5734      &      *coskt(k)
5735           if (lprn)
5736      &    write (iout,*) "k",k,"
5737      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5738      &     " ethetai",ethetai
5739         enddo
5740         if (lprn) then
5741         write (iout,*) "cosph and sinph"
5742         do k=1,nsingle
5743           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5744         enddo
5745         write (iout,*) "cosph1ph2 and sinph2ph2"
5746         do k=2,ndouble
5747           do l=1,k-1
5748             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5749      &         sinph1ph2(l,k),sinph1ph2(k,l)
5750           enddo
5751         enddo
5752         write(iout,*) "ethetai",ethetai
5753         endif
5754         do m=1,ntheterm2
5755           do k=1,nsingle
5756             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5757      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5758      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5759      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5760             ethetai=ethetai+sinkt(m)*aux
5761             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5762             dephii=dephii+k*sinkt(m)*(
5763      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5764      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5765             dephii1=dephii1+k*sinkt(m)*(
5766      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5767      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5768             if (lprn)
5769      &      write (iout,*) "m",m," k",k," bbthet",
5770      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5771      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5772      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5773      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5774           enddo
5775         enddo
5776         if (lprn)
5777      &  write(iout,*) "ethetai",ethetai
5778         do m=1,ntheterm3
5779           do k=2,ndouble
5780             do l=1,k-1
5781               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5782      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5783      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5784      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5785               ethetai=ethetai+sinkt(m)*aux
5786               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5787               dephii=dephii+l*sinkt(m)*(
5788      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5789      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5790      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5791      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5792               dephii1=dephii1+(k-l)*sinkt(m)*(
5793      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5794      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5795      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5796      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5797               if (lprn) then
5798               write (iout,*) "m",m," k",k," l",l," ffthet",
5799      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5800      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5801      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5802      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5803      &            " ethetai",ethetai
5804               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5805      &            cosph1ph2(k,l)*sinkt(m),
5806      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5807               endif
5808             enddo
5809           enddo
5810         enddo
5811 10      continue
5812 c        lprn1=.true.
5813         if (lprn1)
5814      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5815      &   i,theta(i)*rad2deg,phii*rad2deg,
5816      &   phii1*rad2deg,ethetai
5817 c        lprn1=.false.
5818         etheta=etheta+ethetai
5819         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5820         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5821         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5822       enddo
5823       return
5824       end
5825 #endif
5826 #ifdef CRYST_SC
5827 c-----------------------------------------------------------------------------
5828       subroutine esc(escloc)
5829 C Calculate the local energy of a side chain and its derivatives in the
5830 C corresponding virtual-bond valence angles THETA and the spherical angles
5831 C ALPHA and OMEGA.
5832       implicit real*8 (a-h,o-z)
5833       include 'DIMENSIONS'
5834       include 'COMMON.GEO'
5835       include 'COMMON.LOCAL'
5836       include 'COMMON.VAR'
5837       include 'COMMON.INTERACT'
5838       include 'COMMON.DERIV'
5839       include 'COMMON.CHAIN'
5840       include 'COMMON.IOUNITS'
5841       include 'COMMON.NAMES'
5842       include 'COMMON.FFIELD'
5843       include 'COMMON.CONTROL'
5844       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5845      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5846       common /sccalc/ time11,time12,time112,theti,it,nlobit
5847       delta=0.02d0*pi
5848       escloc=0.0D0
5849 c     write (iout,'(a)') 'ESC'
5850       do i=loc_start,loc_end
5851         it=itype(i)
5852         if (it.eq.ntyp1) cycle
5853         if (it.eq.10) goto 1
5854         nlobit=nlob(iabs(it))
5855 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5856 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5857         theti=theta(i+1)-pipol
5858         x(1)=dtan(theti)
5859         x(2)=alph(i)
5860         x(3)=omeg(i)
5861
5862         if (x(2).gt.pi-delta) then
5863           xtemp(1)=x(1)
5864           xtemp(2)=pi-delta
5865           xtemp(3)=x(3)
5866           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5867           xtemp(2)=pi
5868           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5869           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5870      &        escloci,dersc(2))
5871           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5872      &        ddersc0(1),dersc(1))
5873           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5874      &        ddersc0(3),dersc(3))
5875           xtemp(2)=pi-delta
5876           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5877           xtemp(2)=pi
5878           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5879           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5880      &            dersc0(2),esclocbi,dersc02)
5881           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5882      &            dersc12,dersc01)
5883           call splinthet(x(2),0.5d0*delta,ss,ssd)
5884           dersc0(1)=dersc01
5885           dersc0(2)=dersc02
5886           dersc0(3)=0.0d0
5887           do k=1,3
5888             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5889           enddo
5890           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5891 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5892 c    &             esclocbi,ss,ssd
5893           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5894 c         escloci=esclocbi
5895 c         write (iout,*) escloci
5896         else if (x(2).lt.delta) then
5897           xtemp(1)=x(1)
5898           xtemp(2)=delta
5899           xtemp(3)=x(3)
5900           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5901           xtemp(2)=0.0d0
5902           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5903           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5904      &        escloci,dersc(2))
5905           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5906      &        ddersc0(1),dersc(1))
5907           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5908      &        ddersc0(3),dersc(3))
5909           xtemp(2)=delta
5910           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5911           xtemp(2)=0.0d0
5912           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5913           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5914      &            dersc0(2),esclocbi,dersc02)
5915           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5916      &            dersc12,dersc01)
5917           dersc0(1)=dersc01
5918           dersc0(2)=dersc02
5919           dersc0(3)=0.0d0
5920           call splinthet(x(2),0.5d0*delta,ss,ssd)
5921           do k=1,3
5922             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5923           enddo
5924           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5925 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5926 c    &             esclocbi,ss,ssd
5927           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5928 c         write (iout,*) escloci
5929         else
5930           call enesc(x,escloci,dersc,ddummy,.false.)
5931         endif
5932
5933         escloc=escloc+escloci
5934         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5935      &     'escloc',i,escloci
5936 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5937
5938         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5939      &   wscloc*dersc(1)
5940         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5941         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5942     1   continue
5943       enddo
5944       return
5945       end
5946 C---------------------------------------------------------------------------
5947       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5948       implicit real*8 (a-h,o-z)
5949       include 'DIMENSIONS'
5950       include 'COMMON.GEO'
5951       include 'COMMON.LOCAL'
5952       include 'COMMON.IOUNITS'
5953       common /sccalc/ time11,time12,time112,theti,it,nlobit
5954       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5955       double precision contr(maxlob,-1:1)
5956       logical mixed
5957 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5958         escloc_i=0.0D0
5959         do j=1,3
5960           dersc(j)=0.0D0
5961           if (mixed) ddersc(j)=0.0d0
5962         enddo
5963         x3=x(3)
5964
5965 C Because of periodicity of the dependence of the SC energy in omega we have
5966 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5967 C To avoid underflows, first compute & store the exponents.
5968
5969         do iii=-1,1
5970
5971           x(3)=x3+iii*dwapi
5972
5973           do j=1,nlobit
5974             do k=1,3
5975               z(k)=x(k)-censc(k,j,it)
5976             enddo
5977             do k=1,3
5978               Axk=0.0D0
5979               do l=1,3
5980                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5981               enddo
5982               Ax(k,j,iii)=Axk
5983             enddo
5984             expfac=0.0D0
5985             do k=1,3
5986               expfac=expfac+Ax(k,j,iii)*z(k)
5987             enddo
5988             contr(j,iii)=expfac
5989           enddo ! j
5990
5991         enddo ! iii
5992
5993         x(3)=x3
5994 C As in the case of ebend, we want to avoid underflows in exponentiation and
5995 C subsequent NaNs and INFs in energy calculation.
5996 C Find the largest exponent
5997         emin=contr(1,-1)
5998         do iii=-1,1
5999           do j=1,nlobit
6000             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6001           enddo
6002         enddo
6003         emin=0.5D0*emin
6004 cd      print *,'it=',it,' emin=',emin
6005
6006 C Compute the contribution to SC energy and derivatives
6007         do iii=-1,1
6008
6009           do j=1,nlobit
6010 #ifdef OSF
6011             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6012             if(adexp.ne.adexp) adexp=1.0
6013             expfac=dexp(adexp)
6014 #else
6015             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6016 #endif
6017 cd          print *,'j=',j,' expfac=',expfac
6018             escloc_i=escloc_i+expfac
6019             do k=1,3
6020               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6021             enddo
6022             if (mixed) then
6023               do k=1,3,2
6024                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6025      &            +gaussc(k,2,j,it))*expfac
6026               enddo
6027             endif
6028           enddo
6029
6030         enddo ! iii
6031
6032         dersc(1)=dersc(1)/cos(theti)**2
6033         ddersc(1)=ddersc(1)/cos(theti)**2
6034         ddersc(3)=ddersc(3)
6035
6036         escloci=-(dlog(escloc_i)-emin)
6037         do j=1,3
6038           dersc(j)=dersc(j)/escloc_i
6039         enddo
6040         if (mixed) then
6041           do j=1,3,2
6042             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6043           enddo
6044         endif
6045       return
6046       end
6047 C------------------------------------------------------------------------------
6048       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6049       implicit real*8 (a-h,o-z)
6050       include 'DIMENSIONS'
6051       include 'COMMON.GEO'
6052       include 'COMMON.LOCAL'
6053       include 'COMMON.IOUNITS'
6054       common /sccalc/ time11,time12,time112,theti,it,nlobit
6055       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6056       double precision contr(maxlob)
6057       logical mixed
6058
6059       escloc_i=0.0D0
6060
6061       do j=1,3
6062         dersc(j)=0.0D0
6063       enddo
6064
6065       do j=1,nlobit
6066         do k=1,2
6067           z(k)=x(k)-censc(k,j,it)
6068         enddo
6069         z(3)=dwapi
6070         do k=1,3
6071           Axk=0.0D0
6072           do l=1,3
6073             Axk=Axk+gaussc(l,k,j,it)*z(l)
6074           enddo
6075           Ax(k,j)=Axk
6076         enddo
6077         expfac=0.0D0
6078         do k=1,3
6079           expfac=expfac+Ax(k,j)*z(k)
6080         enddo
6081         contr(j)=expfac
6082       enddo ! j
6083
6084 C As in the case of ebend, we want to avoid underflows in exponentiation and
6085 C subsequent NaNs and INFs in energy calculation.
6086 C Find the largest exponent
6087       emin=contr(1)
6088       do j=1,nlobit
6089         if (emin.gt.contr(j)) emin=contr(j)
6090       enddo
6091       emin=0.5D0*emin
6092
6093 C Compute the contribution to SC energy and derivatives
6094
6095       dersc12=0.0d0
6096       do j=1,nlobit
6097         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6098         escloc_i=escloc_i+expfac
6099         do k=1,2
6100           dersc(k)=dersc(k)+Ax(k,j)*expfac
6101         enddo
6102         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6103      &            +gaussc(1,2,j,it))*expfac
6104         dersc(3)=0.0d0
6105       enddo
6106
6107       dersc(1)=dersc(1)/cos(theti)**2
6108       dersc12=dersc12/cos(theti)**2
6109       escloci=-(dlog(escloc_i)-emin)
6110       do j=1,2
6111         dersc(j)=dersc(j)/escloc_i
6112       enddo
6113       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6114       return
6115       end
6116 #else
6117 c----------------------------------------------------------------------------------
6118       subroutine esc(escloc)
6119 C Calculate the local energy of a side chain and its derivatives in the
6120 C corresponding virtual-bond valence angles THETA and the spherical angles
6121 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6122 C added by Urszula Kozlowska. 07/11/2007
6123 C
6124       implicit real*8 (a-h,o-z)
6125       include 'DIMENSIONS'
6126       include 'COMMON.GEO'
6127       include 'COMMON.LOCAL'
6128       include 'COMMON.VAR'
6129       include 'COMMON.SCROT'
6130       include 'COMMON.INTERACT'
6131       include 'COMMON.DERIV'
6132       include 'COMMON.CHAIN'
6133       include 'COMMON.IOUNITS'
6134       include 'COMMON.NAMES'
6135       include 'COMMON.FFIELD'
6136       include 'COMMON.CONTROL'
6137       include 'COMMON.VECTORS'
6138       double precision x_prime(3),y_prime(3),z_prime(3)
6139      &    , sumene,dsc_i,dp2_i,x(65),
6140      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6141      &    de_dxx,de_dyy,de_dzz,de_dt
6142       double precision s1_t,s1_6_t,s2_t,s2_6_t
6143       double precision
6144      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6145      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6146      & dt_dCi(3),dt_dCi1(3)
6147       common /sccalc/ time11,time12,time112,theti,it,nlobit
6148       delta=0.02d0*pi
6149       escloc=0.0D0
6150       do i=loc_start,loc_end
6151         if (itype(i).eq.ntyp1) cycle
6152         costtab(i+1) =dcos(theta(i+1))
6153         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6154         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6155         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6156         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6157         cosfac=dsqrt(cosfac2)
6158         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6159         sinfac=dsqrt(sinfac2)
6160         it=iabs(itype(i))
6161         if (it.eq.10) goto 1
6162 c
6163 C  Compute the axes of tghe local cartesian coordinates system; store in
6164 c   x_prime, y_prime and z_prime
6165 c
6166         do j=1,3
6167           x_prime(j) = 0.00
6168           y_prime(j) = 0.00
6169           z_prime(j) = 0.00
6170         enddo
6171 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6172 C     &   dc_norm(3,i+nres)
6173         do j = 1,3
6174           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6175           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6176         enddo
6177         do j = 1,3
6178           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6179         enddo
6180 c       write (2,*) "i",i
6181 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6182 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6183 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6184 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6185 c      & " xy",scalar(x_prime(1),y_prime(1)),
6186 c      & " xz",scalar(x_prime(1),z_prime(1)),
6187 c      & " yy",scalar(y_prime(1),y_prime(1)),
6188 c      & " yz",scalar(y_prime(1),z_prime(1)),
6189 c      & " zz",scalar(z_prime(1),z_prime(1))
6190 c
6191 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6192 C to local coordinate system. Store in xx, yy, zz.
6193 c
6194         xx=0.0d0
6195         yy=0.0d0
6196         zz=0.0d0
6197         do j = 1,3
6198           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6199           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6200           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6201         enddo
6202
6203         xxtab(i)=xx
6204         yytab(i)=yy
6205         zztab(i)=zz
6206 C
6207 C Compute the energy of the ith side cbain
6208 C
6209 c        write (2,*) "xx",xx," yy",yy," zz",zz
6210         it=iabs(itype(i))
6211         do j = 1,65
6212           x(j) = sc_parmin(j,it)
6213         enddo
6214 #ifdef CHECK_COORD
6215 Cc diagnostics - remove later
6216         xx1 = dcos(alph(2))
6217         yy1 = dsin(alph(2))*dcos(omeg(2))
6218         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6219         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6220      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6221      &    xx1,yy1,zz1
6222 C,"  --- ", xx_w,yy_w,zz_w
6223 c end diagnostics
6224 #endif
6225         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6226      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6227      &   + x(10)*yy*zz
6228         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6229      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6230      & + x(20)*yy*zz
6231         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6232      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6233      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6234      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6235      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6236      &  +x(40)*xx*yy*zz
6237         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6238      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6239      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6240      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6241      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6242      &  +x(60)*xx*yy*zz
6243         dsc_i   = 0.743d0+x(61)
6244         dp2_i   = 1.9d0+x(62)
6245         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6246      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6247         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6248      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6249         s1=(1+x(63))/(0.1d0 + dscp1)
6250         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6251         s2=(1+x(65))/(0.1d0 + dscp2)
6252         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6253         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6254      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6255 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6256 c     &   sumene4,
6257 c     &   dscp1,dscp2,sumene
6258 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6259         escloc = escloc + sumene
6260 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6261 c     & ,zz,xx,yy
6262 c#define DEBUG
6263 #ifdef DEBUG
6264 C
6265 C This section to check the numerical derivatives of the energy of ith side
6266 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6267 C #define DEBUG in the code to turn it on.
6268 C
6269         write (2,*) "sumene               =",sumene
6270         aincr=1.0d-7
6271         xxsave=xx
6272         xx=xx+aincr
6273         write (2,*) xx,yy,zz
6274         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6275         de_dxx_num=(sumenep-sumene)/aincr
6276         xx=xxsave
6277         write (2,*) "xx+ sumene from enesc=",sumenep
6278         yysave=yy
6279         yy=yy+aincr
6280         write (2,*) xx,yy,zz
6281         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6282         de_dyy_num=(sumenep-sumene)/aincr
6283         yy=yysave
6284         write (2,*) "yy+ sumene from enesc=",sumenep
6285         zzsave=zz
6286         zz=zz+aincr
6287         write (2,*) xx,yy,zz
6288         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6289         de_dzz_num=(sumenep-sumene)/aincr
6290         zz=zzsave
6291         write (2,*) "zz+ sumene from enesc=",sumenep
6292         costsave=cost2tab(i+1)
6293         sintsave=sint2tab(i+1)
6294         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6295         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6296         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6297         de_dt_num=(sumenep-sumene)/aincr
6298         write (2,*) " t+ sumene from enesc=",sumenep
6299         cost2tab(i+1)=costsave
6300         sint2tab(i+1)=sintsave
6301 C End of diagnostics section.
6302 #endif
6303 C
6304 C Compute the gradient of esc
6305 C
6306 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6307         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6308         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6309         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6310         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6311         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6312         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6313         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6314         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6315         pom1=(sumene3*sint2tab(i+1)+sumene1)
6316      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6317         pom2=(sumene4*cost2tab(i+1)+sumene2)
6318      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6319         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6320         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6321      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6322      &  +x(40)*yy*zz
6323         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6324         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6325      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6326      &  +x(60)*yy*zz
6327         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6328      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6329      &        +(pom1+pom2)*pom_dx
6330 #ifdef DEBUG
6331         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6332 #endif
6333 C
6334         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6335         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6336      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6337      &  +x(40)*xx*zz
6338         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6339         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6340      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6341      &  +x(59)*zz**2 +x(60)*xx*zz
6342         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6343      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6344      &        +(pom1-pom2)*pom_dy
6345 #ifdef DEBUG
6346         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6347 #endif
6348 C
6349         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6350      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6351      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6352      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6353      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6354      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6355      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6356      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6357 #ifdef DEBUG
6358         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6359 #endif
6360 C
6361         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6362      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6363      &  +pom1*pom_dt1+pom2*pom_dt2
6364 #ifdef DEBUG
6365         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6366 #endif
6367 c#undef DEBUG
6368 c
6369 C
6370        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6371        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6372        cosfac2xx=cosfac2*xx
6373        sinfac2yy=sinfac2*yy
6374        do k = 1,3
6375          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6376      &      vbld_inv(i+1)
6377          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6378      &      vbld_inv(i)
6379          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6380          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6381 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6382 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6383 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6384 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6385          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6386          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6387          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6388          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6389          dZZ_Ci1(k)=0.0d0
6390          dZZ_Ci(k)=0.0d0
6391          do j=1,3
6392            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6393      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6394            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6395      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6396          enddo
6397
6398          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6399          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6400          dZZ_XYZ(k)=vbld_inv(i+nres)*
6401      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6402 c
6403          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6404          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6405        enddo
6406
6407        do k=1,3
6408          dXX_Ctab(k,i)=dXX_Ci(k)
6409          dXX_C1tab(k,i)=dXX_Ci1(k)
6410          dYY_Ctab(k,i)=dYY_Ci(k)
6411          dYY_C1tab(k,i)=dYY_Ci1(k)
6412          dZZ_Ctab(k,i)=dZZ_Ci(k)
6413          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6414          dXX_XYZtab(k,i)=dXX_XYZ(k)
6415          dYY_XYZtab(k,i)=dYY_XYZ(k)
6416          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6417        enddo
6418
6419        do k = 1,3
6420 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6421 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6422 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6423 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6424 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6425 c     &    dt_dci(k)
6426 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6427 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6428          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6429      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6430          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6431      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6432          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6433      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6434        enddo
6435 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6436 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6437
6438 C to check gradient call subroutine check_grad
6439
6440     1 continue
6441       enddo
6442       return
6443       end
6444 c------------------------------------------------------------------------------
6445       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6446       implicit none
6447       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6448      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6449       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6450      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6451      &   + x(10)*yy*zz
6452       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6453      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6454      & + x(20)*yy*zz
6455       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6456      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6457      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6458      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6459      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6460      &  +x(40)*xx*yy*zz
6461       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6462      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6463      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6464      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6465      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6466      &  +x(60)*xx*yy*zz
6467       dsc_i   = 0.743d0+x(61)
6468       dp2_i   = 1.9d0+x(62)
6469       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6470      &          *(xx*cost2+yy*sint2))
6471       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6472      &          *(xx*cost2-yy*sint2))
6473       s1=(1+x(63))/(0.1d0 + dscp1)
6474       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6475       s2=(1+x(65))/(0.1d0 + dscp2)
6476       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6477       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6478      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6479       enesc=sumene
6480       return
6481       end
6482 #endif
6483 c------------------------------------------------------------------------------
6484       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6485 C
6486 C This procedure calculates two-body contact function g(rij) and its derivative:
6487 C
6488 C           eps0ij                                     !       x < -1
6489 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6490 C            0                                         !       x > 1
6491 C
6492 C where x=(rij-r0ij)/delta
6493 C
6494 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6495 C
6496       implicit none
6497       double precision rij,r0ij,eps0ij,fcont,fprimcont
6498       double precision x,x2,x4,delta
6499 c     delta=0.02D0*r0ij
6500 c      delta=0.2D0*r0ij
6501       x=(rij-r0ij)/delta
6502       if (x.lt.-1.0D0) then
6503         fcont=eps0ij
6504         fprimcont=0.0D0
6505       else if (x.le.1.0D0) then
6506         x2=x*x
6507         x4=x2*x2
6508         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6509         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6510       else
6511         fcont=0.0D0
6512         fprimcont=0.0D0
6513       endif
6514       return
6515       end
6516 c------------------------------------------------------------------------------
6517       subroutine splinthet(theti,delta,ss,ssder)
6518       implicit real*8 (a-h,o-z)
6519       include 'DIMENSIONS'
6520       include 'COMMON.VAR'
6521       include 'COMMON.GEO'
6522       thetup=pi-delta
6523       thetlow=delta
6524       if (theti.gt.pipol) then
6525         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6526       else
6527         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6528         ssder=-ssder
6529       endif
6530       return
6531       end
6532 c------------------------------------------------------------------------------
6533       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6534       implicit none
6535       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6536       double precision ksi,ksi2,ksi3,a1,a2,a3
6537       a1=fprim0*delta/(f1-f0)
6538       a2=3.0d0-2.0d0*a1
6539       a3=a1-2.0d0
6540       ksi=(x-x0)/delta
6541       ksi2=ksi*ksi
6542       ksi3=ksi2*ksi
6543       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6544       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6545       return
6546       end
6547 c------------------------------------------------------------------------------
6548       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6549       implicit none
6550       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6551       double precision ksi,ksi2,ksi3,a1,a2,a3
6552       ksi=(x-x0)/delta
6553       ksi2=ksi*ksi
6554       ksi3=ksi2*ksi
6555       a1=fprim0x*delta
6556       a2=3*(f1x-f0x)-2*fprim0x*delta
6557       a3=fprim0x*delta-2*(f1x-f0x)
6558       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6559       return
6560       end
6561 C-----------------------------------------------------------------------------
6562 #ifdef CRYST_TOR
6563 C-----------------------------------------------------------------------------
6564       subroutine etor(etors,edihcnstr)
6565       implicit real*8 (a-h,o-z)
6566       include 'DIMENSIONS'
6567       include 'COMMON.VAR'
6568       include 'COMMON.GEO'
6569       include 'COMMON.LOCAL'
6570       include 'COMMON.TORSION'
6571       include 'COMMON.INTERACT'
6572       include 'COMMON.DERIV'
6573       include 'COMMON.CHAIN'
6574       include 'COMMON.NAMES'
6575       include 'COMMON.IOUNITS'
6576       include 'COMMON.FFIELD'
6577       include 'COMMON.TORCNSTR'
6578       include 'COMMON.CONTROL'
6579       logical lprn
6580 C Set lprn=.true. for debugging
6581       lprn=.false.
6582 c      lprn=.true.
6583       etors=0.0D0
6584       do i=iphi_start,iphi_end
6585       etors_ii=0.0D0
6586         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6587      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6588         itori=itortyp(itype(i-2))
6589         itori1=itortyp(itype(i-1))
6590         phii=phi(i)
6591         gloci=0.0D0
6592 C Proline-Proline pair is a special case...
6593         if (itori.eq.3 .and. itori1.eq.3) then
6594           if (phii.gt.-dwapi3) then
6595             cosphi=dcos(3*phii)
6596             fac=1.0D0/(1.0D0-cosphi)
6597             etorsi=v1(1,3,3)*fac
6598             etorsi=etorsi+etorsi
6599             etors=etors+etorsi-v1(1,3,3)
6600             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6601             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6602           endif
6603           do j=1,3
6604             v1ij=v1(j+1,itori,itori1)
6605             v2ij=v2(j+1,itori,itori1)
6606             cosphi=dcos(j*phii)
6607             sinphi=dsin(j*phii)
6608             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6609             if (energy_dec) etors_ii=etors_ii+
6610      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6611             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6612           enddo
6613         else
6614           do j=1,nterm_old
6615             v1ij=v1(j,itori,itori1)
6616             v2ij=v2(j,itori,itori1)
6617             cosphi=dcos(j*phii)
6618             sinphi=dsin(j*phii)
6619             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6620             if (energy_dec) etors_ii=etors_ii+
6621      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6622             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6623           enddo
6624         endif
6625         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6626              'etor',i,etors_ii
6627         if (lprn)
6628      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6629      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6630      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6631         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6632 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6633       enddo
6634 ! 6/20/98 - dihedral angle constraints
6635       edihcnstr=0.0d0
6636       do i=1,ndih_constr
6637         itori=idih_constr(i)
6638         phii=phi(itori)
6639         difi=phii-phi0(i)
6640         if (difi.gt.drange(i)) then
6641           difi=difi-drange(i)
6642           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6643           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6644         else if (difi.lt.-drange(i)) then
6645           difi=difi+drange(i)
6646           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6647           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6648         endif
6649 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6650 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6651       enddo
6652 !      write (iout,*) 'edihcnstr',edihcnstr
6653       return
6654       end
6655 c------------------------------------------------------------------------------
6656       subroutine etor_d(etors_d)
6657       etors_d=0.0d0
6658       return
6659       end
6660 c----------------------------------------------------------------------------
6661 #else
6662       subroutine etor(etors,edihcnstr)
6663       implicit real*8 (a-h,o-z)
6664       include 'DIMENSIONS'
6665       include 'COMMON.VAR'
6666       include 'COMMON.GEO'
6667       include 'COMMON.LOCAL'
6668       include 'COMMON.TORSION'
6669       include 'COMMON.INTERACT'
6670       include 'COMMON.DERIV'
6671       include 'COMMON.CHAIN'
6672       include 'COMMON.NAMES'
6673       include 'COMMON.IOUNITS'
6674       include 'COMMON.FFIELD'
6675       include 'COMMON.TORCNSTR'
6676       include 'COMMON.CONTROL'
6677       logical lprn
6678 C Set lprn=.true. for debugging
6679       lprn=.false.
6680 c     lprn=.true.
6681       etors=0.0D0
6682       do i=iphi_start,iphi_end
6683 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6684 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6685 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6686 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6687         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6688      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6689 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6690 C For introducing the NH3+ and COO- group please check the etor_d for reference
6691 C and guidance
6692         etors_ii=0.0D0
6693          if (iabs(itype(i)).eq.20) then
6694          iblock=2
6695          else
6696          iblock=1
6697          endif
6698         itori=itortyp(itype(i-2))
6699         itori1=itortyp(itype(i-1))
6700         phii=phi(i)
6701         gloci=0.0D0
6702 C Regular cosine and sine terms
6703         do j=1,nterm(itori,itori1,iblock)
6704           v1ij=v1(j,itori,itori1,iblock)
6705           v2ij=v2(j,itori,itori1,iblock)
6706           cosphi=dcos(j*phii)
6707           sinphi=dsin(j*phii)
6708           etors=etors+v1ij*cosphi+v2ij*sinphi
6709           if (energy_dec) etors_ii=etors_ii+
6710      &                v1ij*cosphi+v2ij*sinphi
6711           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6712         enddo
6713 C Lorentz terms
6714 C                         v1
6715 C  E = SUM ----------------------------------- - v1
6716 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6717 C
6718         cosphi=dcos(0.5d0*phii)
6719         sinphi=dsin(0.5d0*phii)
6720         do j=1,nlor(itori,itori1,iblock)
6721           vl1ij=vlor1(j,itori,itori1)
6722           vl2ij=vlor2(j,itori,itori1)
6723           vl3ij=vlor3(j,itori,itori1)
6724           pom=vl2ij*cosphi+vl3ij*sinphi
6725           pom1=1.0d0/(pom*pom+1.0d0)
6726           etors=etors+vl1ij*pom1
6727           if (energy_dec) etors_ii=etors_ii+
6728      &                vl1ij*pom1
6729           pom=-pom*pom1*pom1
6730           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6731         enddo
6732 C Subtract the constant term
6733         etors=etors-v0(itori,itori1,iblock)
6734           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6735      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6736         if (lprn)
6737      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6738      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6739      &  (v1(j,itori,itori1,iblock),j=1,6),
6740      &  (v2(j,itori,itori1,iblock),j=1,6)
6741         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6742 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6743       enddo
6744 ! 6/20/98 - dihedral angle constraints
6745       edihcnstr=0.0d0
6746 c      do i=1,ndih_constr
6747       do i=idihconstr_start,idihconstr_end
6748         itori=idih_constr(i)
6749         phii=phi(itori)
6750         difi=pinorm(phii-phi0(i))
6751         if (difi.gt.drange(i)) then
6752           difi=difi-drange(i)
6753           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6754           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6755         else if (difi.lt.-drange(i)) then
6756           difi=difi+drange(i)
6757           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6758           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6759         else
6760           difi=0.0
6761         endif
6762 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6763 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6764 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6765       enddo
6766 cd       write (iout,*) 'edihcnstr',edihcnstr
6767       return
6768       end
6769 c----------------------------------------------------------------------------
6770       subroutine etor_d(etors_d)
6771 C 6/23/01 Compute double torsional energy
6772       implicit real*8 (a-h,o-z)
6773       include 'DIMENSIONS'
6774       include 'COMMON.VAR'
6775       include 'COMMON.GEO'
6776       include 'COMMON.LOCAL'
6777       include 'COMMON.TORSION'
6778       include 'COMMON.INTERACT'
6779       include 'COMMON.DERIV'
6780       include 'COMMON.CHAIN'
6781       include 'COMMON.NAMES'
6782       include 'COMMON.IOUNITS'
6783       include 'COMMON.FFIELD'
6784       include 'COMMON.TORCNSTR'
6785       logical lprn
6786 C Set lprn=.true. for debugging
6787       lprn=.false.
6788 c     lprn=.true.
6789       etors_d=0.0D0
6790 c      write(iout,*) "a tu??"
6791       do i=iphid_start,iphid_end
6792 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6793 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6794 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6795 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6796 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6797          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6798      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6799      &  (itype(i+1).eq.ntyp1)) cycle
6800 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6801         itori=itortyp(itype(i-2))
6802         itori1=itortyp(itype(i-1))
6803         itori2=itortyp(itype(i))
6804         phii=phi(i)
6805         phii1=phi(i+1)
6806         gloci1=0.0D0
6807         gloci2=0.0D0
6808         iblock=1
6809         if (iabs(itype(i+1)).eq.20) iblock=2
6810 C Iblock=2 Proline type
6811 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6812 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6813 C        if (itype(i+1).eq.ntyp1) iblock=3
6814 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6815 C IS or IS NOT need for this
6816 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6817 C        is (itype(i-3).eq.ntyp1) ntblock=2
6818 C        ntblock is N-terminal blocking group
6819
6820 C Regular cosine and sine terms
6821         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6822 C Example of changes for NH3+ blocking group
6823 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6824 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6825           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6826           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6827           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6828           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6829           cosphi1=dcos(j*phii)
6830           sinphi1=dsin(j*phii)
6831           cosphi2=dcos(j*phii1)
6832           sinphi2=dsin(j*phii1)
6833           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6834      &     v2cij*cosphi2+v2sij*sinphi2
6835           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6836           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6837         enddo
6838         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6839           do l=1,k-1
6840             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6841             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6842             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6843             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6844             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6845             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6846             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6847             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6848             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6849      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6850             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6851      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6852             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6853      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6854           enddo
6855         enddo
6856         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6857         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6858       enddo
6859       return
6860       end
6861 #endif
6862 c------------------------------------------------------------------------------
6863       subroutine eback_sc_corr(esccor)
6864 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6865 c        conformational states; temporarily implemented as differences
6866 c        between UNRES torsional potentials (dependent on three types of
6867 c        residues) and the torsional potentials dependent on all 20 types
6868 c        of residues computed from AM1  energy surfaces of terminally-blocked
6869 c        amino-acid residues.
6870       implicit real*8 (a-h,o-z)
6871       include 'DIMENSIONS'
6872       include 'COMMON.VAR'
6873       include 'COMMON.GEO'
6874       include 'COMMON.LOCAL'
6875       include 'COMMON.TORSION'
6876       include 'COMMON.SCCOR'
6877       include 'COMMON.INTERACT'
6878       include 'COMMON.DERIV'
6879       include 'COMMON.CHAIN'
6880       include 'COMMON.NAMES'
6881       include 'COMMON.IOUNITS'
6882       include 'COMMON.FFIELD'
6883       include 'COMMON.CONTROL'
6884       logical lprn
6885 C Set lprn=.true. for debugging
6886       lprn=.false.
6887 c      lprn=.true.
6888 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6889       esccor=0.0D0
6890       do i=itau_start,itau_end
6891         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6892         esccor_ii=0.0D0
6893         isccori=isccortyp(itype(i-2))
6894         isccori1=isccortyp(itype(i-1))
6895 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6896         phii=phi(i)
6897         do intertyp=1,3 !intertyp
6898 cc Added 09 May 2012 (Adasko)
6899 cc  Intertyp means interaction type of backbone mainchain correlation:
6900 c   1 = SC...Ca...Ca...Ca
6901 c   2 = Ca...Ca...Ca...SC
6902 c   3 = SC...Ca...Ca...SCi
6903         gloci=0.0D0
6904         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6905      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6906      &      (itype(i-1).eq.ntyp1)))
6907      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6908      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6909      &     .or.(itype(i).eq.ntyp1)))
6910      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6911      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6912      &      (itype(i-3).eq.ntyp1)))) cycle
6913         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6914         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6915      & cycle
6916        do j=1,nterm_sccor(isccori,isccori1)
6917           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6918           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6919           cosphi=dcos(j*tauangle(intertyp,i))
6920           sinphi=dsin(j*tauangle(intertyp,i))
6921           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6922           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6923         enddo
6924 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6925         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6926         if (lprn)
6927      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6928      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6929      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6930      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6931         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6932        enddo !intertyp
6933       enddo
6934
6935       return
6936       end
6937 c----------------------------------------------------------------------------
6938       subroutine multibody(ecorr)
6939 C This subroutine calculates multi-body contributions to energy following
6940 C the idea of Skolnick et al. If side chains I and J make a contact and
6941 C at the same time side chains I+1 and J+1 make a contact, an extra
6942 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6943       implicit real*8 (a-h,o-z)
6944       include 'DIMENSIONS'
6945       include 'COMMON.IOUNITS'
6946       include 'COMMON.DERIV'
6947       include 'COMMON.INTERACT'
6948       include 'COMMON.CONTACTS'
6949       double precision gx(3),gx1(3)
6950       logical lprn
6951
6952 C Set lprn=.true. for debugging
6953       lprn=.false.
6954
6955       if (lprn) then
6956         write (iout,'(a)') 'Contact function values:'
6957         do i=nnt,nct-2
6958           write (iout,'(i2,20(1x,i2,f10.5))')
6959      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6960         enddo
6961       endif
6962       ecorr=0.0D0
6963       do i=nnt,nct
6964         do j=1,3
6965           gradcorr(j,i)=0.0D0
6966           gradxorr(j,i)=0.0D0
6967         enddo
6968       enddo
6969       do i=nnt,nct-2
6970
6971         DO ISHIFT = 3,4
6972
6973         i1=i+ishift
6974         num_conti=num_cont(i)
6975         num_conti1=num_cont(i1)
6976         do jj=1,num_conti
6977           j=jcont(jj,i)
6978           do kk=1,num_conti1
6979             j1=jcont(kk,i1)
6980             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6981 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6982 cd   &                   ' ishift=',ishift
6983 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6984 C The system gains extra energy.
6985               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6986             endif   ! j1==j+-ishift
6987           enddo     ! kk
6988         enddo       ! jj
6989
6990         ENDDO ! ISHIFT
6991
6992       enddo         ! i
6993       return
6994       end
6995 c------------------------------------------------------------------------------
6996       double precision function esccorr(i,j,k,l,jj,kk)
6997       implicit real*8 (a-h,o-z)
6998       include 'DIMENSIONS'
6999       include 'COMMON.IOUNITS'
7000       include 'COMMON.DERIV'
7001       include 'COMMON.INTERACT'
7002       include 'COMMON.CONTACTS'
7003       double precision gx(3),gx1(3)
7004       logical lprn
7005       lprn=.false.
7006       eij=facont(jj,i)
7007       ekl=facont(kk,k)
7008 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7009 C Calculate the multi-body contribution to energy.
7010 C Calculate multi-body contributions to the gradient.
7011 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7012 cd   & k,l,(gacont(m,kk,k),m=1,3)
7013       do m=1,3
7014         gx(m) =ekl*gacont(m,jj,i)
7015         gx1(m)=eij*gacont(m,kk,k)
7016         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7017         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7018         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7019         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7020       enddo
7021       do m=i,j-1
7022         do ll=1,3
7023           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7024         enddo
7025       enddo
7026       do m=k,l-1
7027         do ll=1,3
7028           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7029         enddo
7030       enddo
7031       esccorr=-eij*ekl
7032       return
7033       end
7034 c------------------------------------------------------------------------------
7035       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7036 C This subroutine calculates multi-body contributions to hydrogen-bonding
7037       implicit real*8 (a-h,o-z)
7038       include 'DIMENSIONS'
7039       include 'COMMON.IOUNITS'
7040 #ifdef MPI
7041       include "mpif.h"
7042       parameter (max_cont=maxconts)
7043       parameter (max_dim=26)
7044       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7045       double precision zapas(max_dim,maxconts,max_fg_procs),
7046      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7047       common /przechowalnia/ zapas
7048       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7049      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7050 #endif
7051       include 'COMMON.SETUP'
7052       include 'COMMON.FFIELD'
7053       include 'COMMON.DERIV'
7054       include 'COMMON.INTERACT'
7055       include 'COMMON.CONTACTS'
7056       include 'COMMON.CONTROL'
7057       include 'COMMON.LOCAL'
7058       double precision gx(3),gx1(3),time00
7059       logical lprn,ldone
7060
7061 C Set lprn=.true. for debugging
7062       lprn=.false.
7063 #ifdef MPI
7064       n_corr=0
7065       n_corr1=0
7066       if (nfgtasks.le.1) goto 30
7067       if (lprn) then
7068         write (iout,'(a)') 'Contact function values before RECEIVE:'
7069         do i=nnt,nct-2
7070           write (iout,'(2i3,50(1x,i2,f5.2))')
7071      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7072      &    j=1,num_cont_hb(i))
7073         enddo
7074       endif
7075       call flush(iout)
7076       do i=1,ntask_cont_from
7077         ncont_recv(i)=0
7078       enddo
7079       do i=1,ntask_cont_to
7080         ncont_sent(i)=0
7081       enddo
7082 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7083 c     & ntask_cont_to
7084 C Make the list of contacts to send to send to other procesors
7085 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7086 c      call flush(iout)
7087       do i=iturn3_start,iturn3_end
7088 c        write (iout,*) "make contact list turn3",i," num_cont",
7089 c     &    num_cont_hb(i)
7090         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7091       enddo
7092       do i=iturn4_start,iturn4_end
7093 c        write (iout,*) "make contact list turn4",i," num_cont",
7094 c     &   num_cont_hb(i)
7095         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7096       enddo
7097       do ii=1,nat_sent
7098         i=iat_sent(ii)
7099 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7100 c     &    num_cont_hb(i)
7101         do j=1,num_cont_hb(i)
7102         do k=1,4
7103           jjc=jcont_hb(j,i)
7104           iproc=iint_sent_local(k,jjc,ii)
7105 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7106           if (iproc.gt.0) then
7107             ncont_sent(iproc)=ncont_sent(iproc)+1
7108             nn=ncont_sent(iproc)
7109             zapas(1,nn,iproc)=i
7110             zapas(2,nn,iproc)=jjc
7111             zapas(3,nn,iproc)=facont_hb(j,i)
7112             zapas(4,nn,iproc)=ees0p(j,i)
7113             zapas(5,nn,iproc)=ees0m(j,i)
7114             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7115             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7116             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7117             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7118             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7119             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7120             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7121             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7122             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7123             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7124             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7125             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7126             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7127             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7128             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7129             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7130             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7131             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7132             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7133             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7134             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7135           endif
7136         enddo
7137         enddo
7138       enddo
7139       if (lprn) then
7140       write (iout,*)
7141      &  "Numbers of contacts to be sent to other processors",
7142      &  (ncont_sent(i),i=1,ntask_cont_to)
7143       write (iout,*) "Contacts sent"
7144       do ii=1,ntask_cont_to
7145         nn=ncont_sent(ii)
7146         iproc=itask_cont_to(ii)
7147         write (iout,*) nn," contacts to processor",iproc,
7148      &   " of CONT_TO_COMM group"
7149         do i=1,nn
7150           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7151         enddo
7152       enddo
7153       call flush(iout)
7154       endif
7155       CorrelType=477
7156       CorrelID=fg_rank+1
7157       CorrelType1=478
7158       CorrelID1=nfgtasks+fg_rank+1
7159       ireq=0
7160 C Receive the numbers of needed contacts from other processors
7161       do ii=1,ntask_cont_from
7162         iproc=itask_cont_from(ii)
7163         ireq=ireq+1
7164         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7165      &    FG_COMM,req(ireq),IERR)
7166       enddo
7167 c      write (iout,*) "IRECV ended"
7168 c      call flush(iout)
7169 C Send the number of contacts needed by other processors
7170       do ii=1,ntask_cont_to
7171         iproc=itask_cont_to(ii)
7172         ireq=ireq+1
7173         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7174      &    FG_COMM,req(ireq),IERR)
7175       enddo
7176 c      write (iout,*) "ISEND ended"
7177 c      write (iout,*) "number of requests (nn)",ireq
7178       call flush(iout)
7179       if (ireq.gt.0)
7180      &  call MPI_Waitall(ireq,req,status_array,ierr)
7181 c      write (iout,*)
7182 c     &  "Numbers of contacts to be received from other processors",
7183 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7184 c      call flush(iout)
7185 C Receive contacts
7186       ireq=0
7187       do ii=1,ntask_cont_from
7188         iproc=itask_cont_from(ii)
7189         nn=ncont_recv(ii)
7190 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7191 c     &   " of CONT_TO_COMM group"
7192         call flush(iout)
7193         if (nn.gt.0) then
7194           ireq=ireq+1
7195           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7196      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7197 c          write (iout,*) "ireq,req",ireq,req(ireq)
7198         endif
7199       enddo
7200 C Send the contacts to processors that need them
7201       do ii=1,ntask_cont_to
7202         iproc=itask_cont_to(ii)
7203         nn=ncont_sent(ii)
7204 c        write (iout,*) nn," contacts to processor",iproc,
7205 c     &   " of CONT_TO_COMM group"
7206         if (nn.gt.0) then
7207           ireq=ireq+1
7208           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7209      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7210 c          write (iout,*) "ireq,req",ireq,req(ireq)
7211 c          do i=1,nn
7212 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7213 c          enddo
7214         endif
7215       enddo
7216 c      write (iout,*) "number of requests (contacts)",ireq
7217 c      write (iout,*) "req",(req(i),i=1,4)
7218 c      call flush(iout)
7219       if (ireq.gt.0)
7220      & call MPI_Waitall(ireq,req,status_array,ierr)
7221       do iii=1,ntask_cont_from
7222         iproc=itask_cont_from(iii)
7223         nn=ncont_recv(iii)
7224         if (lprn) then
7225         write (iout,*) "Received",nn," contacts from processor",iproc,
7226      &   " of CONT_FROM_COMM group"
7227         call flush(iout)
7228         do i=1,nn
7229           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7230         enddo
7231         call flush(iout)
7232         endif
7233         do i=1,nn
7234           ii=zapas_recv(1,i,iii)
7235 c Flag the received contacts to prevent double-counting
7236           jj=-zapas_recv(2,i,iii)
7237 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7238 c          call flush(iout)
7239           nnn=num_cont_hb(ii)+1
7240           num_cont_hb(ii)=nnn
7241           jcont_hb(nnn,ii)=jj
7242           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7243           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7244           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7245           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7246           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7247           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7248           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7249           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7250           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7251           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7252           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7253           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7254           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7255           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7256           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7257           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7258           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7259           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7260           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7261           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7262           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7263           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7264           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7265           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7266         enddo
7267       enddo
7268       call flush(iout)
7269       if (lprn) then
7270         write (iout,'(a)') 'Contact function values after receive:'
7271         do i=nnt,nct-2
7272           write (iout,'(2i3,50(1x,i3,f5.2))')
7273      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7274      &    j=1,num_cont_hb(i))
7275         enddo
7276         call flush(iout)
7277       endif
7278    30 continue
7279 #endif
7280       if (lprn) then
7281         write (iout,'(a)') 'Contact function values:'
7282         do i=nnt,nct-2
7283           write (iout,'(2i3,50(1x,i3,f5.2))')
7284      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7285      &    j=1,num_cont_hb(i))
7286         enddo
7287       endif
7288       ecorr=0.0D0
7289 C Remove the loop below after debugging !!!
7290       do i=nnt,nct
7291         do j=1,3
7292           gradcorr(j,i)=0.0D0
7293           gradxorr(j,i)=0.0D0
7294         enddo
7295       enddo
7296 C Calculate the local-electrostatic correlation terms
7297       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7298         i1=i+1
7299         num_conti=num_cont_hb(i)
7300         num_conti1=num_cont_hb(i+1)
7301         do jj=1,num_conti
7302           j=jcont_hb(jj,i)
7303           jp=iabs(j)
7304           do kk=1,num_conti1
7305             j1=jcont_hb(kk,i1)
7306             jp1=iabs(j1)
7307 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7308 c     &         ' jj=',jj,' kk=',kk
7309             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7310      &          .or. j.lt.0 .and. j1.gt.0) .and.
7311      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7312 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7313 C The system gains extra energy.
7314               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7315               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7316      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7317               n_corr=n_corr+1
7318             else if (j1.eq.j) then
7319 C Contacts I-J and I-(J+1) occur simultaneously.
7320 C The system loses extra energy.
7321 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7322             endif
7323           enddo ! kk
7324           do kk=1,num_conti
7325             j1=jcont_hb(kk,i)
7326 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7327 c    &         ' jj=',jj,' kk=',kk
7328             if (j1.eq.j+1) then
7329 C Contacts I-J and (I+1)-J occur simultaneously.
7330 C The system loses extra energy.
7331 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7332             endif ! j1==j+1
7333           enddo ! kk
7334         enddo ! jj
7335       enddo ! i
7336       return
7337       end
7338 c------------------------------------------------------------------------------
7339       subroutine add_hb_contact(ii,jj,itask)
7340       implicit real*8 (a-h,o-z)
7341       include "DIMENSIONS"
7342       include "COMMON.IOUNITS"
7343       integer max_cont
7344       integer max_dim
7345       parameter (max_cont=maxconts)
7346       parameter (max_dim=26)
7347       include "COMMON.CONTACTS"
7348       double precision zapas(max_dim,maxconts,max_fg_procs),
7349      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7350       common /przechowalnia/ zapas
7351       integer i,j,ii,jj,iproc,itask(4),nn
7352 c      write (iout,*) "itask",itask
7353       do i=1,2
7354         iproc=itask(i)
7355         if (iproc.gt.0) then
7356           do j=1,num_cont_hb(ii)
7357             jjc=jcont_hb(j,ii)
7358 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7359             if (jjc.eq.jj) then
7360               ncont_sent(iproc)=ncont_sent(iproc)+1
7361               nn=ncont_sent(iproc)
7362               zapas(1,nn,iproc)=ii
7363               zapas(2,nn,iproc)=jjc
7364               zapas(3,nn,iproc)=facont_hb(j,ii)
7365               zapas(4,nn,iproc)=ees0p(j,ii)
7366               zapas(5,nn,iproc)=ees0m(j,ii)
7367               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7368               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7369               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7370               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7371               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7372               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7373               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7374               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7375               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7376               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7377               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7378               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7379               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7380               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7381               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7382               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7383               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7384               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7385               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7386               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7387               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7388               exit
7389             endif
7390           enddo
7391         endif
7392       enddo
7393       return
7394       end
7395 c------------------------------------------------------------------------------
7396       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7397      &  n_corr1)
7398 C This subroutine calculates multi-body contributions to hydrogen-bonding
7399       implicit real*8 (a-h,o-z)
7400       include 'DIMENSIONS'
7401       include 'COMMON.IOUNITS'
7402 #ifdef MPI
7403       include "mpif.h"
7404       parameter (max_cont=maxconts)
7405       parameter (max_dim=70)
7406       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7407       double precision zapas(max_dim,maxconts,max_fg_procs),
7408      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7409       common /przechowalnia/ zapas
7410       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7411      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7412 #endif
7413       include 'COMMON.SETUP'
7414       include 'COMMON.FFIELD'
7415       include 'COMMON.DERIV'
7416       include 'COMMON.LOCAL'
7417       include 'COMMON.INTERACT'
7418       include 'COMMON.CONTACTS'
7419       include 'COMMON.CHAIN'
7420       include 'COMMON.CONTROL'
7421       double precision gx(3),gx1(3)
7422       integer num_cont_hb_old(maxres)
7423       logical lprn,ldone
7424       double precision eello4,eello5,eelo6,eello_turn6
7425       external eello4,eello5,eello6,eello_turn6
7426 C Set lprn=.true. for debugging
7427       lprn=.false.
7428       eturn6=0.0d0
7429 #ifdef MPI
7430       do i=1,nres
7431         num_cont_hb_old(i)=num_cont_hb(i)
7432       enddo
7433       n_corr=0
7434       n_corr1=0
7435       if (nfgtasks.le.1) goto 30
7436       if (lprn) then
7437         write (iout,'(a)') 'Contact function values before RECEIVE:'
7438         do i=nnt,nct-2
7439           write (iout,'(2i3,50(1x,i2,f5.2))')
7440      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7441      &    j=1,num_cont_hb(i))
7442         enddo
7443       endif
7444       call flush(iout)
7445       do i=1,ntask_cont_from
7446         ncont_recv(i)=0
7447       enddo
7448       do i=1,ntask_cont_to
7449         ncont_sent(i)=0
7450       enddo
7451 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7452 c     & ntask_cont_to
7453 C Make the list of contacts to send to send to other procesors
7454       do i=iturn3_start,iturn3_end
7455 c        write (iout,*) "make contact list turn3",i," num_cont",
7456 c     &    num_cont_hb(i)
7457         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7458       enddo
7459       do i=iturn4_start,iturn4_end
7460 c        write (iout,*) "make contact list turn4",i," num_cont",
7461 c     &   num_cont_hb(i)
7462         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7463       enddo
7464       do ii=1,nat_sent
7465         i=iat_sent(ii)
7466 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7467 c     &    num_cont_hb(i)
7468         do j=1,num_cont_hb(i)
7469         do k=1,4
7470           jjc=jcont_hb(j,i)
7471           iproc=iint_sent_local(k,jjc,ii)
7472 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7473           if (iproc.ne.0) then
7474             ncont_sent(iproc)=ncont_sent(iproc)+1
7475             nn=ncont_sent(iproc)
7476             zapas(1,nn,iproc)=i
7477             zapas(2,nn,iproc)=jjc
7478             zapas(3,nn,iproc)=d_cont(j,i)
7479             ind=3
7480             do kk=1,3
7481               ind=ind+1
7482               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7483             enddo
7484             do kk=1,2
7485               do ll=1,2
7486                 ind=ind+1
7487                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7488               enddo
7489             enddo
7490             do jj=1,5
7491               do kk=1,3
7492                 do ll=1,2
7493                   do mm=1,2
7494                     ind=ind+1
7495                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7496                   enddo
7497                 enddo
7498               enddo
7499             enddo
7500           endif
7501         enddo
7502         enddo
7503       enddo
7504       if (lprn) then
7505       write (iout,*)
7506      &  "Numbers of contacts to be sent to other processors",
7507      &  (ncont_sent(i),i=1,ntask_cont_to)
7508       write (iout,*) "Contacts sent"
7509       do ii=1,ntask_cont_to
7510         nn=ncont_sent(ii)
7511         iproc=itask_cont_to(ii)
7512         write (iout,*) nn," contacts to processor",iproc,
7513      &   " of CONT_TO_COMM group"
7514         do i=1,nn
7515           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7516         enddo
7517       enddo
7518       call flush(iout)
7519       endif
7520       CorrelType=477
7521       CorrelID=fg_rank+1
7522       CorrelType1=478
7523       CorrelID1=nfgtasks+fg_rank+1
7524       ireq=0
7525 C Receive the numbers of needed contacts from other processors
7526       do ii=1,ntask_cont_from
7527         iproc=itask_cont_from(ii)
7528         ireq=ireq+1
7529         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7530      &    FG_COMM,req(ireq),IERR)
7531       enddo
7532 c      write (iout,*) "IRECV ended"
7533 c      call flush(iout)
7534 C Send the number of contacts needed by other processors
7535       do ii=1,ntask_cont_to
7536         iproc=itask_cont_to(ii)
7537         ireq=ireq+1
7538         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7539      &    FG_COMM,req(ireq),IERR)
7540       enddo
7541 c      write (iout,*) "ISEND ended"
7542 c      write (iout,*) "number of requests (nn)",ireq
7543       call flush(iout)
7544       if (ireq.gt.0)
7545      &  call MPI_Waitall(ireq,req,status_array,ierr)
7546 c      write (iout,*)
7547 c     &  "Numbers of contacts to be received from other processors",
7548 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7549 c      call flush(iout)
7550 C Receive contacts
7551       ireq=0
7552       do ii=1,ntask_cont_from
7553         iproc=itask_cont_from(ii)
7554         nn=ncont_recv(ii)
7555 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7556 c     &   " of CONT_TO_COMM group"
7557         call flush(iout)
7558         if (nn.gt.0) then
7559           ireq=ireq+1
7560           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7561      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7562 c          write (iout,*) "ireq,req",ireq,req(ireq)
7563         endif
7564       enddo
7565 C Send the contacts to processors that need them
7566       do ii=1,ntask_cont_to
7567         iproc=itask_cont_to(ii)
7568         nn=ncont_sent(ii)
7569 c        write (iout,*) nn," contacts to processor",iproc,
7570 c     &   " of CONT_TO_COMM group"
7571         if (nn.gt.0) then
7572           ireq=ireq+1
7573           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7574      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7575 c          write (iout,*) "ireq,req",ireq,req(ireq)
7576 c          do i=1,nn
7577 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7578 c          enddo
7579         endif
7580       enddo
7581 c      write (iout,*) "number of requests (contacts)",ireq
7582 c      write (iout,*) "req",(req(i),i=1,4)
7583 c      call flush(iout)
7584       if (ireq.gt.0)
7585      & call MPI_Waitall(ireq,req,status_array,ierr)
7586       do iii=1,ntask_cont_from
7587         iproc=itask_cont_from(iii)
7588         nn=ncont_recv(iii)
7589         if (lprn) then
7590         write (iout,*) "Received",nn," contacts from processor",iproc,
7591      &   " of CONT_FROM_COMM group"
7592         call flush(iout)
7593         do i=1,nn
7594           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7595         enddo
7596         call flush(iout)
7597         endif
7598         do i=1,nn
7599           ii=zapas_recv(1,i,iii)
7600 c Flag the received contacts to prevent double-counting
7601           jj=-zapas_recv(2,i,iii)
7602 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7603 c          call flush(iout)
7604           nnn=num_cont_hb(ii)+1
7605           num_cont_hb(ii)=nnn
7606           jcont_hb(nnn,ii)=jj
7607           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7608           ind=3
7609           do kk=1,3
7610             ind=ind+1
7611             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7612           enddo
7613           do kk=1,2
7614             do ll=1,2
7615               ind=ind+1
7616               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7617             enddo
7618           enddo
7619           do jj=1,5
7620             do kk=1,3
7621               do ll=1,2
7622                 do mm=1,2
7623                   ind=ind+1
7624                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7625                 enddo
7626               enddo
7627             enddo
7628           enddo
7629         enddo
7630       enddo
7631       call flush(iout)
7632       if (lprn) then
7633         write (iout,'(a)') 'Contact function values after receive:'
7634         do i=nnt,nct-2
7635           write (iout,'(2i3,50(1x,i3,5f6.3))')
7636      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7637      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7638         enddo
7639         call flush(iout)
7640       endif
7641    30 continue
7642 #endif
7643       if (lprn) then
7644         write (iout,'(a)') 'Contact function values:'
7645         do i=nnt,nct-2
7646           write (iout,'(2i3,50(1x,i2,5f6.3))')
7647      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7648      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7649         enddo
7650       endif
7651       ecorr=0.0D0
7652       ecorr5=0.0d0
7653       ecorr6=0.0d0
7654 C Remove the loop below after debugging !!!
7655       do i=nnt,nct
7656         do j=1,3
7657           gradcorr(j,i)=0.0D0
7658           gradxorr(j,i)=0.0D0
7659         enddo
7660       enddo
7661 C Calculate the dipole-dipole interaction energies
7662       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7663       do i=iatel_s,iatel_e+1
7664         num_conti=num_cont_hb(i)
7665         do jj=1,num_conti
7666           j=jcont_hb(jj,i)
7667 #ifdef MOMENT
7668           call dipole(i,j,jj)
7669 #endif
7670         enddo
7671       enddo
7672       endif
7673 C Calculate the local-electrostatic correlation terms
7674 c                write (iout,*) "gradcorr5 in eello5 before loop"
7675 c                do iii=1,nres
7676 c                  write (iout,'(i5,3f10.5)')
7677 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7678 c                enddo
7679       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7680 c        write (iout,*) "corr loop i",i
7681         i1=i+1
7682         num_conti=num_cont_hb(i)
7683         num_conti1=num_cont_hb(i+1)
7684         do jj=1,num_conti
7685           j=jcont_hb(jj,i)
7686           jp=iabs(j)
7687           do kk=1,num_conti1
7688             j1=jcont_hb(kk,i1)
7689             jp1=iabs(j1)
7690 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7691 c     &         ' jj=',jj,' kk=',kk
7692 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7693             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7694      &          .or. j.lt.0 .and. j1.gt.0) .and.
7695      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7696 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7697 C The system gains extra energy.
7698               n_corr=n_corr+1
7699               sqd1=dsqrt(d_cont(jj,i))
7700               sqd2=dsqrt(d_cont(kk,i1))
7701               sred_geom = sqd1*sqd2
7702               IF (sred_geom.lt.cutoff_corr) THEN
7703                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7704      &            ekont,fprimcont)
7705 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7706 cd     &         ' jj=',jj,' kk=',kk
7707                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7708                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7709                 do l=1,3
7710                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7711                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7712                 enddo
7713                 n_corr1=n_corr1+1
7714 cd               write (iout,*) 'sred_geom=',sred_geom,
7715 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7716 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7717 cd               write (iout,*) "g_contij",g_contij
7718 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7719 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7720                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7721                 if (wcorr4.gt.0.0d0)
7722      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7723                   if (energy_dec.and.wcorr4.gt.0.0d0)
7724      1                 write (iout,'(a6,4i5,0pf7.3)')
7725      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7726 c                write (iout,*) "gradcorr5 before eello5"
7727 c                do iii=1,nres
7728 c                  write (iout,'(i5,3f10.5)')
7729 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7730 c                enddo
7731                 if (wcorr5.gt.0.0d0)
7732      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7733 c                write (iout,*) "gradcorr5 after eello5"
7734 c                do iii=1,nres
7735 c                  write (iout,'(i5,3f10.5)')
7736 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7737 c                enddo
7738                   if (energy_dec.and.wcorr5.gt.0.0d0)
7739      1                 write (iout,'(a6,4i5,0pf7.3)')
7740      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7741 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7742 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7743                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7744      &               .or. wturn6.eq.0.0d0))then
7745 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7746                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7747                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7748      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7749 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7750 cd     &            'ecorr6=',ecorr6
7751 cd                write (iout,'(4e15.5)') sred_geom,
7752 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7753 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7754 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7755                 else if (wturn6.gt.0.0d0
7756      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7757 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7758                   eturn6=eturn6+eello_turn6(i,jj,kk)
7759                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7760      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7761 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7762                 endif
7763               ENDIF
7764 1111          continue
7765             endif
7766           enddo ! kk
7767         enddo ! jj
7768       enddo ! i
7769       do i=1,nres
7770         num_cont_hb(i)=num_cont_hb_old(i)
7771       enddo
7772 c                write (iout,*) "gradcorr5 in eello5"
7773 c                do iii=1,nres
7774 c                  write (iout,'(i5,3f10.5)')
7775 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7776 c                enddo
7777       return
7778       end
7779 c------------------------------------------------------------------------------
7780       subroutine add_hb_contact_eello(ii,jj,itask)
7781       implicit real*8 (a-h,o-z)
7782       include "DIMENSIONS"
7783       include "COMMON.IOUNITS"
7784       integer max_cont
7785       integer max_dim
7786       parameter (max_cont=maxconts)
7787       parameter (max_dim=70)
7788       include "COMMON.CONTACTS"
7789       double precision zapas(max_dim,maxconts,max_fg_procs),
7790      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7791       common /przechowalnia/ zapas
7792       integer i,j,ii,jj,iproc,itask(4),nn
7793 c      write (iout,*) "itask",itask
7794       do i=1,2
7795         iproc=itask(i)
7796         if (iproc.gt.0) then
7797           do j=1,num_cont_hb(ii)
7798             jjc=jcont_hb(j,ii)
7799 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7800             if (jjc.eq.jj) then
7801               ncont_sent(iproc)=ncont_sent(iproc)+1
7802               nn=ncont_sent(iproc)
7803               zapas(1,nn,iproc)=ii
7804               zapas(2,nn,iproc)=jjc
7805               zapas(3,nn,iproc)=d_cont(j,ii)
7806               ind=3
7807               do kk=1,3
7808                 ind=ind+1
7809                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7810               enddo
7811               do kk=1,2
7812                 do ll=1,2
7813                   ind=ind+1
7814                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7815                 enddo
7816               enddo
7817               do jj=1,5
7818                 do kk=1,3
7819                   do ll=1,2
7820                     do mm=1,2
7821                       ind=ind+1
7822                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7823                     enddo
7824                   enddo
7825                 enddo
7826               enddo
7827               exit
7828             endif
7829           enddo
7830         endif
7831       enddo
7832       return
7833       end
7834 c------------------------------------------------------------------------------
7835       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7836       implicit real*8 (a-h,o-z)
7837       include 'DIMENSIONS'
7838       include 'COMMON.IOUNITS'
7839       include 'COMMON.DERIV'
7840       include 'COMMON.INTERACT'
7841       include 'COMMON.CONTACTS'
7842       double precision gx(3),gx1(3)
7843       logical lprn
7844       lprn=.false.
7845       eij=facont_hb(jj,i)
7846       ekl=facont_hb(kk,k)
7847       ees0pij=ees0p(jj,i)
7848       ees0pkl=ees0p(kk,k)
7849       ees0mij=ees0m(jj,i)
7850       ees0mkl=ees0m(kk,k)
7851       ekont=eij*ekl
7852       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7853 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7854 C Following 4 lines for diagnostics.
7855 cd    ees0pkl=0.0D0
7856 cd    ees0pij=1.0D0
7857 cd    ees0mkl=0.0D0
7858 cd    ees0mij=1.0D0
7859 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7860 c     & 'Contacts ',i,j,
7861 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7862 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7863 c     & 'gradcorr_long'
7864 C Calculate the multi-body contribution to energy.
7865 c      ecorr=ecorr+ekont*ees
7866 C Calculate multi-body contributions to the gradient.
7867       coeffpees0pij=coeffp*ees0pij
7868       coeffmees0mij=coeffm*ees0mij
7869       coeffpees0pkl=coeffp*ees0pkl
7870       coeffmees0mkl=coeffm*ees0mkl
7871       do ll=1,3
7872 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7873         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7874      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7875      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7876         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7877      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7878      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7879 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7880         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7881      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7882      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7883         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7884      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7885      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7886         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7887      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7888      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7889         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7890         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7891         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7892      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7893      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7894         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7895         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7896 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7897       enddo
7898 c      write (iout,*)
7899 cgrad      do m=i+1,j-1
7900 cgrad        do ll=1,3
7901 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7902 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7903 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7904 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7905 cgrad        enddo
7906 cgrad      enddo
7907 cgrad      do m=k+1,l-1
7908 cgrad        do ll=1,3
7909 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7910 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7911 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7912 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7913 cgrad        enddo
7914 cgrad      enddo
7915 c      write (iout,*) "ehbcorr",ekont*ees
7916       ehbcorr=ekont*ees
7917       return
7918       end
7919 #ifdef MOMENT
7920 C---------------------------------------------------------------------------
7921       subroutine dipole(i,j,jj)
7922       implicit real*8 (a-h,o-z)
7923       include 'DIMENSIONS'
7924       include 'COMMON.IOUNITS'
7925       include 'COMMON.CHAIN'
7926       include 'COMMON.FFIELD'
7927       include 'COMMON.DERIV'
7928       include 'COMMON.INTERACT'
7929       include 'COMMON.CONTACTS'
7930       include 'COMMON.TORSION'
7931       include 'COMMON.VAR'
7932       include 'COMMON.GEO'
7933       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7934      &  auxmat(2,2)
7935       iti1 = itortyp(itype(i+1))
7936       if (j.lt.nres-1) then
7937         itj1 = itortyp(itype(j+1))
7938       else
7939         itj1=ntortyp
7940       endif
7941       do iii=1,2
7942         dipi(iii,1)=Ub2(iii,i)
7943         dipderi(iii)=Ub2der(iii,i)
7944         dipi(iii,2)=b1(iii,i+1)
7945         dipj(iii,1)=Ub2(iii,j)
7946         dipderj(iii)=Ub2der(iii,j)
7947         dipj(iii,2)=b1(iii,j+1)
7948       enddo
7949       kkk=0
7950       do iii=1,2
7951         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7952         do jjj=1,2
7953           kkk=kkk+1
7954           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7955         enddo
7956       enddo
7957       do kkk=1,5
7958         do lll=1,3
7959           mmm=0
7960           do iii=1,2
7961             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7962      &        auxvec(1))
7963             do jjj=1,2
7964               mmm=mmm+1
7965               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7966             enddo
7967           enddo
7968         enddo
7969       enddo
7970       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7971       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7972       do iii=1,2
7973         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7974       enddo
7975       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7976       do iii=1,2
7977         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7978       enddo
7979       return
7980       end
7981 #endif
7982 C---------------------------------------------------------------------------
7983       subroutine calc_eello(i,j,k,l,jj,kk)
7984 C
7985 C This subroutine computes matrices and vectors needed to calculate
7986 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7987 C
7988       implicit real*8 (a-h,o-z)
7989       include 'DIMENSIONS'
7990       include 'COMMON.IOUNITS'
7991       include 'COMMON.CHAIN'
7992       include 'COMMON.DERIV'
7993       include 'COMMON.INTERACT'
7994       include 'COMMON.CONTACTS'
7995       include 'COMMON.TORSION'
7996       include 'COMMON.VAR'
7997       include 'COMMON.GEO'
7998       include 'COMMON.FFIELD'
7999       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8000      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8001       logical lprn
8002       common /kutas/ lprn
8003 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8004 cd     & ' jj=',jj,' kk=',kk
8005 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8006 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8007 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8008       do iii=1,2
8009         do jjj=1,2
8010           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8011           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8012         enddo
8013       enddo
8014       call transpose2(aa1(1,1),aa1t(1,1))
8015       call transpose2(aa2(1,1),aa2t(1,1))
8016       do kkk=1,5
8017         do lll=1,3
8018           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8019      &      aa1tder(1,1,lll,kkk))
8020           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8021      &      aa2tder(1,1,lll,kkk))
8022         enddo
8023       enddo
8024       if (l.eq.j+1) then
8025 C parallel orientation of the two CA-CA-CA frames.
8026         if (i.gt.1) then
8027           iti=itortyp(itype(i))
8028         else
8029           iti=ntortyp
8030         endif
8031         itk1=itortyp(itype(k+1))
8032         itj=itortyp(itype(j))
8033         if (l.lt.nres-1) then
8034           itl1=itortyp(itype(l+1))
8035         else
8036           itl1=ntortyp
8037         endif
8038 C A1 kernel(j+1) A2T
8039 cd        do iii=1,2
8040 cd          write (iout,'(3f10.5,5x,3f10.5)')
8041 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8042 cd        enddo
8043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8044      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8045      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8046 C Following matrices are needed only for 6-th order cumulants
8047         IF (wcorr6.gt.0.0d0) THEN
8048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8049      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8050      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8051         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8052      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8053      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8054      &   ADtEAderx(1,1,1,1,1,1))
8055         lprn=.false.
8056         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8057      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8058      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8059      &   ADtEA1derx(1,1,1,1,1,1))
8060         ENDIF
8061 C End 6-th order cumulants
8062 cd        lprn=.false.
8063 cd        if (lprn) then
8064 cd        write (2,*) 'In calc_eello6'
8065 cd        do iii=1,2
8066 cd          write (2,*) 'iii=',iii
8067 cd          do kkk=1,5
8068 cd            write (2,*) 'kkk=',kkk
8069 cd            do jjj=1,2
8070 cd              write (2,'(3(2f10.5),5x)')
8071 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8072 cd            enddo
8073 cd          enddo
8074 cd        enddo
8075 cd        endif
8076         call transpose2(EUgder(1,1,k),auxmat(1,1))
8077         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8078         call transpose2(EUg(1,1,k),auxmat(1,1))
8079         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8080         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8081         do iii=1,2
8082           do kkk=1,5
8083             do lll=1,3
8084               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8085      &          EAEAderx(1,1,lll,kkk,iii,1))
8086             enddo
8087           enddo
8088         enddo
8089 C A1T kernel(i+1) A2
8090         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8091      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8092      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8093 C Following matrices are needed only for 6-th order cumulants
8094         IF (wcorr6.gt.0.0d0) THEN
8095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8096      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8097      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8098         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8099      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8100      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8101      &   ADtEAderx(1,1,1,1,1,2))
8102         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8103      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8104      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8105      &   ADtEA1derx(1,1,1,1,1,2))
8106         ENDIF
8107 C End 6-th order cumulants
8108         call transpose2(EUgder(1,1,l),auxmat(1,1))
8109         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8110         call transpose2(EUg(1,1,l),auxmat(1,1))
8111         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8112         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8113         do iii=1,2
8114           do kkk=1,5
8115             do lll=1,3
8116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8117      &          EAEAderx(1,1,lll,kkk,iii,2))
8118             enddo
8119           enddo
8120         enddo
8121 C AEAb1 and AEAb2
8122 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8123 C They are needed only when the fifth- or the sixth-order cumulants are
8124 C indluded.
8125         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8126         call transpose2(AEA(1,1,1),auxmat(1,1))
8127         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8128         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8129         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8130         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8131         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8132         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8133         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8134         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8135         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8136         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8137         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8138         call transpose2(AEA(1,1,2),auxmat(1,1))
8139         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8140         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8141         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8142         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8143         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8144         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8145         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8146         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8147         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8148         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8149         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8150 C Calculate the Cartesian derivatives of the vectors.
8151         do iii=1,2
8152           do kkk=1,5
8153             do lll=1,3
8154               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8155               call matvec2(auxmat(1,1),b1(1,i),
8156      &          AEAb1derx(1,lll,kkk,iii,1,1))
8157               call matvec2(auxmat(1,1),Ub2(1,i),
8158      &          AEAb2derx(1,lll,kkk,iii,1,1))
8159               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8160      &          AEAb1derx(1,lll,kkk,iii,2,1))
8161               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8162      &          AEAb2derx(1,lll,kkk,iii,2,1))
8163               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8164               call matvec2(auxmat(1,1),b1(1,j),
8165      &          AEAb1derx(1,lll,kkk,iii,1,2))
8166               call matvec2(auxmat(1,1),Ub2(1,j),
8167      &          AEAb2derx(1,lll,kkk,iii,1,2))
8168               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8169      &          AEAb1derx(1,lll,kkk,iii,2,2))
8170               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8171      &          AEAb2derx(1,lll,kkk,iii,2,2))
8172             enddo
8173           enddo
8174         enddo
8175         ENDIF
8176 C End vectors
8177       else
8178 C Antiparallel orientation of the two CA-CA-CA frames.
8179         if (i.gt.1) then
8180           iti=itortyp(itype(i))
8181         else
8182           iti=ntortyp
8183         endif
8184         itk1=itortyp(itype(k+1))
8185         itl=itortyp(itype(l))
8186         itj=itortyp(itype(j))
8187         if (j.lt.nres-1) then
8188           itj1=itortyp(itype(j+1))
8189         else
8190           itj1=ntortyp
8191         endif
8192 C A2 kernel(j-1)T A1T
8193         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8194      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8195      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8196 C Following matrices are needed only for 6-th order cumulants
8197         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8198      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8199         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8200      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8201      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8202         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8203      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8204      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8205      &   ADtEAderx(1,1,1,1,1,1))
8206         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8207      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8208      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8209      &   ADtEA1derx(1,1,1,1,1,1))
8210         ENDIF
8211 C End 6-th order cumulants
8212         call transpose2(EUgder(1,1,k),auxmat(1,1))
8213         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8214         call transpose2(EUg(1,1,k),auxmat(1,1))
8215         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8216         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8217         do iii=1,2
8218           do kkk=1,5
8219             do lll=1,3
8220               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8221      &          EAEAderx(1,1,lll,kkk,iii,1))
8222             enddo
8223           enddo
8224         enddo
8225 C A2T kernel(i+1)T A1
8226         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8227      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8228      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8229 C Following matrices are needed only for 6-th order cumulants
8230         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8231      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8233      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8234      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8235         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8236      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8237      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8238      &   ADtEAderx(1,1,1,1,1,2))
8239         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8240      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8241      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8242      &   ADtEA1derx(1,1,1,1,1,2))
8243         ENDIF
8244 C End 6-th order cumulants
8245         call transpose2(EUgder(1,1,j),auxmat(1,1))
8246         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8247         call transpose2(EUg(1,1,j),auxmat(1,1))
8248         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8249         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8250         do iii=1,2
8251           do kkk=1,5
8252             do lll=1,3
8253               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8254      &          EAEAderx(1,1,lll,kkk,iii,2))
8255             enddo
8256           enddo
8257         enddo
8258 C AEAb1 and AEAb2
8259 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8260 C They are needed only when the fifth- or the sixth-order cumulants are
8261 C indluded.
8262         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8263      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8264         call transpose2(AEA(1,1,1),auxmat(1,1))
8265         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8266         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8267         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8268         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8269         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8270         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8271         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8272         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8273         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8274         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8275         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8276         call transpose2(AEA(1,1,2),auxmat(1,1))
8277         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8278         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8279         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8280         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8281         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8282         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8283         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8284         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8285         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8286         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8287         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8288 C Calculate the Cartesian derivatives of the vectors.
8289         do iii=1,2
8290           do kkk=1,5
8291             do lll=1,3
8292               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8293               call matvec2(auxmat(1,1),b1(1,i),
8294      &          AEAb1derx(1,lll,kkk,iii,1,1))
8295               call matvec2(auxmat(1,1),Ub2(1,i),
8296      &          AEAb2derx(1,lll,kkk,iii,1,1))
8297               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8298      &          AEAb1derx(1,lll,kkk,iii,2,1))
8299               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8300      &          AEAb2derx(1,lll,kkk,iii,2,1))
8301               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8302               call matvec2(auxmat(1,1),b1(1,l),
8303      &          AEAb1derx(1,lll,kkk,iii,1,2))
8304               call matvec2(auxmat(1,1),Ub2(1,l),
8305      &          AEAb2derx(1,lll,kkk,iii,1,2))
8306               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8307      &          AEAb1derx(1,lll,kkk,iii,2,2))
8308               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8309      &          AEAb2derx(1,lll,kkk,iii,2,2))
8310             enddo
8311           enddo
8312         enddo
8313         ENDIF
8314 C End vectors
8315       endif
8316       return
8317       end
8318 C---------------------------------------------------------------------------
8319       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8320      &  KK,KKderg,AKA,AKAderg,AKAderx)
8321       implicit none
8322       integer nderg
8323       logical transp
8324       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8325      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8326      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8327       integer iii,kkk,lll
8328       integer jjj,mmm
8329       logical lprn
8330       common /kutas/ lprn
8331       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8332       do iii=1,nderg
8333         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8334      &    AKAderg(1,1,iii))
8335       enddo
8336 cd      if (lprn) write (2,*) 'In kernel'
8337       do kkk=1,5
8338 cd        if (lprn) write (2,*) 'kkk=',kkk
8339         do lll=1,3
8340           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8341      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8342 cd          if (lprn) then
8343 cd            write (2,*) 'lll=',lll
8344 cd            write (2,*) 'iii=1'
8345 cd            do jjj=1,2
8346 cd              write (2,'(3(2f10.5),5x)')
8347 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8348 cd            enddo
8349 cd          endif
8350           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8351      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8352 cd          if (lprn) then
8353 cd            write (2,*) 'lll=',lll
8354 cd            write (2,*) 'iii=2'
8355 cd            do jjj=1,2
8356 cd              write (2,'(3(2f10.5),5x)')
8357 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8358 cd            enddo
8359 cd          endif
8360         enddo
8361       enddo
8362       return
8363       end
8364 C---------------------------------------------------------------------------
8365       double precision function eello4(i,j,k,l,jj,kk)
8366       implicit real*8 (a-h,o-z)
8367       include 'DIMENSIONS'
8368       include 'COMMON.IOUNITS'
8369       include 'COMMON.CHAIN'
8370       include 'COMMON.DERIV'
8371       include 'COMMON.INTERACT'
8372       include 'COMMON.CONTACTS'
8373       include 'COMMON.TORSION'
8374       include 'COMMON.VAR'
8375       include 'COMMON.GEO'
8376       double precision pizda(2,2),ggg1(3),ggg2(3)
8377 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8378 cd        eello4=0.0d0
8379 cd        return
8380 cd      endif
8381 cd      print *,'eello4:',i,j,k,l,jj,kk
8382 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8383 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8384 cold      eij=facont_hb(jj,i)
8385 cold      ekl=facont_hb(kk,k)
8386 cold      ekont=eij*ekl
8387       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8388 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8389       gcorr_loc(k-1)=gcorr_loc(k-1)
8390      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8391       if (l.eq.j+1) then
8392         gcorr_loc(l-1)=gcorr_loc(l-1)
8393      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8394       else
8395         gcorr_loc(j-1)=gcorr_loc(j-1)
8396      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8397       endif
8398       do iii=1,2
8399         do kkk=1,5
8400           do lll=1,3
8401             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8402      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8403 cd            derx(lll,kkk,iii)=0.0d0
8404           enddo
8405         enddo
8406       enddo
8407 cd      gcorr_loc(l-1)=0.0d0
8408 cd      gcorr_loc(j-1)=0.0d0
8409 cd      gcorr_loc(k-1)=0.0d0
8410 cd      eel4=1.0d0
8411 cd      write (iout,*)'Contacts have occurred for peptide groups',
8412 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8413 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8414       if (j.lt.nres-1) then
8415         j1=j+1
8416         j2=j-1
8417       else
8418         j1=j-1
8419         j2=j-2
8420       endif
8421       if (l.lt.nres-1) then
8422         l1=l+1
8423         l2=l-1
8424       else
8425         l1=l-1
8426         l2=l-2
8427       endif
8428       do ll=1,3
8429 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8430 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8431         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8432         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8433 cgrad        ghalf=0.5d0*ggg1(ll)
8434         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8435         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8436         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8437         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8438         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8439         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8440 cgrad        ghalf=0.5d0*ggg2(ll)
8441         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8442         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8443         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8444         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8445         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8446         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8447       enddo
8448 cgrad      do m=i+1,j-1
8449 cgrad        do ll=1,3
8450 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8451 cgrad        enddo
8452 cgrad      enddo
8453 cgrad      do m=k+1,l-1
8454 cgrad        do ll=1,3
8455 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8456 cgrad        enddo
8457 cgrad      enddo
8458 cgrad      do m=i+2,j2
8459 cgrad        do ll=1,3
8460 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8461 cgrad        enddo
8462 cgrad      enddo
8463 cgrad      do m=k+2,l2
8464 cgrad        do ll=1,3
8465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8466 cgrad        enddo
8467 cgrad      enddo
8468 cd      do iii=1,nres-3
8469 cd        write (2,*) iii,gcorr_loc(iii)
8470 cd      enddo
8471       eello4=ekont*eel4
8472 cd      write (2,*) 'ekont',ekont
8473 cd      write (iout,*) 'eello4',ekont*eel4
8474       return
8475       end
8476 C---------------------------------------------------------------------------
8477       double precision function eello5(i,j,k,l,jj,kk)
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       include 'COMMON.IOUNITS'
8481       include 'COMMON.CHAIN'
8482       include 'COMMON.DERIV'
8483       include 'COMMON.INTERACT'
8484       include 'COMMON.CONTACTS'
8485       include 'COMMON.TORSION'
8486       include 'COMMON.VAR'
8487       include 'COMMON.GEO'
8488       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8489       double precision ggg1(3),ggg2(3)
8490 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8491 C                                                                              C
8492 C                            Parallel chains                                   C
8493 C                                                                              C
8494 C          o             o                   o             o                   C
8495 C         /l\           / \             \   / \           / \   /              C
8496 C        /   \         /   \             \ /   \         /   \ /               C
8497 C       j| o |l1       | o |              o| o |         | o |o                C
8498 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8499 C      \i/   \         /   \ /             /   \         /   \                 C
8500 C       o    k1             o                                                  C
8501 C         (I)          (II)                (III)          (IV)                 C
8502 C                                                                              C
8503 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8504 C                                                                              C
8505 C                            Antiparallel chains                               C
8506 C                                                                              C
8507 C          o             o                   o             o                   C
8508 C         /j\           / \             \   / \           / \   /              C
8509 C        /   \         /   \             \ /   \         /   \ /               C
8510 C      j1| o |l        | o |              o| o |         | o |o                C
8511 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8512 C      \i/   \         /   \ /             /   \         /   \                 C
8513 C       o     k1            o                                                  C
8514 C         (I)          (II)                (III)          (IV)                 C
8515 C                                                                              C
8516 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8517 C                                                                              C
8518 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8519 C                                                                              C
8520 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8521 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8522 cd        eello5=0.0d0
8523 cd        return
8524 cd      endif
8525 cd      write (iout,*)
8526 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8527 cd     &   ' and',k,l
8528       itk=itortyp(itype(k))
8529       itl=itortyp(itype(l))
8530       itj=itortyp(itype(j))
8531       eello5_1=0.0d0
8532       eello5_2=0.0d0
8533       eello5_3=0.0d0
8534       eello5_4=0.0d0
8535 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8536 cd     &   eel5_3_num,eel5_4_num)
8537       do iii=1,2
8538         do kkk=1,5
8539           do lll=1,3
8540             derx(lll,kkk,iii)=0.0d0
8541           enddo
8542         enddo
8543       enddo
8544 cd      eij=facont_hb(jj,i)
8545 cd      ekl=facont_hb(kk,k)
8546 cd      ekont=eij*ekl
8547 cd      write (iout,*)'Contacts have occurred for peptide groups',
8548 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8549 cd      goto 1111
8550 C Contribution from the graph I.
8551 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8552 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8553       call transpose2(EUg(1,1,k),auxmat(1,1))
8554       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8555       vv(1)=pizda(1,1)-pizda(2,2)
8556       vv(2)=pizda(1,2)+pizda(2,1)
8557       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8558      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8559 C Explicit gradient in virtual-dihedral angles.
8560       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8561      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8562      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8563       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8564       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8565       vv(1)=pizda(1,1)-pizda(2,2)
8566       vv(2)=pizda(1,2)+pizda(2,1)
8567       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8568      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8569      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8570       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8571       vv(1)=pizda(1,1)-pizda(2,2)
8572       vv(2)=pizda(1,2)+pizda(2,1)
8573       if (l.eq.j+1) then
8574         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8575      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8577       else
8578         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8579      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8580      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8581       endif
8582 C Cartesian gradient
8583       do iii=1,2
8584         do kkk=1,5
8585           do lll=1,3
8586             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8587      &        pizda(1,1))
8588             vv(1)=pizda(1,1)-pizda(2,2)
8589             vv(2)=pizda(1,2)+pizda(2,1)
8590             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8591      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8592      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8593           enddo
8594         enddo
8595       enddo
8596 c      goto 1112
8597 c1111  continue
8598 C Contribution from graph II
8599       call transpose2(EE(1,1,itk),auxmat(1,1))
8600       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8601       vv(1)=pizda(1,1)+pizda(2,2)
8602       vv(2)=pizda(2,1)-pizda(1,2)
8603       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8604      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8605 C Explicit gradient in virtual-dihedral angles.
8606       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8607      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8608       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8609       vv(1)=pizda(1,1)+pizda(2,2)
8610       vv(2)=pizda(2,1)-pizda(1,2)
8611       if (l.eq.j+1) then
8612         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8613      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8614      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8615       else
8616         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8617      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8618      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8619       endif
8620 C Cartesian gradient
8621       do iii=1,2
8622         do kkk=1,5
8623           do lll=1,3
8624             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8625      &        pizda(1,1))
8626             vv(1)=pizda(1,1)+pizda(2,2)
8627             vv(2)=pizda(2,1)-pizda(1,2)
8628             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8629      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8630      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8631           enddo
8632         enddo
8633       enddo
8634 cd      goto 1112
8635 cd1111  continue
8636       if (l.eq.j+1) then
8637 cd        goto 1110
8638 C Parallel orientation
8639 C Contribution from graph III
8640         call transpose2(EUg(1,1,l),auxmat(1,1))
8641         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8642         vv(1)=pizda(1,1)-pizda(2,2)
8643         vv(2)=pizda(1,2)+pizda(2,1)
8644         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8645      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8646 C Explicit gradient in virtual-dihedral angles.
8647         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8648      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8649      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8650         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(1,2)+pizda(2,1)
8653         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8654      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8655      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8656         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8657         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8658         vv(1)=pizda(1,1)-pizda(2,2)
8659         vv(2)=pizda(1,2)+pizda(2,1)
8660         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8661      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8663 C Cartesian gradient
8664         do iii=1,2
8665           do kkk=1,5
8666             do lll=1,3
8667               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8668      &          pizda(1,1))
8669               vv(1)=pizda(1,1)-pizda(2,2)
8670               vv(2)=pizda(1,2)+pizda(2,1)
8671               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8672      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8673      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8674             enddo
8675           enddo
8676         enddo
8677 cd        goto 1112
8678 C Contribution from graph IV
8679 cd1110    continue
8680         call transpose2(EE(1,1,itl),auxmat(1,1))
8681         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8682         vv(1)=pizda(1,1)+pizda(2,2)
8683         vv(2)=pizda(2,1)-pizda(1,2)
8684         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8685      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8686 C Explicit gradient in virtual-dihedral angles.
8687         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8688      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8689         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8690         vv(1)=pizda(1,1)+pizda(2,2)
8691         vv(2)=pizda(2,1)-pizda(1,2)
8692         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8693      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8694      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8695 C Cartesian gradient
8696         do iii=1,2
8697           do kkk=1,5
8698             do lll=1,3
8699               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8700      &          pizda(1,1))
8701               vv(1)=pizda(1,1)+pizda(2,2)
8702               vv(2)=pizda(2,1)-pizda(1,2)
8703               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8704      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8705      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8706             enddo
8707           enddo
8708         enddo
8709       else
8710 C Antiparallel orientation
8711 C Contribution from graph III
8712 c        goto 1110
8713         call transpose2(EUg(1,1,j),auxmat(1,1))
8714         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8715         vv(1)=pizda(1,1)-pizda(2,2)
8716         vv(2)=pizda(1,2)+pizda(2,1)
8717         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8719 C Explicit gradient in virtual-dihedral angles.
8720         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8721      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8722      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8723         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8724         vv(1)=pizda(1,1)-pizda(2,2)
8725         vv(2)=pizda(1,2)+pizda(2,1)
8726         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8727      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8728      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8729         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8730         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8731         vv(1)=pizda(1,1)-pizda(2,2)
8732         vv(2)=pizda(1,2)+pizda(2,1)
8733         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8734      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8735      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8736 C Cartesian gradient
8737         do iii=1,2
8738           do kkk=1,5
8739             do lll=1,3
8740               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8741      &          pizda(1,1))
8742               vv(1)=pizda(1,1)-pizda(2,2)
8743               vv(2)=pizda(1,2)+pizda(2,1)
8744               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8745      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8746      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8747             enddo
8748           enddo
8749         enddo
8750 cd        goto 1112
8751 C Contribution from graph IV
8752 1110    continue
8753         call transpose2(EE(1,1,itj),auxmat(1,1))
8754         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8755         vv(1)=pizda(1,1)+pizda(2,2)
8756         vv(2)=pizda(2,1)-pizda(1,2)
8757         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8758      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8759 C Explicit gradient in virtual-dihedral angles.
8760         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8761      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8762         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8763         vv(1)=pizda(1,1)+pizda(2,2)
8764         vv(2)=pizda(2,1)-pizda(1,2)
8765         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8766      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8767      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8768 C Cartesian gradient
8769         do iii=1,2
8770           do kkk=1,5
8771             do lll=1,3
8772               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8773      &          pizda(1,1))
8774               vv(1)=pizda(1,1)+pizda(2,2)
8775               vv(2)=pizda(2,1)-pizda(1,2)
8776               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8777      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8778      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8779             enddo
8780           enddo
8781         enddo
8782       endif
8783 1112  continue
8784       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8785 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8786 cd        write (2,*) 'ijkl',i,j,k,l
8787 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8788 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8789 cd      endif
8790 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8791 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8792 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8793 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8794       if (j.lt.nres-1) then
8795         j1=j+1
8796         j2=j-1
8797       else
8798         j1=j-1
8799         j2=j-2
8800       endif
8801       if (l.lt.nres-1) then
8802         l1=l+1
8803         l2=l-1
8804       else
8805         l1=l-1
8806         l2=l-2
8807       endif
8808 cd      eij=1.0d0
8809 cd      ekl=1.0d0
8810 cd      ekont=1.0d0
8811 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8812 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8813 C        summed up outside the subrouine as for the other subroutines
8814 C        handling long-range interactions. The old code is commented out
8815 C        with "cgrad" to keep track of changes.
8816       do ll=1,3
8817 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8818 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8819         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8820         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8821 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8822 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8823 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8824 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8825 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8826 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8827 c     &   gradcorr5ij,
8828 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8829 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8830 cgrad        ghalf=0.5d0*ggg1(ll)
8831 cd        ghalf=0.0d0
8832         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8833         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8834         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8835         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8836         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8837         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8838 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8839 cgrad        ghalf=0.5d0*ggg2(ll)
8840 cd        ghalf=0.0d0
8841         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8842         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8843         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8844         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8845         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8846         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8847       enddo
8848 cd      goto 1112
8849 cgrad      do m=i+1,j-1
8850 cgrad        do ll=1,3
8851 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8852 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8853 cgrad        enddo
8854 cgrad      enddo
8855 cgrad      do m=k+1,l-1
8856 cgrad        do ll=1,3
8857 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8858 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8859 cgrad        enddo
8860 cgrad      enddo
8861 c1112  continue
8862 cgrad      do m=i+2,j2
8863 cgrad        do ll=1,3
8864 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8865 cgrad        enddo
8866 cgrad      enddo
8867 cgrad      do m=k+2,l2
8868 cgrad        do ll=1,3
8869 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cd      do iii=1,nres-3
8873 cd        write (2,*) iii,g_corr5_loc(iii)
8874 cd      enddo
8875       eello5=ekont*eel5
8876 cd      write (2,*) 'ekont',ekont
8877 cd      write (iout,*) 'eello5',ekont*eel5
8878       return
8879       end
8880 c--------------------------------------------------------------------------
8881       double precision function eello6(i,j,k,l,jj,kk)
8882       implicit real*8 (a-h,o-z)
8883       include 'DIMENSIONS'
8884       include 'COMMON.IOUNITS'
8885       include 'COMMON.CHAIN'
8886       include 'COMMON.DERIV'
8887       include 'COMMON.INTERACT'
8888       include 'COMMON.CONTACTS'
8889       include 'COMMON.TORSION'
8890       include 'COMMON.VAR'
8891       include 'COMMON.GEO'
8892       include 'COMMON.FFIELD'
8893       double precision ggg1(3),ggg2(3)
8894 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8895 cd        eello6=0.0d0
8896 cd        return
8897 cd      endif
8898 cd      write (iout,*)
8899 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8900 cd     &   ' and',k,l
8901       eello6_1=0.0d0
8902       eello6_2=0.0d0
8903       eello6_3=0.0d0
8904       eello6_4=0.0d0
8905       eello6_5=0.0d0
8906       eello6_6=0.0d0
8907 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8908 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8909       do iii=1,2
8910         do kkk=1,5
8911           do lll=1,3
8912             derx(lll,kkk,iii)=0.0d0
8913           enddo
8914         enddo
8915       enddo
8916 cd      eij=facont_hb(jj,i)
8917 cd      ekl=facont_hb(kk,k)
8918 cd      ekont=eij*ekl
8919 cd      eij=1.0d0
8920 cd      ekl=1.0d0
8921 cd      ekont=1.0d0
8922       if (l.eq.j+1) then
8923         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8924         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8925         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8926         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8927         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8928         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8929       else
8930         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8931         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8932         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8933         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8934         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8935           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8936         else
8937           eello6_5=0.0d0
8938         endif
8939         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8940       endif
8941 C If turn contributions are considered, they will be handled separately.
8942       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8943 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8944 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8945 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8946 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8947 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8948 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8949 cd      goto 1112
8950       if (j.lt.nres-1) then
8951         j1=j+1
8952         j2=j-1
8953       else
8954         j1=j-1
8955         j2=j-2
8956       endif
8957       if (l.lt.nres-1) then
8958         l1=l+1
8959         l2=l-1
8960       else
8961         l1=l-1
8962         l2=l-2
8963       endif
8964       do ll=1,3
8965 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8966 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8967 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8968 cgrad        ghalf=0.5d0*ggg1(ll)
8969 cd        ghalf=0.0d0
8970         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8971         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8972         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8973         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8974         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8975         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8976         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8977         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8978 cgrad        ghalf=0.5d0*ggg2(ll)
8979 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8980 cd        ghalf=0.0d0
8981         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8982         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8983         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8984         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8985         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8986         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8987       enddo
8988 cd      goto 1112
8989 cgrad      do m=i+1,j-1
8990 cgrad        do ll=1,3
8991 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8992 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8993 cgrad        enddo
8994 cgrad      enddo
8995 cgrad      do m=k+1,l-1
8996 cgrad        do ll=1,3
8997 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8998 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8999 cgrad        enddo
9000 cgrad      enddo
9001 cgrad1112  continue
9002 cgrad      do m=i+2,j2
9003 cgrad        do ll=1,3
9004 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9005 cgrad        enddo
9006 cgrad      enddo
9007 cgrad      do m=k+2,l2
9008 cgrad        do ll=1,3
9009 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9010 cgrad        enddo
9011 cgrad      enddo
9012 cd      do iii=1,nres-3
9013 cd        write (2,*) iii,g_corr6_loc(iii)
9014 cd      enddo
9015       eello6=ekont*eel6
9016 cd      write (2,*) 'ekont',ekont
9017 cd      write (iout,*) 'eello6',ekont*eel6
9018       return
9019       end
9020 c--------------------------------------------------------------------------
9021       double precision function eello6_graph1(i,j,k,l,imat,swap)
9022       implicit real*8 (a-h,o-z)
9023       include 'DIMENSIONS'
9024       include 'COMMON.IOUNITS'
9025       include 'COMMON.CHAIN'
9026       include 'COMMON.DERIV'
9027       include 'COMMON.INTERACT'
9028       include 'COMMON.CONTACTS'
9029       include 'COMMON.TORSION'
9030       include 'COMMON.VAR'
9031       include 'COMMON.GEO'
9032       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9033       logical swap
9034       logical lprn
9035       common /kutas/ lprn
9036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9037 C                                                                              C
9038 C      Parallel       Antiparallel                                             C
9039 C                                                                              C
9040 C          o             o                                                     C
9041 C         /l\           /j\                                                    C
9042 C        /   \         /   \                                                   C
9043 C       /| o |         | o |\                                                  C
9044 C     \ j|/k\|  /   \  |/k\|l /                                                C
9045 C      \ /   \ /     \ /   \ /                                                 C
9046 C       o     o       o     o                                                  C
9047 C       i             i                                                        C
9048 C                                                                              C
9049 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9050       itk=itortyp(itype(k))
9051       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9052       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9053       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9054       call transpose2(EUgC(1,1,k),auxmat(1,1))
9055       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9056       vv1(1)=pizda1(1,1)-pizda1(2,2)
9057       vv1(2)=pizda1(1,2)+pizda1(2,1)
9058       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9059       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9060       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9061       s5=scalar2(vv(1),Dtobr2(1,i))
9062 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9063       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9064       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9065      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9066      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9067      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9068      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9069      & +scalar2(vv(1),Dtobr2der(1,i)))
9070       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9071       vv1(1)=pizda1(1,1)-pizda1(2,2)
9072       vv1(2)=pizda1(1,2)+pizda1(2,1)
9073       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9074       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9075       if (l.eq.j+1) then
9076         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9077      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9078      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9079      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9080      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9081       else
9082         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9083      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9084      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9085      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9086      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9087       endif
9088       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9089       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9090       vv1(1)=pizda1(1,1)-pizda1(2,2)
9091       vv1(2)=pizda1(1,2)+pizda1(2,1)
9092       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9093      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9094      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9095      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9096       do iii=1,2
9097         if (swap) then
9098           ind=3-iii
9099         else
9100           ind=iii
9101         endif
9102         do kkk=1,5
9103           do lll=1,3
9104             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9105             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9106             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9107             call transpose2(EUgC(1,1,k),auxmat(1,1))
9108             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9109      &        pizda1(1,1))
9110             vv1(1)=pizda1(1,1)-pizda1(2,2)
9111             vv1(2)=pizda1(1,2)+pizda1(2,1)
9112             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9113             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9114      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9115             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9116      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9117             s5=scalar2(vv(1),Dtobr2(1,i))
9118             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9119           enddo
9120         enddo
9121       enddo
9122       return
9123       end
9124 c----------------------------------------------------------------------------
9125       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9126       implicit real*8 (a-h,o-z)
9127       include 'DIMENSIONS'
9128       include 'COMMON.IOUNITS'
9129       include 'COMMON.CHAIN'
9130       include 'COMMON.DERIV'
9131       include 'COMMON.INTERACT'
9132       include 'COMMON.CONTACTS'
9133       include 'COMMON.TORSION'
9134       include 'COMMON.VAR'
9135       include 'COMMON.GEO'
9136       logical swap
9137       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9138      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9139       logical lprn
9140       common /kutas/ lprn
9141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9142 C                                                                              C
9143 C      Parallel       Antiparallel                                             C
9144 C                                                                              C
9145 C          o             o                                                     C
9146 C     \   /l\           /j\   /                                                C
9147 C      \ /   \         /   \ /                                                 C
9148 C       o| o |         | o |o                                                  C
9149 C     \ j|/k\|      \  |/k\|l                                                  C
9150 C      \ /   \       \ /   \                                                   C
9151 C       o             o                                                        C
9152 C       i             i                                                        C
9153 C                                                                              C
9154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9155 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9156 C AL 7/4/01 s1 would occur in the sixth-order moment,
9157 C           but not in a cluster cumulant
9158 #ifdef MOMENT
9159       s1=dip(1,jj,i)*dip(1,kk,k)
9160 #endif
9161       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9162       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9163       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9164       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9165       call transpose2(EUg(1,1,k),auxmat(1,1))
9166       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9167       vv(1)=pizda(1,1)-pizda(2,2)
9168       vv(2)=pizda(1,2)+pizda(2,1)
9169       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9170 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9171 #ifdef MOMENT
9172       eello6_graph2=-(s1+s2+s3+s4)
9173 #else
9174       eello6_graph2=-(s2+s3+s4)
9175 #endif
9176 c      eello6_graph2=-s3
9177 C Derivatives in gamma(i-1)
9178       if (i.gt.1) then
9179 #ifdef MOMENT
9180         s1=dipderg(1,jj,i)*dip(1,kk,k)
9181 #endif
9182         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9183         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9184         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9185         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9186 #ifdef MOMENT
9187         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9188 #else
9189         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9190 #endif
9191 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9192       endif
9193 C Derivatives in gamma(k-1)
9194 #ifdef MOMENT
9195       s1=dip(1,jj,i)*dipderg(1,kk,k)
9196 #endif
9197       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9198       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9199       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9200       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9201       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9202       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9203       vv(1)=pizda(1,1)-pizda(2,2)
9204       vv(2)=pizda(1,2)+pizda(2,1)
9205       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9206 #ifdef MOMENT
9207       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9208 #else
9209       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9210 #endif
9211 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9212 C Derivatives in gamma(j-1) or gamma(l-1)
9213       if (j.gt.1) then
9214 #ifdef MOMENT
9215         s1=dipderg(3,jj,i)*dip(1,kk,k)
9216 #endif
9217         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9218         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9219         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9220         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9221         vv(1)=pizda(1,1)-pizda(2,2)
9222         vv(2)=pizda(1,2)+pizda(2,1)
9223         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9224 #ifdef MOMENT
9225         if (swap) then
9226           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9227         else
9228           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9229         endif
9230 #endif
9231         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9232 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9233       endif
9234 C Derivatives in gamma(l-1) or gamma(j-1)
9235       if (l.gt.1) then
9236 #ifdef MOMENT
9237         s1=dip(1,jj,i)*dipderg(3,kk,k)
9238 #endif
9239         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9240         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9241         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9242         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9243         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9244         vv(1)=pizda(1,1)-pizda(2,2)
9245         vv(2)=pizda(1,2)+pizda(2,1)
9246         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9247 #ifdef MOMENT
9248         if (swap) then
9249           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9250         else
9251           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9252         endif
9253 #endif
9254         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9255 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9256       endif
9257 C Cartesian derivatives.
9258       if (lprn) then
9259         write (2,*) 'In eello6_graph2'
9260         do iii=1,2
9261           write (2,*) 'iii=',iii
9262           do kkk=1,5
9263             write (2,*) 'kkk=',kkk
9264             do jjj=1,2
9265               write (2,'(3(2f10.5),5x)')
9266      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9267             enddo
9268           enddo
9269         enddo
9270       endif
9271       do iii=1,2
9272         do kkk=1,5
9273           do lll=1,3
9274 #ifdef MOMENT
9275             if (iii.eq.1) then
9276               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9277             else
9278               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9279             endif
9280 #endif
9281             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9282      &        auxvec(1))
9283             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9284             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9285      &        auxvec(1))
9286             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9287             call transpose2(EUg(1,1,k),auxmat(1,1))
9288             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9289      &        pizda(1,1))
9290             vv(1)=pizda(1,1)-pizda(2,2)
9291             vv(2)=pizda(1,2)+pizda(2,1)
9292             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9293 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9294 #ifdef MOMENT
9295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9296 #else
9297             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9298 #endif
9299             if (swap) then
9300               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9301             else
9302               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9303             endif
9304           enddo
9305         enddo
9306       enddo
9307       return
9308       end
9309 c----------------------------------------------------------------------------
9310       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9311       implicit real*8 (a-h,o-z)
9312       include 'DIMENSIONS'
9313       include 'COMMON.IOUNITS'
9314       include 'COMMON.CHAIN'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9322       logical swap
9323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9324 C                                                                              C
9325 C      Parallel       Antiparallel                                             C
9326 C                                                                              C
9327 C          o             o                                                     C
9328 C         /l\   /   \   /j\                                                    C
9329 C        /   \ /     \ /   \                                                   C
9330 C       /| o |o       o| o |\                                                  C
9331 C       j|/k\|  /      |/k\|l /                                                C
9332 C        /   \ /       /   \ /                                                 C
9333 C       /     o       /     o                                                  C
9334 C       i             i                                                        C
9335 C                                                                              C
9336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9337 C
9338 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9339 C           energy moment and not to the cluster cumulant.
9340       iti=itortyp(itype(i))
9341       if (j.lt.nres-1) then
9342         itj1=itortyp(itype(j+1))
9343       else
9344         itj1=ntortyp
9345       endif
9346       itk=itortyp(itype(k))
9347       itk1=itortyp(itype(k+1))
9348       if (l.lt.nres-1) then
9349         itl1=itortyp(itype(l+1))
9350       else
9351         itl1=ntortyp
9352       endif
9353 #ifdef MOMENT
9354       s1=dip(4,jj,i)*dip(4,kk,k)
9355 #endif
9356       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9357       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9358       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9359       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9360       call transpose2(EE(1,1,itk),auxmat(1,1))
9361       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9362       vv(1)=pizda(1,1)+pizda(2,2)
9363       vv(2)=pizda(2,1)-pizda(1,2)
9364       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9365 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9366 cd     & "sum",-(s2+s3+s4)
9367 #ifdef MOMENT
9368       eello6_graph3=-(s1+s2+s3+s4)
9369 #else
9370       eello6_graph3=-(s2+s3+s4)
9371 #endif
9372 c      eello6_graph3=-s4
9373 C Derivatives in gamma(k-1)
9374       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9375       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9376       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9377       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9378 C Derivatives in gamma(l-1)
9379       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9380       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9381       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9382       vv(1)=pizda(1,1)+pizda(2,2)
9383       vv(2)=pizda(2,1)-pizda(1,2)
9384       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9385       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9386 C Cartesian derivatives.
9387       do iii=1,2
9388         do kkk=1,5
9389           do lll=1,3
9390 #ifdef MOMENT
9391             if (iii.eq.1) then
9392               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9393             else
9394               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9395             endif
9396 #endif
9397             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9398      &        auxvec(1))
9399             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9400             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9401      &        auxvec(1))
9402             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9403             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9404      &        pizda(1,1))
9405             vv(1)=pizda(1,1)+pizda(2,2)
9406             vv(2)=pizda(2,1)-pizda(1,2)
9407             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9408 #ifdef MOMENT
9409             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9410 #else
9411             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9412 #endif
9413             if (swap) then
9414               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9415             else
9416               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9417             endif
9418 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9419           enddo
9420         enddo
9421       enddo
9422       return
9423       end
9424 c----------------------------------------------------------------------------
9425       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9426       implicit real*8 (a-h,o-z)
9427       include 'DIMENSIONS'
9428       include 'COMMON.IOUNITS'
9429       include 'COMMON.CHAIN'
9430       include 'COMMON.DERIV'
9431       include 'COMMON.INTERACT'
9432       include 'COMMON.CONTACTS'
9433       include 'COMMON.TORSION'
9434       include 'COMMON.VAR'
9435       include 'COMMON.GEO'
9436       include 'COMMON.FFIELD'
9437       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9438      & auxvec1(2),auxmat1(2,2)
9439       logical swap
9440 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9441 C                                                                              C
9442 C      Parallel       Antiparallel                                             C
9443 C                                                                              C
9444 C          o             o                                                     C
9445 C         /l\   /   \   /j\                                                    C
9446 C        /   \ /     \ /   \                                                   C
9447 C       /| o |o       o| o |\                                                  C
9448 C     \ j|/k\|      \  |/k\|l                                                  C
9449 C      \ /   \       \ /   \                                                   C
9450 C       o     \       o     \                                                  C
9451 C       i             i                                                        C
9452 C                                                                              C
9453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9454 C
9455 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9456 C           energy moment and not to the cluster cumulant.
9457 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9458       iti=itortyp(itype(i))
9459       itj=itortyp(itype(j))
9460       if (j.lt.nres-1) then
9461         itj1=itortyp(itype(j+1))
9462       else
9463         itj1=ntortyp
9464       endif
9465       itk=itortyp(itype(k))
9466       if (k.lt.nres-1) then
9467         itk1=itortyp(itype(k+1))
9468       else
9469         itk1=ntortyp
9470       endif
9471       itl=itortyp(itype(l))
9472       if (l.lt.nres-1) then
9473         itl1=itortyp(itype(l+1))
9474       else
9475         itl1=ntortyp
9476       endif
9477 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9478 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9479 cd     & ' itl',itl,' itl1',itl1
9480 #ifdef MOMENT
9481       if (imat.eq.1) then
9482         s1=dip(3,jj,i)*dip(3,kk,k)
9483       else
9484         s1=dip(2,jj,j)*dip(2,kk,l)
9485       endif
9486 #endif
9487       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9488       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9489       if (j.eq.l+1) then
9490         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9491         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9492       else
9493         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9494         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9495       endif
9496       call transpose2(EUg(1,1,k),auxmat(1,1))
9497       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9498       vv(1)=pizda(1,1)-pizda(2,2)
9499       vv(2)=pizda(2,1)+pizda(1,2)
9500       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9501 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9502 #ifdef MOMENT
9503       eello6_graph4=-(s1+s2+s3+s4)
9504 #else
9505       eello6_graph4=-(s2+s3+s4)
9506 #endif
9507 C Derivatives in gamma(i-1)
9508       if (i.gt.1) then
9509 #ifdef MOMENT
9510         if (imat.eq.1) then
9511           s1=dipderg(2,jj,i)*dip(3,kk,k)
9512         else
9513           s1=dipderg(4,jj,j)*dip(2,kk,l)
9514         endif
9515 #endif
9516         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9517         if (j.eq.l+1) then
9518           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9519           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9520         else
9521           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9522           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9523         endif
9524         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9525         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9526 cd          write (2,*) 'turn6 derivatives'
9527 #ifdef MOMENT
9528           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9529 #else
9530           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9531 #endif
9532         else
9533 #ifdef MOMENT
9534           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9535 #else
9536           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9537 #endif
9538         endif
9539       endif
9540 C Derivatives in gamma(k-1)
9541 #ifdef MOMENT
9542       if (imat.eq.1) then
9543         s1=dip(3,jj,i)*dipderg(2,kk,k)
9544       else
9545         s1=dip(2,jj,j)*dipderg(4,kk,l)
9546       endif
9547 #endif
9548       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9549       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9550       if (j.eq.l+1) then
9551         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9552         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9553       else
9554         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9555         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9556       endif
9557       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9558       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9559       vv(1)=pizda(1,1)-pizda(2,2)
9560       vv(2)=pizda(2,1)+pizda(1,2)
9561       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9562       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9563 #ifdef MOMENT
9564         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9565 #else
9566         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9567 #endif
9568       else
9569 #ifdef MOMENT
9570         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9571 #else
9572         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9573 #endif
9574       endif
9575 C Derivatives in gamma(j-1) or gamma(l-1)
9576       if (l.eq.j+1 .and. l.gt.1) then
9577         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9578         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9579         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9580         vv(1)=pizda(1,1)-pizda(2,2)
9581         vv(2)=pizda(2,1)+pizda(1,2)
9582         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9583         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9584       else if (j.gt.1) then
9585         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9586         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9587         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9588         vv(1)=pizda(1,1)-pizda(2,2)
9589         vv(2)=pizda(2,1)+pizda(1,2)
9590         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9591         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9592           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9593         else
9594           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9595         endif
9596       endif
9597 C Cartesian derivatives.
9598       do iii=1,2
9599         do kkk=1,5
9600           do lll=1,3
9601 #ifdef MOMENT
9602             if (iii.eq.1) then
9603               if (imat.eq.1) then
9604                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9605               else
9606                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9607               endif
9608             else
9609               if (imat.eq.1) then
9610                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9611               else
9612                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9613               endif
9614             endif
9615 #endif
9616             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9617      &        auxvec(1))
9618             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9619             if (j.eq.l+1) then
9620               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9621      &          b1(1,j+1),auxvec(1))
9622               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9623             else
9624               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9625      &          b1(1,l+1),auxvec(1))
9626               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9627             endif
9628             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9629      &        pizda(1,1))
9630             vv(1)=pizda(1,1)-pizda(2,2)
9631             vv(2)=pizda(2,1)+pizda(1,2)
9632             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9633             if (swap) then
9634               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9635 #ifdef MOMENT
9636                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9637      &             -(s1+s2+s4)
9638 #else
9639                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9640      &             -(s2+s4)
9641 #endif
9642                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9643               else
9644 #ifdef MOMENT
9645                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9646 #else
9647                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9648 #endif
9649                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9650               endif
9651             else
9652 #ifdef MOMENT
9653               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9654 #else
9655               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9656 #endif
9657               if (l.eq.j+1) then
9658                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9659               else
9660                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9661               endif
9662             endif
9663           enddo
9664         enddo
9665       enddo
9666       return
9667       end
9668 c----------------------------------------------------------------------------
9669       double precision function eello_turn6(i,jj,kk)
9670       implicit real*8 (a-h,o-z)
9671       include 'DIMENSIONS'
9672       include 'COMMON.IOUNITS'
9673       include 'COMMON.CHAIN'
9674       include 'COMMON.DERIV'
9675       include 'COMMON.INTERACT'
9676       include 'COMMON.CONTACTS'
9677       include 'COMMON.TORSION'
9678       include 'COMMON.VAR'
9679       include 'COMMON.GEO'
9680       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9681      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9682      &  ggg1(3),ggg2(3)
9683       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9684      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9685 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9686 C           the respective energy moment and not to the cluster cumulant.
9687       s1=0.0d0
9688       s8=0.0d0
9689       s13=0.0d0
9690 c
9691       eello_turn6=0.0d0
9692       j=i+4
9693       k=i+1
9694       l=i+3
9695       iti=itortyp(itype(i))
9696       itk=itortyp(itype(k))
9697       itk1=itortyp(itype(k+1))
9698       itl=itortyp(itype(l))
9699       itj=itortyp(itype(j))
9700 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9701 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9702 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9703 cd        eello6=0.0d0
9704 cd        return
9705 cd      endif
9706 cd      write (iout,*)
9707 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9708 cd     &   ' and',k,l
9709 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9710       do iii=1,2
9711         do kkk=1,5
9712           do lll=1,3
9713             derx_turn(lll,kkk,iii)=0.0d0
9714           enddo
9715         enddo
9716       enddo
9717 cd      eij=1.0d0
9718 cd      ekl=1.0d0
9719 cd      ekont=1.0d0
9720       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9721 cd      eello6_5=0.0d0
9722 cd      write (2,*) 'eello6_5',eello6_5
9723 #ifdef MOMENT
9724       call transpose2(AEA(1,1,1),auxmat(1,1))
9725       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9726       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9727       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9728 #endif
9729       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9730       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9731       s2 = scalar2(b1(1,k),vtemp1(1))
9732 #ifdef MOMENT
9733       call transpose2(AEA(1,1,2),atemp(1,1))
9734       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9735       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9736       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9737 #endif
9738       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9739       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9740       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9741 #ifdef MOMENT
9742       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9743       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9744       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9745       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9746       ss13 = scalar2(b1(1,k),vtemp4(1))
9747       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9748 #endif
9749 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9750 c      s1=0.0d0
9751 c      s2=0.0d0
9752 c      s8=0.0d0
9753 c      s12=0.0d0
9754 c      s13=0.0d0
9755       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9756 C Derivatives in gamma(i+2)
9757       s1d =0.0d0
9758       s8d =0.0d0
9759 #ifdef MOMENT
9760       call transpose2(AEA(1,1,1),auxmatd(1,1))
9761       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9762       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9763       call transpose2(AEAderg(1,1,2),atempd(1,1))
9764       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9765       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9766 #endif
9767       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9768       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9769       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9770 c      s1d=0.0d0
9771 c      s2d=0.0d0
9772 c      s8d=0.0d0
9773 c      s12d=0.0d0
9774 c      s13d=0.0d0
9775       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9776 C Derivatives in gamma(i+3)
9777 #ifdef MOMENT
9778       call transpose2(AEA(1,1,1),auxmatd(1,1))
9779       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9780       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9781       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9782 #endif
9783       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9784       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9785       s2d = scalar2(b1(1,k),vtemp1d(1))
9786 #ifdef MOMENT
9787       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9788       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9789 #endif
9790       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9791 #ifdef MOMENT
9792       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9793       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9794       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9795 #endif
9796 c      s1d=0.0d0
9797 c      s2d=0.0d0
9798 c      s8d=0.0d0
9799 c      s12d=0.0d0
9800 c      s13d=0.0d0
9801 #ifdef MOMENT
9802       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9803      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9804 #else
9805       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9806      &               -0.5d0*ekont*(s2d+s12d)
9807 #endif
9808 C Derivatives in gamma(i+4)
9809       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9810       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9811       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9812 #ifdef MOMENT
9813       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9814       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9815       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9816 #endif
9817 c      s1d=0.0d0
9818 c      s2d=0.0d0
9819 c      s8d=0.0d0
9820 C      s12d=0.0d0
9821 c      s13d=0.0d0
9822 #ifdef MOMENT
9823       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9824 #else
9825       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9826 #endif
9827 C Derivatives in gamma(i+5)
9828 #ifdef MOMENT
9829       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9830       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9831       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9832 #endif
9833       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9834       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9835       s2d = scalar2(b1(1,k),vtemp1d(1))
9836 #ifdef MOMENT
9837       call transpose2(AEA(1,1,2),atempd(1,1))
9838       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9839       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9840 #endif
9841       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9842       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9843 #ifdef MOMENT
9844       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9845       ss13d = scalar2(b1(1,k),vtemp4d(1))
9846       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9847 #endif
9848 c      s1d=0.0d0
9849 c      s2d=0.0d0
9850 c      s8d=0.0d0
9851 c      s12d=0.0d0
9852 c      s13d=0.0d0
9853 #ifdef MOMENT
9854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9855      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9856 #else
9857       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9858      &               -0.5d0*ekont*(s2d+s12d)
9859 #endif
9860 C Cartesian derivatives
9861       do iii=1,2
9862         do kkk=1,5
9863           do lll=1,3
9864 #ifdef MOMENT
9865             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9866             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9867             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9868 #endif
9869             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9870             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9871      &          vtemp1d(1))
9872             s2d = scalar2(b1(1,k),vtemp1d(1))
9873 #ifdef MOMENT
9874             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9875             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9876             s8d = -(atempd(1,1)+atempd(2,2))*
9877      &           scalar2(cc(1,1,itl),vtemp2(1))
9878 #endif
9879             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9880      &           auxmatd(1,1))
9881             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9882             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9883 c      s1d=0.0d0
9884 c      s2d=0.0d0
9885 c      s8d=0.0d0
9886 c      s12d=0.0d0
9887 c      s13d=0.0d0
9888 #ifdef MOMENT
9889             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9890      &        - 0.5d0*(s1d+s2d)
9891 #else
9892             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9893      &        - 0.5d0*s2d
9894 #endif
9895 #ifdef MOMENT
9896             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9897      &        - 0.5d0*(s8d+s12d)
9898 #else
9899             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9900      &        - 0.5d0*s12d
9901 #endif
9902           enddo
9903         enddo
9904       enddo
9905 #ifdef MOMENT
9906       do kkk=1,5
9907         do lll=1,3
9908           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9909      &      achuj_tempd(1,1))
9910           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9911           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9912           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9913           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9914           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9915      &      vtemp4d(1))
9916           ss13d = scalar2(b1(1,k),vtemp4d(1))
9917           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9918           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9919         enddo
9920       enddo
9921 #endif
9922 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9923 cd     &  16*eel_turn6_num
9924 cd      goto 1112
9925       if (j.lt.nres-1) then
9926         j1=j+1
9927         j2=j-1
9928       else
9929         j1=j-1
9930         j2=j-2
9931       endif
9932       if (l.lt.nres-1) then
9933         l1=l+1
9934         l2=l-1
9935       else
9936         l1=l-1
9937         l2=l-2
9938       endif
9939       do ll=1,3
9940 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9941 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9942 cgrad        ghalf=0.5d0*ggg1(ll)
9943 cd        ghalf=0.0d0
9944         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9945         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9946         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9947      &    +ekont*derx_turn(ll,2,1)
9948         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9949         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9950      &    +ekont*derx_turn(ll,4,1)
9951         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9952         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9953         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9954 cgrad        ghalf=0.5d0*ggg2(ll)
9955 cd        ghalf=0.0d0
9956         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9957      &    +ekont*derx_turn(ll,2,2)
9958         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9959         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9960      &    +ekont*derx_turn(ll,4,2)
9961         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9962         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9963         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9964       enddo
9965 cd      goto 1112
9966 cgrad      do m=i+1,j-1
9967 cgrad        do ll=1,3
9968 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9969 cgrad        enddo
9970 cgrad      enddo
9971 cgrad      do m=k+1,l-1
9972 cgrad        do ll=1,3
9973 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9974 cgrad        enddo
9975 cgrad      enddo
9976 cgrad1112  continue
9977 cgrad      do m=i+2,j2
9978 cgrad        do ll=1,3
9979 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9980 cgrad        enddo
9981 cgrad      enddo
9982 cgrad      do m=k+2,l2
9983 cgrad        do ll=1,3
9984 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9985 cgrad        enddo
9986 cgrad      enddo
9987 cd      do iii=1,nres-3
9988 cd        write (2,*) iii,g_corr6_loc(iii)
9989 cd      enddo
9990       eello_turn6=ekont*eel_turn6
9991 cd      write (2,*) 'ekont',ekont
9992 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9993       return
9994       end
9995
9996 C-----------------------------------------------------------------------------
9997       double precision function scalar(u,v)
9998 !DIR$ INLINEALWAYS scalar
9999 #ifndef OSF
10000 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10001 #endif
10002       implicit none
10003       double precision u(3),v(3)
10004 cd      double precision sc
10005 cd      integer i
10006 cd      sc=0.0d0
10007 cd      do i=1,3
10008 cd        sc=sc+u(i)*v(i)
10009 cd      enddo
10010 cd      scalar=sc
10011
10012       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10013       return
10014       end
10015 crc-------------------------------------------------
10016       SUBROUTINE MATVEC2(A1,V1,V2)
10017 !DIR$ INLINEALWAYS MATVEC2
10018 #ifndef OSF
10019 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10020 #endif
10021       implicit real*8 (a-h,o-z)
10022       include 'DIMENSIONS'
10023       DIMENSION A1(2,2),V1(2),V2(2)
10024 c      DO 1 I=1,2
10025 c        VI=0.0
10026 c        DO 3 K=1,2
10027 c    3     VI=VI+A1(I,K)*V1(K)
10028 c        Vaux(I)=VI
10029 c    1 CONTINUE
10030
10031       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10032       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10033
10034       v2(1)=vaux1
10035       v2(2)=vaux2
10036       END
10037 C---------------------------------------
10038       SUBROUTINE MATMAT2(A1,A2,A3)
10039 #ifndef OSF
10040 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10041 #endif
10042       implicit real*8 (a-h,o-z)
10043       include 'DIMENSIONS'
10044       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10045 c      DIMENSION AI3(2,2)
10046 c        DO  J=1,2
10047 c          A3IJ=0.0
10048 c          DO K=1,2
10049 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10050 c          enddo
10051 c          A3(I,J)=A3IJ
10052 c       enddo
10053 c      enddo
10054
10055       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10056       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10057       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10058       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10059
10060       A3(1,1)=AI3_11
10061       A3(2,1)=AI3_21
10062       A3(1,2)=AI3_12
10063       A3(2,2)=AI3_22
10064       END
10065
10066 c-------------------------------------------------------------------------
10067       double precision function scalar2(u,v)
10068 !DIR$ INLINEALWAYS scalar2
10069       implicit none
10070       double precision u(2),v(2)
10071       double precision sc
10072       integer i
10073       scalar2=u(1)*v(1)+u(2)*v(2)
10074       return
10075       end
10076
10077 C-----------------------------------------------------------------------------
10078
10079       subroutine transpose2(a,at)
10080 !DIR$ INLINEALWAYS transpose2
10081 #ifndef OSF
10082 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10083 #endif
10084       implicit none
10085       double precision a(2,2),at(2,2)
10086       at(1,1)=a(1,1)
10087       at(1,2)=a(2,1)
10088       at(2,1)=a(1,2)
10089       at(2,2)=a(2,2)
10090       return
10091       end
10092 c--------------------------------------------------------------------------
10093       subroutine transpose(n,a,at)
10094       implicit none
10095       integer n,i,j
10096       double precision a(n,n),at(n,n)
10097       do i=1,n
10098         do j=1,n
10099           at(j,i)=a(i,j)
10100         enddo
10101       enddo
10102       return
10103       end
10104 C---------------------------------------------------------------------------
10105       subroutine prodmat3(a1,a2,kk,transp,prod)
10106 !DIR$ INLINEALWAYS prodmat3
10107 #ifndef OSF
10108 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10109 #endif
10110       implicit none
10111       integer i,j
10112       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10113       logical transp
10114 crc      double precision auxmat(2,2),prod_(2,2)
10115
10116       if (transp) then
10117 crc        call transpose2(kk(1,1),auxmat(1,1))
10118 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10119 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10120
10121            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10122      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10123            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10124      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10125            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10126      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10127            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10128      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10129
10130       else
10131 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10132 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10133
10134            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10135      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10136            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10137      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10138            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10139      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10140            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10141      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10142
10143       endif
10144 c      call transpose2(a2(1,1),a2t(1,1))
10145
10146 crc      print *,transp
10147 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10148 crc      print *,((prod(i,j),i=1,2),j=1,2)
10149
10150       return
10151       end
10152 CCC----------------------------------------------
10153       subroutine Eliptransfer(eliptran)
10154       implicit real*8 (a-h,o-z)
10155       include 'DIMENSIONS'
10156       include 'COMMON.GEO'
10157       include 'COMMON.VAR'
10158       include 'COMMON.LOCAL'
10159       include 'COMMON.CHAIN'
10160       include 'COMMON.DERIV'
10161       include 'COMMON.NAMES'
10162       include 'COMMON.INTERACT'
10163       include 'COMMON.IOUNITS'
10164       include 'COMMON.CALC'
10165       include 'COMMON.CONTROL'
10166       include 'COMMON.SPLITELE'
10167       include 'COMMON.SBRIDGE'
10168 C this is done by Adasko
10169 C      print *,"wchodze"
10170 C structure of box:
10171 C      water
10172 C--bordliptop-- buffore starts
10173 C--bufliptop--- here true lipid starts
10174 C      lipid
10175 C--buflipbot--- lipid ends buffore starts
10176 C--bordlipbot--buffore ends
10177       eliptran=0.0
10178       do i=ilip_start,ilip_end
10179 C       do i=1,1
10180         if (itype(i).eq.ntyp1) cycle
10181
10182         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10183         if (positi.le.0) positi=positi+boxzsize
10184 C        print *,i
10185 C first for peptide groups
10186 c for each residue check if it is in lipid or lipid water border area
10187        if ((positi.gt.bordlipbot)
10188      &.and.(positi.lt.bordliptop)) then
10189 C the energy transfer exist
10190         if (positi.lt.buflipbot) then
10191 C what fraction I am in
10192          fracinbuf=1.0d0-
10193      &        ((positi-bordlipbot)/lipbufthick)
10194 C lipbufthick is thickenes of lipid buffore
10195          sslip=sscalelip(fracinbuf)
10196          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10197          eliptran=eliptran+sslip*pepliptran
10198          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10199          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10200 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10201
10202 C        print *,"doing sccale for lower part"
10203 C         print *,i,sslip,fracinbuf,ssgradlip
10204         elseif (positi.gt.bufliptop) then
10205          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10206          sslip=sscalelip(fracinbuf)
10207          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10208          eliptran=eliptran+sslip*pepliptran
10209          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10210          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10211 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10212 C          print *, "doing sscalefor top part"
10213 C         print *,i,sslip,fracinbuf,ssgradlip
10214         else
10215          eliptran=eliptran+pepliptran
10216 C         print *,"I am in true lipid"
10217         endif
10218 C       else
10219 C       eliptran=elpitran+0.0 ! I am in water
10220        endif
10221        enddo
10222 C       print *, "nic nie bylo w lipidzie?"
10223 C now multiply all by the peptide group transfer factor
10224 C       eliptran=eliptran*pepliptran
10225 C now the same for side chains
10226 CV       do i=1,1
10227        do i=ilip_start,ilip_end
10228         if (itype(i).eq.ntyp1) cycle
10229         positi=(mod(c(3,i+nres),boxzsize))
10230         if (positi.le.0) positi=positi+boxzsize
10231 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10232 c for each residue check if it is in lipid or lipid water border area
10233 C       respos=mod(c(3,i+nres),boxzsize)
10234 C       print *,positi,bordlipbot,buflipbot
10235        if ((positi.gt.bordlipbot)
10236      & .and.(positi.lt.bordliptop)) then
10237 C the energy transfer exist
10238         if (positi.lt.buflipbot) then
10239          fracinbuf=1.0d0-
10240      &     ((positi-bordlipbot)/lipbufthick)
10241 C lipbufthick is thickenes of lipid buffore
10242          sslip=sscalelip(fracinbuf)
10243          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10244          eliptran=eliptran+sslip*liptranene(itype(i))
10245          gliptranx(3,i)=gliptranx(3,i)
10246      &+ssgradlip*liptranene(itype(i))
10247          gliptranc(3,i-1)= gliptranc(3,i-1)
10248      &+ssgradlip*liptranene(itype(i))
10249 C         print *,"doing sccale for lower part"
10250         elseif (positi.gt.bufliptop) then
10251          fracinbuf=1.0d0-
10252      &((bordliptop-positi)/lipbufthick)
10253          sslip=sscalelip(fracinbuf)
10254          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10255          eliptran=eliptran+sslip*liptranene(itype(i))
10256          gliptranx(3,i)=gliptranx(3,i)
10257      &+ssgradlip*liptranene(itype(i))
10258          gliptranc(3,i-1)= gliptranc(3,i-1)
10259      &+ssgradlip*liptranene(itype(i))
10260 C          print *, "doing sscalefor top part",sslip,fracinbuf
10261         else
10262          eliptran=eliptran+liptranene(itype(i))
10263 C         print *,"I am in true lipid"
10264         endif
10265         endif ! if in lipid or buffor
10266 C       else
10267 C       eliptran=elpitran+0.0 ! I am in water
10268        enddo
10269        return
10270        end
10271 C---------------------------------------------------------
10272 C AFM soubroutine for constant force
10273        subroutine AFMforce(Eafmforce)
10274        implicit real*8 (a-h,o-z)
10275       include 'DIMENSIONS'
10276       include 'COMMON.GEO'
10277       include 'COMMON.VAR'
10278       include 'COMMON.LOCAL'
10279       include 'COMMON.CHAIN'
10280       include 'COMMON.DERIV'
10281       include 'COMMON.NAMES'
10282       include 'COMMON.INTERACT'
10283       include 'COMMON.IOUNITS'
10284       include 'COMMON.CALC'
10285       include 'COMMON.CONTROL'
10286       include 'COMMON.SPLITELE'
10287       include 'COMMON.SBRIDGE'
10288       real*8 diffafm(3)
10289       dist=0.0d0
10290       Eafmforce=0.0d0
10291       do i=1,3
10292       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10293       dist=dist+diffafm(i)**2
10294       enddo
10295       dist=dsqrt(dist)
10296       Eafmforce=-forceAFMconst*(dist-distafminit)
10297       do i=1,3
10298       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10299       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10300       enddo
10301 C      print *,'AFM',Eafmforce
10302       return
10303       end
10304 C---------------------------------------------------------
10305 C AFM subroutine with pseudoconstant velocity
10306        subroutine AFMvel(Eafmforce)
10307        implicit real*8 (a-h,o-z)
10308       include 'DIMENSIONS'
10309       include 'COMMON.GEO'
10310       include 'COMMON.VAR'
10311       include 'COMMON.LOCAL'
10312       include 'COMMON.CHAIN'
10313       include 'COMMON.DERIV'
10314       include 'COMMON.NAMES'
10315       include 'COMMON.INTERACT'
10316       include 'COMMON.IOUNITS'
10317       include 'COMMON.CALC'
10318       include 'COMMON.CONTROL'
10319       include 'COMMON.SPLITELE'
10320       include 'COMMON.SBRIDGE'
10321       real*8 diffafm(3)
10322 C Only for check grad COMMENT if not used for checkgrad
10323 C      totT=3.0d0
10324 C--------------------------------------------------------
10325 C      print *,"wchodze"
10326       dist=0.0d0
10327       Eafmforce=0.0d0
10328       do i=1,3
10329       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10330       dist=dist+diffafm(i)**2
10331       enddo
10332       dist=dsqrt(dist)
10333       Eafmforce=0.5d0*forceAFMconst
10334      & *(distafminit+totTafm*velAFMconst-dist)**2
10335 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10336       do i=1,3
10337       gradafm(i,afmend-1)=-forceAFMconst*
10338      &(distafminit+totTafm*velAFMconst-dist)
10339      &*diffafm(i)/dist
10340       gradafm(i,afmbeg-1)=forceAFMconst*
10341      &(distafminit+totTafm*velAFMconst-dist)
10342      &*diffafm(i)/dist
10343       enddo
10344 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10345       return
10346       end
10347