source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 141       if (ipot.lt.6) then
 142 #ifdef SPLITELE
 143          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 144      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 145      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 146      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 147 #else
 148          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 149      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 150      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 151      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 152 #endif
 153             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 154          else
 155             ees=0.0d0
 156             evdw1=0.0d0
 157             eel_loc=0.0d0
 158             eello_turn3=0.0d0
 159             eello_turn4=0.0d0
 160          endif
 161       else
 162         write (iout,*) "Soft-spheer ELEC potential"
 163         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164      &   eello_turn4)
 165       endif
 166 c      print *,"Processor",myrank," computed UELEC"
 167 C
 168 C Calculate excluded-volume interaction energy between peptide groups
 169 C and side chains.
 170 C
 171       if (ipot.lt.6) then
 172        if(wscp.gt.0d0) then
 173         call escp(evdw2,evdw2_14)
 174        else
 175         evdw2=0
 176         evdw2_14=0
 177        endif
 178       else
 179 c        write (iout,*) "Soft-sphere SCP potential"
 180         call escp_soft_sphere(evdw2,evdw2_14)
 181       endif
 182 c
 183 c Calculate the bond-stretching energy
 184 c
 185       call ebond(estr)
 186 C
 187 C Calculate the disulfide-bridge and other energy and the contributions
 188 C from other distance constraints.
 189 cd    print *,'Calling EHPB'
 190       call edis(ehpb)
 191 cd    print *,'EHPB exitted succesfully.'
 192 C
 193 C Calculate the virtual-bond-angle energy.
 194 C
 195       if (wang.gt.0d0) then
 196         call ebend(ebe)
 197       else
 198         ebe=0
 199       endif
 200 c      print *,"Processor",myrank," computed UB"
 201 C
 202 C Calculate the SC local energy.
 203 C
 204 C      print *,"TU DOCHODZE?"
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 C      print *,"PRZED MULIt"
 236 c      print *,"Processor",myrank," computed Usccorr"
 237 C
 238 C 12/1/95 Multi-body terms
 239 C
 240       n_corr=0
 241       n_corr1=0
 242       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 243      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 245 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 246 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 247       else
 248          ecorr=0.0d0
 249          ecorr5=0.0d0
 250          ecorr6=0.0d0
 251          eturn6=0.0d0
 252       endif
 253       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 254          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 255 cd         write (iout,*) "multibody_hb ecorr",ecorr
 256       endif
 257 c      print *,"Processor",myrank," computed Ucorr"
 258 C
 259 C If performing constraint dynamics, call the constraint energy
 260 C  after the equilibration time
 261       if(usampl.and.totT.gt.eq_time) then
 262          call EconstrQ
 263          call Econstr_back
 264       else
 265          Uconst=0.0d0
 266          Uconst_back=0.0d0
 267       endif
 268 C 01/27/2015 added by adasko
 269 C the energy component below is energy transfer into lipid environment
 270 C based on partition function
 271 C      print *,"przed lipidami"
 272       if (wliptran.gt.0) then
 273         call Eliptransfer(eliptran)
 274       endif
 275 C      print *,"za lipidami"
 276       if (AFMlog.gt.0) then
 277         call AFMforce(Eafmforce)
 278       else if (selfguide.gt.0) then
 279         call AFMvel(Eafmforce)
 280       endif
 281 #ifdef TIMING
 282       time_enecalc=time_enecalc+MPI_Wtime()-time00
 283 #endif
 284 c      print *,"Processor",myrank," computed Uconstr"
 285 #ifdef TIMING
 286       time00=MPI_Wtime()
 287 #endif
 288 c
 289 C Sum the energies
 290 C
 291       energia(1)=evdw
 292 #ifdef SCP14
 293       energia(2)=evdw2-evdw2_14
 294       energia(18)=evdw2_14
 295 #else
 296       energia(2)=evdw2
 297       energia(18)=0.0d0
 298 #endif
 299 #ifdef SPLITELE
 300       energia(3)=ees
 301       energia(16)=evdw1
 302 #else
 303       energia(3)=ees+evdw1
 304       energia(16)=0.0d0
 305 #endif
 306       energia(4)=ecorr
 307       energia(5)=ecorr5
 308       energia(6)=ecorr6
 309       energia(7)=eel_loc
 310       energia(8)=eello_turn3
 311       energia(9)=eello_turn4
 312       energia(10)=eturn6
 313       energia(11)=ebe
 314       energia(12)=escloc
 315       energia(13)=etors
 316       energia(14)=etors_d
 317       energia(15)=ehpb
 318       energia(19)=edihcnstr
 319       energia(17)=estr
 320       energia(20)=Uconst+Uconst_back
 321       energia(21)=esccor
 322       energia(22)=eliptran
 323       energia(23)=Eafmforce
 324 c    Here are the energies showed per procesor if the are more processors
 325 c    per molecule then we sum it up in sum_energy subroutine
 326 c      print *," Processor",myrank," calls SUM_ENERGY"
 327       call sum_energy(energia,.true.)
 328       if (dyn_ss) call dyn_set_nss
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331       time_sumene=time_sumene+MPI_Wtime()-time00
 332 #endif
 333       return
 334       end
 335 c-------------------------------------------------------------------------------
 336       subroutine sum_energy(energia,reduce)
 337       implicit real*8 (a-h,o-z)
 338       include 'DIMENSIONS'
 339 #ifndef ISNAN
 340       external proc_proc
 341 #ifdef WINPGI
 342 cMS$ATTRIBUTES C ::  proc_proc
 343 #endif
 344 #endif
 345 #ifdef MPI
 346       include "mpif.h"
 347 #endif
 348       include 'COMMON.SETUP'
 349       include 'COMMON.IOUNITS'
 350       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 351       include 'COMMON.FFIELD'
 352       include 'COMMON.DERIV'
 353       include 'COMMON.INTERACT'
 354       include 'COMMON.SBRIDGE'
 355       include 'COMMON.CHAIN'
 356       include 'COMMON.VAR'
 357       include 'COMMON.CONTROL'
 358       include 'COMMON.TIME1'
 359       logical reduce
 360 #ifdef MPI
 361       if (nfgtasks.gt.1 .and. reduce) then
 362 #ifdef DEBUG
 363         write (iout,*) "energies before REDUCE"
 364         call enerprint(energia)
 365         call flush(iout)
 366 #endif
 367         do i=0,n_ene
 368           enebuff(i)=energia(i)
 369         enddo
 370         time00=MPI_Wtime()
 371         call MPI_Barrier(FG_COMM,IERR)
 372         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 373         time00=MPI_Wtime()
 374         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 375      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 376 #ifdef DEBUG
 377         write (iout,*) "energies after REDUCE"
 378         call enerprint(energia)
 379         call flush(iout)
 380 #endif
 381         time_Reduce=time_Reduce+MPI_Wtime()-time00
 382       endif
 383       if (fg_rank.eq.0) then
 384 #endif
 385       evdw=energia(1)
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       eliptran=energia(22)
 416       Eafmforce=energia(23)
 417 #ifdef SPLITELE
 418       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 419      & +wang*ebe+wtor*etors+wscloc*escloc
 420      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 421      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 422      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 423      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 424 #else
 425       etot=wsc*evdw+wscp*evdw2+welec*(ees+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
 431      & +Eafmforce
 432 #endif
 433       energia(0)=etot
 434 c detecting NaNQ
 435 #ifdef ISNAN
 436 #ifdef AIX
 437       if (isnan(etot).ne.0) energia(0)=1.0d+99
 438 #else
 439       if (isnan(etot)) energia(0)=1.0d+99
 440 #endif
 441 #else
 442       i=0
 443 #ifdef WINPGI
 444       idumm=proc_proc(etot,i)
 445 #else
 446       call proc_proc(etot,i)
 447 #endif
 448       if(i.eq.1)energia(0)=1.0d+99
 449 #endif
 450 #ifdef MPI
 451       endif
 452 #endif
 453       return
 454       end
 455 c-------------------------------------------------------------------------------
 456       subroutine sum_gradient
 457       implicit real*8 (a-h,o-z)
 458       include 'DIMENSIONS'
 459 #ifndef ISNAN
 460       external proc_proc
 461 #ifdef WINPGI
 462 cMS$ATTRIBUTES C ::  proc_proc
 463 #endif
 464 #endif
 465 #ifdef MPI
 466       include 'mpif.h'
 467 #endif
 468       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 469      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 470      & ,gloc_scbuf(3,-1:maxres)
 471       include 'COMMON.SETUP'
 472       include 'COMMON.IOUNITS'
 473       include 'COMMON.FFIELD'
 474       include 'COMMON.DERIV'
 475       include 'COMMON.INTERACT'
 476       include 'COMMON.SBRIDGE'
 477       include 'COMMON.CHAIN'
 478       include 'COMMON.VAR'
 479       include 'COMMON.CONTROL'
 480       include 'COMMON.TIME1'
 481       include 'COMMON.MAXGRAD'
 482       include 'COMMON.SCCOR'
 483 #ifdef TIMING
 484       time01=MPI_Wtime()
 485 #endif
 486 #ifdef DEBUG
 487       write (iout,*) "sum_gradient gvdwc, gvdwx"
 488       do i=1,nres
 489         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 490      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 491       enddo
 492       call flush(iout)
 493 #endif
 494 #ifdef MPI
 495 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 496         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 497      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 498 #endif
 499 C
 500 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 501 C            in virtual-bond-vector coordinates
 502 C
 503 #ifdef DEBUG
 504 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 505 c      do i=1,nres-1
 506 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 507 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 508 c      enddo
 509 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 510 c      do i=1,nres-1
 511 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 512 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 513 c      enddo
 514       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 515       do i=1,nres
 516         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 517      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 518      &   g_corr5_loc(i)
 519       enddo
 520       call flush(iout)
 521 #endif
 522 #ifdef SPLITELE
 523       do i=0,nct
 524         do j=1,3
 525           gradbufc(j,i)=wsc*gvdwc(j,i)+
 526      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 527      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 528      &                wel_loc*gel_loc_long(j,i)+
 529      &                wcorr*gradcorr_long(j,i)+
 530      &                wcorr5*gradcorr5_long(j,i)+
 531      &                wcorr6*gradcorr6_long(j,i)+
 532      &                wturn6*gcorr6_turn_long(j,i)+
 533      &                wstrain*ghpbc(j,i)
 534      &                +wliptran*gliptranc(j,i)
 535      &                +gradafm(j,i)
 536
 537         enddo
 538       enddo
 539 #else
 540       do i=0,nct
 541         do j=1,3
 542           gradbufc(j,i)=wsc*gvdwc(j,i)+
 543      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 544      &                welec*gelc_long(j,i)+
 545      &                wbond*gradb(j,i)+
 546      &                wel_loc*gel_loc_long(j,i)+
 547      &                wcorr*gradcorr_long(j,i)+
 548      &                wcorr5*gradcorr5_long(j,i)+
 549      &                wcorr6*gradcorr6_long(j,i)+
 550      &                wturn6*gcorr6_turn_long(j,i)+
 551      &                wstrain*ghpbc(j,i)
 552      &                +wliptran*gliptranc(j,i)
 553      &                +gradafm(j,i)
 554
 555         enddo
 556       enddo
 557 #endif
 558 #ifdef MPI
 559       if (nfgtasks.gt.1) then
 560       time00=MPI_Wtime()
 561 #ifdef DEBUG
 562       write (iout,*) "gradbufc before allreduce"
 563       do i=1,nres
 564         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 565       enddo
 566       call flush(iout)
 567 #endif
 568       do i=0,nres
 569         do j=1,3
 570           gradbufc_sum(j,i)=gradbufc(j,i)
 571         enddo
 572       enddo
 573 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 574 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 575 c      time_reduce=time_reduce+MPI_Wtime()-time00
 576 #ifdef DEBUG
 577 c      write (iout,*) "gradbufc_sum after allreduce"
 578 c      do i=1,nres
 579 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 580 c      enddo
 581 c      call flush(iout)
 582 #endif
 583 #ifdef TIMING
 584 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 585 #endif
 586       do i=nnt,nres
 587         do k=1,3
 588           gradbufc(k,i)=0.0d0
 589         enddo
 590       enddo
 591 #ifdef DEBUG
 592       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 593       write (iout,*) (i," jgrad_start",jgrad_start(i),
 594      &                  " jgrad_end  ",jgrad_end(i),
 595      &                  i=igrad_start,igrad_end)
 596 #endif
 597 c
 598 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 599 c do not parallelize this part.
 600 c
 601 c      do i=igrad_start,igrad_end
 602 c        do j=jgrad_start(i),jgrad_end(i)
 603 c          do k=1,3
 604 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 605 c          enddo
 606 c        enddo
 607 c      enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,-1,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "gradbufc after summing"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 620       enddo
 621       call flush(iout)
 622 #endif
 623       else
 624 #endif
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632       do i=-1,nres
 633         do j=1,3
 634           gradbufc_sum(j,i)=gradbufc(j,i)
 635           gradbufc(j,i)=0.0d0
 636         enddo
 637       enddo
 638       do j=1,3
 639         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 640       enddo
 641       do i=nres-2,-1,-1
 642         do j=1,3
 643           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 644         enddo
 645       enddo
 646 c      do i=nnt,nres-1
 647 c        do k=1,3
 648 c          gradbufc(k,i)=0.0d0
 649 c        enddo
 650 c        do j=i+1,nres
 651 c          do k=1,3
 652 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 653 c          enddo
 654 c        enddo
 655 c      enddo
 656 #ifdef DEBUG
 657       write (iout,*) "gradbufc after summing"
 658       do i=1,nres
 659         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 660       enddo
 661       call flush(iout)
 662 #endif
 663 #ifdef MPI
 664       endif
 665 #endif
 666       do k=1,3
 667         gradbufc(k,nres)=0.0d0
 668       enddo
 669       do i=-1,nct
 670         do j=1,3
 671 #ifdef SPLITELE
 672           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 673      &                wel_loc*gel_loc(j,i)+
 674      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 675      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 676      &                wel_loc*gel_loc_long(j,i)+
 677      &                wcorr*gradcorr_long(j,i)+
 678      &                wcorr5*gradcorr5_long(j,i)+
 679      &                wcorr6*gradcorr6_long(j,i)+
 680      &                wturn6*gcorr6_turn_long(j,i))+
 681      &                wbond*gradb(j,i)+
 682      &                wcorr*gradcorr(j,i)+
 683      &                wturn3*gcorr3_turn(j,i)+
 684      &                wturn4*gcorr4_turn(j,i)+
 685      &                wcorr5*gradcorr5(j,i)+
 686      &                wcorr6*gradcorr6(j,i)+
 687      &                wturn6*gcorr6_turn(j,i)+
 688      &                wsccor*gsccorc(j,i)
 689      &               +wscloc*gscloc(j,i)
 690      &               +wliptran*gliptranc(j,i)
 691      &                +gradafm(j,i)
 692 #else
 693           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 694      &                wel_loc*gel_loc(j,i)+
 695      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 696      &                welec*gelc_long(j,i) +
 697      &                wel_loc*gel_loc_long(j,i)+
 698      &                wcorr*gcorr_long(j,i)+
 699      &                wcorr5*gradcorr5_long(j,i)+
 700      &                wcorr6*gradcorr6_long(j,i)+
 701      &                wturn6*gcorr6_turn_long(j,i))+
 702      &                wbond*gradb(j,i)+
 703      &                wcorr*gradcorr(j,i)+
 704      &                wturn3*gcorr3_turn(j,i)+
 705      &                wturn4*gcorr4_turn(j,i)+
 706      &                wcorr5*gradcorr5(j,i)+
 707      &                wcorr6*gradcorr6(j,i)+
 708      &                wturn6*gcorr6_turn(j,i)+
 709      &                wsccor*gsccorc(j,i)
 710      &               +wscloc*gscloc(j,i)
 711      &               +wliptran*gliptranc(j,i)
 712      &                +gradafm(j,i)
 713
 714 #endif
 715           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 716      &                  wbond*gradbx(j,i)+
 717      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 718      &                  wsccor*gsccorx(j,i)
 719      &                 +wscloc*gsclocx(j,i)
 720      &                 +wliptran*gliptranx(j,i)
 721         enddo
 722       enddo
 723 #ifdef DEBUG
 724       write (iout,*) "gloc before adding corr"
 725       do i=1,4*nres
 726         write (iout,*) i,gloc(i,icg)
 727       enddo
 728 #endif
 729       do i=1,nres-3
 730         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 731      &   +wcorr5*g_corr5_loc(i)
 732      &   +wcorr6*g_corr6_loc(i)
 733      &   +wturn4*gel_loc_turn4(i)
 734      &   +wturn3*gel_loc_turn3(i)
 735      &   +wturn6*gel_loc_turn6(i)
 736      &   +wel_loc*gel_loc_loc(i)
 737       enddo
 738 #ifdef DEBUG
 739       write (iout,*) "gloc after adding corr"
 740       do i=1,4*nres
 741         write (iout,*) i,gloc(i,icg)
 742       enddo
 743 #endif
 744 #ifdef MPI
 745       if (nfgtasks.gt.1) then
 746         do j=1,3
 747           do i=1,nres
 748             gradbufc(j,i)=gradc(j,i,icg)
 749             gradbufx(j,i)=gradx(j,i,icg)
 750           enddo
 751         enddo
 752         do i=1,4*nres
 753           glocbuf(i)=gloc(i,icg)
 754         enddo
 755 c#define DEBUG
 756 #ifdef DEBUG
 757       write (iout,*) "gloc_sc before reduce"
 758       do i=1,nres
 759        do j=1,1
 760         write (iout,*) i,j,gloc_sc(j,i,icg)
 761        enddo
 762       enddo
 763 #endif
 764 c#undef DEBUG
 765         do i=1,nres
 766          do j=1,3
 767           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 768          enddo
 769         enddo
 770         time00=MPI_Wtime()
 771         call MPI_Barrier(FG_COMM,IERR)
 772         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 773         time00=MPI_Wtime()
 774         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 775      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 776         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 777      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 778         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 779      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 780         time_reduce=time_reduce+MPI_Wtime()-time00
 781         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 782      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 783         time_reduce=time_reduce+MPI_Wtime()-time00
 784 c#define DEBUG
 785 #ifdef DEBUG
 786       write (iout,*) "gloc_sc after reduce"
 787       do i=1,nres
 788        do j=1,1
 789         write (iout,*) i,j,gloc_sc(j,i,icg)
 790        enddo
 791       enddo
 792 #endif
 793 c#undef DEBUG
 794 #ifdef DEBUG
 795       write (iout,*) "gloc after reduce"
 796       do i=1,4*nres
 797         write (iout,*) i,gloc(i,icg)
 798       enddo
 799 #endif
 800       endif
 801 #endif
 802       if (gnorm_check) then
 803 c
 804 c Compute the maximum elements of the gradient
 805 c
 806       gvdwc_max=0.0d0
 807       gvdwc_scp_max=0.0d0
 808       gelc_max=0.0d0
 809       gvdwpp_max=0.0d0
 810       gradb_max=0.0d0
 811       ghpbc_max=0.0d0
 812       gradcorr_max=0.0d0
 813       gel_loc_max=0.0d0
 814       gcorr3_turn_max=0.0d0
 815       gcorr4_turn_max=0.0d0
 816       gradcorr5_max=0.0d0
 817       gradcorr6_max=0.0d0
 818       gcorr6_turn_max=0.0d0
 819       gsccorc_max=0.0d0
 820       gscloc_max=0.0d0
 821       gvdwx_max=0.0d0
 822       gradx_scp_max=0.0d0
 823       ghpbx_max=0.0d0
 824       gradxorr_max=0.0d0
 825       gsccorx_max=0.0d0
 826       gsclocx_max=0.0d0
 827       do i=1,nct
 828         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 829         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 830         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 831         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 832      &   gvdwc_scp_max=gvdwc_scp_norm
 833         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 834         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 835         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 836         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 837         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 838         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 839         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 840         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 841         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 842         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 843         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 844         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 845         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 846      &    gcorr3_turn(1,i)))
 847         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 848      &    gcorr3_turn_max=gcorr3_turn_norm
 849         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 850      &    gcorr4_turn(1,i)))
 851         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 852      &    gcorr4_turn_max=gcorr4_turn_norm
 853         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 854         if (gradcorr5_norm.gt.gradcorr5_max)
 855      &    gradcorr5_max=gradcorr5_norm
 856         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 857         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 858         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 859      &    gcorr6_turn(1,i)))
 860         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 861      &    gcorr6_turn_max=gcorr6_turn_norm
 862         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 863         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 864         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 865         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 866         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 867         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 868         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 869         if (gradx_scp_norm.gt.gradx_scp_max)
 870      &    gradx_scp_max=gradx_scp_norm
 871         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 872         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 873         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 874         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 875         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 876         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 877         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 878         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 879       enddo
 880       if (gradout) then
 881 #ifdef AIX
 882         open(istat,file=statname,position="append")
 883 #else
 884         open(istat,file=statname,access="append")
 885 #endif
 886         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 887      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 888      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 889      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 890      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 891      &     gsccorx_max,gsclocx_max
 892         close(istat)
 893         if (gvdwc_max.gt.1.0d4) then
 894           write (iout,*) "gvdwc gvdwx gradb gradbx"
 895           do i=nnt,nct
 896             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 897      &        gradb(j,i),gradbx(j,i),j=1,3)
 898           enddo
 899           call pdbout(0.0d0,'cipiszcze',iout)
 900           call flush(iout)
 901         endif
 902       endif
 903       endif
 904 #ifdef DEBUG
 905       write (iout,*) "gradc gradx gloc"
 906       do i=1,nres
 907         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 908      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 909       enddo
 910 #endif
 911 #ifdef TIMING
 912       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 913 #endif
 914       return
 915       end
 916 c-------------------------------------------------------------------------------
 917       subroutine rescale_weights(t_bath)
 918       implicit real*8 (a-h,o-z)
 919       include 'DIMENSIONS'
 920       include 'COMMON.IOUNITS'
 921       include 'COMMON.FFIELD'
 922       include 'COMMON.SBRIDGE'
 923       double precision kfac /2.4d0/
 924       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 925 c      facT=temp0/t_bath
 926 c      facT=2*temp0/(t_bath+temp0)
 927       if (rescale_mode.eq.0) then
 928         facT=1.0d0
 929         facT2=1.0d0
 930         facT3=1.0d0
 931         facT4=1.0d0
 932         facT5=1.0d0
 933       else if (rescale_mode.eq.1) then
 934         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 935         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 936         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 937         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 938         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 939       else if (rescale_mode.eq.2) then
 940         x=t_bath/temp0
 941         x2=x*x
 942         x3=x2*x
 943         x4=x3*x
 944         x5=x4*x
 945         facT=licznik/dlog(dexp(x)+dexp(-x))
 946         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 947         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 948         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 949         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 950       else
 951         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 952         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 953 #ifdef MPI
 954        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 955 #endif
 956        stop 555
 957       endif
 958       welec=weights(3)*fact
 959       wcorr=weights(4)*fact3
 960       wcorr5=weights(5)*fact4
 961       wcorr6=weights(6)*fact5
 962       wel_loc=weights(7)*fact2
 963       wturn3=weights(8)*fact2
 964       wturn4=weights(9)*fact3
 965       wturn6=weights(10)*fact5
 966       wtor=weights(13)*fact
 967       wtor_d=weights(14)*fact2
 968       wsccor=weights(21)*fact
 969
 970       return
 971       end
 972 C------------------------------------------------------------------------
 973       subroutine enerprint(energia)
 974       implicit real*8 (a-h,o-z)
 975       include 'DIMENSIONS'
 976       include 'COMMON.IOUNITS'
 977       include 'COMMON.FFIELD'
 978       include 'COMMON.SBRIDGE'
 979       include 'COMMON.MD'
 980       double precision energia(0:n_ene)
 981       etot=energia(0)
 982       evdw=energia(1)
 983       evdw2=energia(2)
 984 #ifdef SCP14
 985       evdw2=energia(2)+energia(18)
 986 #else
 987       evdw2=energia(2)
 988 #endif
 989       ees=energia(3)
 990 #ifdef SPLITELE
 991       evdw1=energia(16)
 992 #endif
 993       ecorr=energia(4)
 994       ecorr5=energia(5)
 995       ecorr6=energia(6)
 996       eel_loc=energia(7)
 997       eello_turn3=energia(8)
 998       eello_turn4=energia(9)
 999       eello_turn6=energia(10)
1000       ebe=energia(11)
1001       escloc=energia(12)
1002       etors=energia(13)
1003       etors_d=energia(14)
1004       ehpb=energia(15)
1005       edihcnstr=energia(19)
1006       estr=energia(17)
1007       Uconst=energia(20)
1008       esccor=energia(21)
1009       eliptran=energia(22)
1010       Eafmforce=energia(23)
1011 #ifdef SPLITELE
1012       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1013      &  estr,wbond,ebe,wang,
1014      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1015      &  ecorr,wcorr,
1016      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1017      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1018      &  edihcnstr,ebr*nss,
1019      &  Uconst,eliptran,wliptran,Eafmforce,etot
1020    10 format (/'Virtual-chain energies:'//
1021      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1022      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1023      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1024      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1025      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1026      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1027      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1028      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1029      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1030      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1031      & ' (SS bridges & dist. cnstr.)'/
1032      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1033      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1034      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1035      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1036      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1037      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1038      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1039      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1040      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1041      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1042      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1043      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1044      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1045      & 'ETOT=  ',1pE16.6,' (total)')
1046
1047 #else
1048       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1049      &  estr,wbond,ebe,wang,
1050      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1051      &  ecorr,wcorr,
1052      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1053      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1054      &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
1055    10 format (/'Virtual-chain energies:'//
1056      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1057      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1058      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1059      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1060      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1061      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1062      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1063      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1064      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1065      & ' (SS bridges & dist. cnstr.)'/
1066      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1067      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1068      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1069      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1070      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1071      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1072      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1073      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1074      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1075      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1076      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1077      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1078      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1079      & 'ETOT=  ',1pE16.6,' (total)')
1080 #endif
1081       return
1082       end
1083 C-----------------------------------------------------------------------
1084       subroutine elj(evdw)
1085 C
1086 C This subroutine calculates the interaction energy of nonbonded side chains
1087 C assuming the LJ potential of interaction.
1088 C
1089       implicit real*8 (a-h,o-z)
1090       include 'DIMENSIONS'
1091       parameter (accur=1.0d-10)
1092       include 'COMMON.GEO'
1093       include 'COMMON.VAR'
1094       include 'COMMON.LOCAL'
1095       include 'COMMON.CHAIN'
1096       include 'COMMON.DERIV'
1097       include 'COMMON.INTERACT'
1098       include 'COMMON.TORSION'
1099       include 'COMMON.SBRIDGE'
1100       include 'COMMON.NAMES'
1101       include 'COMMON.IOUNITS'
1102       include 'COMMON.CONTACTS'
1103       dimension gg(3)
1104 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1105       evdw=0.0D0
1106       do i=iatsc_s,iatsc_e
1107         itypi=iabs(itype(i))
1108         if (itypi.eq.ntyp1) cycle
1109         itypi1=iabs(itype(i+1))
1110         xi=c(1,nres+i)
1111         yi=c(2,nres+i)
1112         zi=c(3,nres+i)
1113 C Change 12/1/95
1114         num_conti=0
1115 C
1116 C Calculate SC interaction energy.
1117 C
1118         do iint=1,nint_gr(i)
1119 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1120 cd   &                  'iend=',iend(i,iint)
1121           do j=istart(i,iint),iend(i,iint)
1122             itypj=iabs(itype(j))
1123             if (itypj.eq.ntyp1) cycle
1124             xj=c(1,nres+j)-xi
1125             yj=c(2,nres+j)-yi
1126             zj=c(3,nres+j)-zi
1127 C Change 12/1/95 to calculate four-body interactions
1128             rij=xj*xj+yj*yj+zj*zj
1129             rrij=1.0D0/rij
1130 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1131             eps0ij=eps(itypi,itypj)
1132             fac=rrij**expon2
1133 C have you changed here?
1134             e1=fac*fac*aa
1135             e2=fac*bb
1136             evdwij=e1+e2
1137 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1138 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1139 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1140 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1141 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1142 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1143             evdw=evdw+evdwij
1144 C
1145 C Calculate the components of the gradient in DC and X
1146 C
1147             fac=-rrij*(e1+evdwij)
1148             gg(1)=xj*fac
1149             gg(2)=yj*fac
1150             gg(3)=zj*fac
1151             do k=1,3
1152               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1153               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1154               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1155               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1156             enddo
1157 cgrad            do k=i,j-1
1158 cgrad              do l=1,3
1159 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1160 cgrad              enddo
1161 cgrad            enddo
1162 C
1163 C 12/1/95, revised on 5/20/97
1164 C
1165 C Calculate the contact function. The ith column of the array JCONT will
1166 C contain the numbers of atoms that make contacts with the atom I (of numbers
1167 C greater than I). The arrays FACONT and GACONT will contain the values of
1168 C the contact function and its derivative.
1169 C
1170 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1171 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1172 C Uncomment next line, if the correlation interactions are contact function only
1173             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1174               rij=dsqrt(rij)
1175               sigij=sigma(itypi,itypj)
1176               r0ij=rs0(itypi,itypj)
1177 C
1178 C Check whether the SC's are not too far to make a contact.
1179 C
1180               rcut=1.5d0*r0ij
1181               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1182 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1183 C
1184               if (fcont.gt.0.0D0) then
1185 C If the SC-SC distance if close to sigma, apply spline.
1186 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1187 cAdam &             fcont1,fprimcont1)
1188 cAdam           fcont1=1.0d0-fcont1
1189 cAdam           if (fcont1.gt.0.0d0) then
1190 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1191 cAdam             fcont=fcont*fcont1
1192 cAdam           endif
1193 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1194 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1195 cga             do k=1,3
1196 cga               gg(k)=gg(k)*eps0ij
1197 cga             enddo
1198 cga             eps0ij=-evdwij*eps0ij
1199 C Uncomment for AL's type of SC correlation interactions.
1200 cadam           eps0ij=-evdwij
1201                 num_conti=num_conti+1
1202                 jcont(num_conti,i)=j
1203                 facont(num_conti,i)=fcont*eps0ij
1204                 fprimcont=eps0ij*fprimcont/rij
1205                 fcont=expon*fcont
1206 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1207 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1208 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1209 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1210                 gacont(1,num_conti,i)=-fprimcont*xj
1211                 gacont(2,num_conti,i)=-fprimcont*yj
1212                 gacont(3,num_conti,i)=-fprimcont*zj
1213 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1214 cd              write (iout,'(2i3,3f10.5)')
1215 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1216               endif
1217             endif
1218           enddo      ! j
1219         enddo        ! iint
1220 C Change 12/1/95
1221         num_cont(i)=num_conti
1222       enddo          ! i
1223       do i=1,nct
1224         do j=1,3
1225           gvdwc(j,i)=expon*gvdwc(j,i)
1226           gvdwx(j,i)=expon*gvdwx(j,i)
1227         enddo
1228       enddo
1229 C******************************************************************************
1230 C
1231 C                              N O T E !!!
1232 C
1233 C To save time, the factor of EXPON has been extracted from ALL components
1234 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1235 C use!
1236 C
1237 C******************************************************************************
1238       return
1239       end
1240 C-----------------------------------------------------------------------------
1241       subroutine eljk(evdw)
1242 C
1243 C This subroutine calculates the interaction energy of nonbonded side chains
1244 C assuming the LJK potential of interaction.
1245 C
1246       implicit real*8 (a-h,o-z)
1247       include 'DIMENSIONS'
1248       include 'COMMON.GEO'
1249       include 'COMMON.VAR'
1250       include 'COMMON.LOCAL'
1251       include 'COMMON.CHAIN'
1252       include 'COMMON.DERIV'
1253       include 'COMMON.INTERACT'
1254       include 'COMMON.IOUNITS'
1255       include 'COMMON.NAMES'
1256       dimension gg(3)
1257       logical scheck
1258 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1259       evdw=0.0D0
1260       do i=iatsc_s,iatsc_e
1261         itypi=iabs(itype(i))
1262         if (itypi.eq.ntyp1) cycle
1263         itypi1=iabs(itype(i+1))
1264         xi=c(1,nres+i)
1265         yi=c(2,nres+i)
1266         zi=c(3,nres+i)
1267 C
1268 C Calculate SC interaction energy.
1269 C
1270         do iint=1,nint_gr(i)
1271           do j=istart(i,iint),iend(i,iint)
1272             itypj=iabs(itype(j))
1273             if (itypj.eq.ntyp1) cycle
1274             xj=c(1,nres+j)-xi
1275             yj=c(2,nres+j)-yi
1276             zj=c(3,nres+j)-zi
1277             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1278             fac_augm=rrij**expon
1279             e_augm=augm(itypi,itypj)*fac_augm
1280             r_inv_ij=dsqrt(rrij)
1281             rij=1.0D0/r_inv_ij
1282             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1283             fac=r_shift_inv**expon
1284 C have you changed here?
1285             e1=fac*fac*aa
1286             e2=fac*bb
1287             evdwij=e_augm+e1+e2
1288 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1289 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1290 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1291 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1292 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1293 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1294 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1295             evdw=evdw+evdwij
1296 C
1297 C Calculate the components of the gradient in DC and X
1298 C
1299             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1300             gg(1)=xj*fac
1301             gg(2)=yj*fac
1302             gg(3)=zj*fac
1303             do k=1,3
1304               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1305               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1306               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1307               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1308             enddo
1309 cgrad            do k=i,j-1
1310 cgrad              do l=1,3
1311 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1312 cgrad              enddo
1313 cgrad            enddo
1314           enddo      ! j
1315         enddo        ! iint
1316       enddo          ! i
1317       do i=1,nct
1318         do j=1,3
1319           gvdwc(j,i)=expon*gvdwc(j,i)
1320           gvdwx(j,i)=expon*gvdwx(j,i)
1321         enddo
1322       enddo
1323       return
1324       end
1325 C-----------------------------------------------------------------------------
1326       subroutine ebp(evdw)
1327 C
1328 C This subroutine calculates the interaction energy of nonbonded side chains
1329 C assuming the Berne-Pechukas potential of interaction.
1330 C
1331       implicit real*8 (a-h,o-z)
1332       include 'DIMENSIONS'
1333       include 'COMMON.GEO'
1334       include 'COMMON.VAR'
1335       include 'COMMON.LOCAL'
1336       include 'COMMON.CHAIN'
1337       include 'COMMON.DERIV'
1338       include 'COMMON.NAMES'
1339       include 'COMMON.INTERACT'
1340       include 'COMMON.IOUNITS'
1341       include 'COMMON.CALC'
1342       common /srutu/ icall
1343 c     double precision rrsave(maxdim)
1344       logical lprn
1345       evdw=0.0D0
1346 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1347       evdw=0.0D0
1348 c     if (icall.eq.0) then
1349 c       lprn=.true.
1350 c     else
1351         lprn=.false.
1352 c     endif
1353       ind=0
1354       do i=iatsc_s,iatsc_e
1355         itypi=iabs(itype(i))
1356         if (itypi.eq.ntyp1) cycle
1357         itypi1=iabs(itype(i+1))
1358         xi=c(1,nres+i)
1359         yi=c(2,nres+i)
1360         zi=c(3,nres+i)
1361         dxi=dc_norm(1,nres+i)
1362         dyi=dc_norm(2,nres+i)
1363         dzi=dc_norm(3,nres+i)
1364 c        dsci_inv=dsc_inv(itypi)
1365         dsci_inv=vbld_inv(i+nres)
1366 C
1367 C Calculate SC interaction energy.
1368 C
1369         do iint=1,nint_gr(i)
1370           do j=istart(i,iint),iend(i,iint)
1371             ind=ind+1
1372             itypj=iabs(itype(j))
1373             if (itypj.eq.ntyp1) cycle
1374 c            dscj_inv=dsc_inv(itypj)
1375             dscj_inv=vbld_inv(j+nres)
1376             chi1=chi(itypi,itypj)
1377             chi2=chi(itypj,itypi)
1378             chi12=chi1*chi2
1379             chip1=chip(itypi)
1380             chip2=chip(itypj)
1381             chip12=chip1*chip2
1382             alf1=alp(itypi)
1383             alf2=alp(itypj)
1384             alf12=0.5D0*(alf1+alf2)
1385 C For diagnostics only!!!
1386 c           chi1=0.0D0
1387 c           chi2=0.0D0
1388 c           chi12=0.0D0
1389 c           chip1=0.0D0
1390 c           chip2=0.0D0
1391 c           chip12=0.0D0
1392 c           alf1=0.0D0
1393 c           alf2=0.0D0
1394 c           alf12=0.0D0
1395             xj=c(1,nres+j)-xi
1396             yj=c(2,nres+j)-yi
1397             zj=c(3,nres+j)-zi
1398             dxj=dc_norm(1,nres+j)
1399             dyj=dc_norm(2,nres+j)
1400             dzj=dc_norm(3,nres+j)
1401             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1402 cd          if (icall.eq.0) then
1403 cd            rrsave(ind)=rrij
1404 cd          else
1405 cd            rrij=rrsave(ind)
1406 cd          endif
1407             rij=dsqrt(rrij)
1408 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1409             call sc_angular
1410 C Calculate whole angle-dependent part of epsilon and contributions
1411 C to its derivatives
1412 C have you changed here?
1413             fac=(rrij*sigsq)**expon2
1414             e1=fac*fac*aa
1415             e2=fac*bb
1416             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1417             eps2der=evdwij*eps3rt
1418             eps3der=evdwij*eps2rt
1419             evdwij=evdwij*eps2rt*eps3rt
1420             evdw=evdw+evdwij
1421             if (lprn) then
1422             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1423             epsi=bb**2/aa
1424 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1425 cd     &        restyp(itypi),i,restyp(itypj),j,
1426 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1427 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1428 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1429 cd     &        evdwij
1430             endif
1431 C Calculate gradient components.
1432             e1=e1*eps1*eps2rt**2*eps3rt**2
1433             fac=-expon*(e1+evdwij)
1434             sigder=fac/sigsq
1435             fac=rrij*fac
1436 C Calculate radial part of the gradient
1437             gg(1)=xj*fac
1438             gg(2)=yj*fac
1439             gg(3)=zj*fac
1440 C Calculate the angular part of the gradient and sum add the contributions
1441 C to the appropriate components of the Cartesian gradient.
1442             call sc_grad
1443           enddo      ! j
1444         enddo        ! iint
1445       enddo          ! i
1446 c     stop
1447       return
1448       end
1449 C-----------------------------------------------------------------------------
1450       subroutine egb(evdw)
1451 C
1452 C This subroutine calculates the interaction energy of nonbonded side chains
1453 C assuming the Gay-Berne potential of interaction.
1454 C
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.NAMES'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.IOUNITS'
1465       include 'COMMON.CALC'
1466       include 'COMMON.CONTROL'
1467       include 'COMMON.SPLITELE'
1468       include 'COMMON.SBRIDGE'
1469       logical lprn
1470       integer xshift,yshift,zshift
1471       evdw=0.0D0
1472 ccccc      energy_dec=.false.
1473 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1474       evdw=0.0D0
1475       lprn=.false.
1476 c     if (icall.eq.0) lprn=.false.
1477       ind=0
1478 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1479 C we have the original box)
1480 C      do xshift=-1,1
1481 C      do yshift=-1,1
1482 C      do zshift=-1,1
1483       do i=iatsc_s,iatsc_e
1484         itypi=iabs(itype(i))
1485         if (itypi.eq.ntyp1) cycle
1486         itypi1=iabs(itype(i+1))
1487         xi=c(1,nres+i)
1488         yi=c(2,nres+i)
1489         zi=c(3,nres+i)
1490 C Return atom into box, boxxsize is size of box in x dimension
1491 c  134   continue
1492 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1493 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1494 C Condition for being inside the proper box
1495 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1496 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1497 c        go to 134
1498 c        endif
1499 c  135   continue
1500 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1501 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1502 C Condition for being inside the proper box
1503 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1504 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1505 c        go to 135
1506 c        endif
1507 c  136   continue
1508 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1509 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1510 C Condition for being inside the proper box
1511 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1512 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1513 c        go to 136
1514 c        endif
1515           xi=mod(xi,boxxsize)
1516           if (xi.lt.0) xi=xi+boxxsize
1517           yi=mod(yi,boxysize)
1518           if (yi.lt.0) yi=yi+boxysize
1519           zi=mod(zi,boxzsize)
1520           if (zi.lt.0) zi=zi+boxzsize
1521 C define scaling factor for lipids
1522
1523 C        if (positi.le.0) positi=positi+boxzsize
1524 C        print *,i
1525 C first for peptide groups
1526 c for each residue check if it is in lipid or lipid water border area
1527        if ((zi.gt.bordlipbot)
1528      &.and.(zi.lt.bordliptop)) then
1529 C the energy transfer exist
1530         if (zi.lt.buflipbot) then
1531 C what fraction I am in
1532          fracinbuf=1.0d0-
1533      &        ((zi-bordlipbot)/lipbufthick)
1534 C lipbufthick is thickenes of lipid buffore
1535          sslipi=sscalelip(fracinbuf)
1536          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1537         elseif (zi.gt.bufliptop) then
1538          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1539          sslipi=sscalelip(fracinbuf)
1540          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1541         else
1542          sslipi=1.0d0
1543          ssgradlipi=0.0
1544         endif
1545        else
1546          sslipi=0.0d0
1547          ssgradlipi=0.0
1548        endif
1549
1550 C          xi=xi+xshift*boxxsize
1551 C          yi=yi+yshift*boxysize
1552 C          zi=zi+zshift*boxzsize
1553
1554         dxi=dc_norm(1,nres+i)
1555         dyi=dc_norm(2,nres+i)
1556         dzi=dc_norm(3,nres+i)
1557 c        dsci_inv=dsc_inv(itypi)
1558         dsci_inv=vbld_inv(i+nres)
1559 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1560 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1561 C
1562 C Calculate SC interaction energy.
1563 C
1564         do iint=1,nint_gr(i)
1565           do j=istart(i,iint),iend(i,iint)
1566             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1567               call dyn_ssbond_ene(i,j,evdwij)
1568               evdw=evdw+evdwij
1569               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1570      &                        'evdw',i,j,evdwij,' ss'
1571             ELSE
1572             ind=ind+1
1573             itypj=iabs(itype(j))
1574             if (itypj.eq.ntyp1) cycle
1575 c            dscj_inv=dsc_inv(itypj)
1576             dscj_inv=vbld_inv(j+nres)
1577 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1578 c     &       1.0d0/vbld(j+nres)
1579 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1580             sig0ij=sigma(itypi,itypj)
1581             chi1=chi(itypi,itypj)
1582             chi2=chi(itypj,itypi)
1583             chi12=chi1*chi2
1584             chip1=chip(itypi)
1585             chip2=chip(itypj)
1586             chip12=chip1*chip2
1587             alf1=alp(itypi)
1588             alf2=alp(itypj)
1589             alf12=0.5D0*(alf1+alf2)
1590 C For diagnostics only!!!
1591 c           chi1=0.0D0
1592 c           chi2=0.0D0
1593 c           chi12=0.0D0
1594 c           chip1=0.0D0
1595 c           chip2=0.0D0
1596 c           chip12=0.0D0
1597 c           alf1=0.0D0
1598 c           alf2=0.0D0
1599 c           alf12=0.0D0
1600             xj=c(1,nres+j)
1601             yj=c(2,nres+j)
1602             zj=c(3,nres+j)
1603 C Return atom J into box the original box
1604 c  137   continue
1605 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1606 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1607 C Condition for being inside the proper box
1608 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1609 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1610 c        go to 137
1611 c        endif
1612 c  138   continue
1613 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1614 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1615 C Condition for being inside the proper box
1616 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1617 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1618 c        go to 138
1619 c        endif
1620 c  139   continue
1621 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1622 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1623 C Condition for being inside the proper box
1624 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1625 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1626 c        go to 139
1627 c        endif
1628           xj=mod(xj,boxxsize)
1629           if (xj.lt.0) xj=xj+boxxsize
1630           yj=mod(yj,boxysize)
1631           if (yj.lt.0) yj=yj+boxysize
1632           zj=mod(zj,boxzsize)
1633           if (zj.lt.0) zj=zj+boxzsize
1634        if ((zj.gt.bordlipbot)
1635      &.and.(zj.lt.bordliptop)) then
1636 C the energy transfer exist
1637         if (zj.lt.buflipbot) then
1638 C what fraction I am in
1639          fracinbuf=1.0d0-
1640      &        ((zj-bordlipbot)/lipbufthick)
1641 C lipbufthick is thickenes of lipid buffore
1642          sslipj=sscalelip(fracinbuf)
1643          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1644         elseif (zj.gt.bufliptop) then
1645          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1646          sslipj=sscalelip(fracinbuf)
1647          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1648         else
1649          sslipj=1.0d0
1650          ssgradlipj=0.0
1651         endif
1652        else
1653          sslipj=0.0d0
1654          ssgradlipj=0.0
1655        endif
1656       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1657      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1658       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1659      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1660 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1661 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1662 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1663 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1664       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1665       xj_safe=xj
1666       yj_safe=yj
1667       zj_safe=zj
1668       subchap=0
1669       do xshift=-1,1
1670       do yshift=-1,1
1671       do zshift=-1,1
1672           xj=xj_safe+xshift*boxxsize
1673           yj=yj_safe+yshift*boxysize
1674           zj=zj_safe+zshift*boxzsize
1675           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1676           if(dist_temp.lt.dist_init) then
1677             dist_init=dist_temp
1678             xj_temp=xj
1679             yj_temp=yj
1680             zj_temp=zj
1681             subchap=1
1682           endif
1683        enddo
1684        enddo
1685        enddo
1686        if (subchap.eq.1) then
1687           xj=xj_temp-xi
1688           yj=yj_temp-yi
1689           zj=zj_temp-zi
1690        else
1691           xj=xj_safe-xi
1692           yj=yj_safe-yi
1693           zj=zj_safe-zi
1694        endif
1695             dxj=dc_norm(1,nres+j)
1696             dyj=dc_norm(2,nres+j)
1697             dzj=dc_norm(3,nres+j)
1698 C            xj=xj-xi
1699 C            yj=yj-yi
1700 C            zj=zj-zi
1701 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1702 c            write (iout,*) "j",j," dc_norm",
1703 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1704             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1705             rij=dsqrt(rrij)
1706             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1707             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1708
1709 c            write (iout,'(a7,4f8.3)')
1710 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1711             if (sss.gt.0.0d0) then
1712 C Calculate angle-dependent terms of energy and contributions to their
1713 C derivatives.
1714             call sc_angular
1715             sigsq=1.0D0/sigsq
1716             sig=sig0ij*dsqrt(sigsq)
1717             rij_shift=1.0D0/rij-sig+sig0ij
1718 c for diagnostics; uncomment
1719 c            rij_shift=1.2*sig0ij
1720 C I hate to put IF's in the loops, but here don't have another choice!!!!
1721             if (rij_shift.le.0.0D0) then
1722               evdw=1.0D20
1723 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1724 cd     &        restyp(itypi),i,restyp(itypj),j,
1725 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1726               return
1727             endif
1728             sigder=-sig*sigsq
1729 c---------------------------------------------------------------
1730             rij_shift=1.0D0/rij_shift
1731             fac=rij_shift**expon
1732 C here to start with
1733 C            if (c(i,3).gt.
1734             faclip=fac
1735             e1=fac*fac*aa
1736             e2=fac*bb
1737             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1738             eps2der=evdwij*eps3rt
1739             eps3der=evdwij*eps2rt
1740 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1741 C     &((sslipi+sslipj)/2.0d0+
1742 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1743 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1744 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1745             evdwij=evdwij*eps2rt*eps3rt
1746             evdw=evdw+evdwij*sss
1747             if (lprn) then
1748             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1749             epsi=bb**2/aa
1750             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1751      &        restyp(itypi),i,restyp(itypj),j,
1752      &        epsi,sigm,chi1,chi2,chip1,chip2,
1753      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1754      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1755      &        evdwij
1756             endif
1757
1758             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1759      &                        'evdw',i,j,evdwij
1760
1761 C Calculate gradient components.
1762             e1=e1*eps1*eps2rt**2*eps3rt**2
1763             fac=-expon*(e1+evdwij)*rij_shift
1764             sigder=fac*sigder
1765             fac=rij*fac
1766 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1767 c     &      evdwij,fac,sigma(itypi,itypj),expon
1768             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1769 c            fac=0.0d0
1770 C Calculate the radial part of the gradient
1771             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1772      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1773      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1774      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1775             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1776             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1777 C            gg_lipi(3)=0.0d0
1778 C            gg_lipj(3)=0.0d0
1779             gg(1)=xj*fac
1780             gg(2)=yj*fac
1781             gg(3)=zj*fac
1782 C Calculate angular part of the gradient.
1783             call sc_grad
1784             endif
1785             ENDIF    ! dyn_ss
1786           enddo      ! j
1787         enddo        ! iint
1788       enddo          ! i
1789 C      enddo          ! zshift
1790 C      enddo          ! yshift
1791 C      enddo          ! xshift
1792 c      write (iout,*) "Number of loop steps in EGB:",ind
1793 cccc      energy_dec=.false.
1794       return
1795       end
1796 C-----------------------------------------------------------------------------
1797       subroutine egbv(evdw)
1798 C
1799 C This subroutine calculates the interaction energy of nonbonded side chains
1800 C assuming the Gay-Berne-Vorobjev potential of interaction.
1801 C
1802       implicit real*8 (a-h,o-z)
1803       include 'DIMENSIONS'
1804       include 'COMMON.GEO'
1805       include 'COMMON.VAR'
1806       include 'COMMON.LOCAL'
1807       include 'COMMON.CHAIN'
1808       include 'COMMON.DERIV'
1809       include 'COMMON.NAMES'
1810       include 'COMMON.INTERACT'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CALC'
1813       common /srutu/ icall
1814       logical lprn
1815       evdw=0.0D0
1816 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1817       evdw=0.0D0
1818       lprn=.false.
1819 c     if (icall.eq.0) lprn=.true.
1820       ind=0
1821       do i=iatsc_s,iatsc_e
1822         itypi=iabs(itype(i))
1823         if (itypi.eq.ntyp1) cycle
1824         itypi1=iabs(itype(i+1))
1825         xi=c(1,nres+i)
1826         yi=c(2,nres+i)
1827         zi=c(3,nres+i)
1828           xi=mod(xi,boxxsize)
1829           if (xi.lt.0) xi=xi+boxxsize
1830           yi=mod(yi,boxysize)
1831           if (yi.lt.0) yi=yi+boxysize
1832           zi=mod(zi,boxzsize)
1833           if (zi.lt.0) zi=zi+boxzsize
1834 C define scaling factor for lipids
1835
1836 C        if (positi.le.0) positi=positi+boxzsize
1837 C        print *,i
1838 C first for peptide groups
1839 c for each residue check if it is in lipid or lipid water border area
1840        if ((zi.gt.bordlipbot)
1841      &.and.(zi.lt.bordliptop)) then
1842 C the energy transfer exist
1843         if (zi.lt.buflipbot) then
1844 C what fraction I am in
1845          fracinbuf=1.0d0-
1846      &        ((zi-bordlipbot)/lipbufthick)
1847 C lipbufthick is thickenes of lipid buffore
1848          sslipi=sscalelip(fracinbuf)
1849          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1850         elseif (zi.gt.bufliptop) then
1851          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1852          sslipi=sscalelip(fracinbuf)
1853          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1854         else
1855          sslipi=1.0d0
1856          ssgradlipi=0.0
1857         endif
1858        else
1859          sslipi=0.0d0
1860          ssgradlipi=0.0
1861        endif
1862
1863         dxi=dc_norm(1,nres+i)
1864         dyi=dc_norm(2,nres+i)
1865         dzi=dc_norm(3,nres+i)
1866 c        dsci_inv=dsc_inv(itypi)
1867         dsci_inv=vbld_inv(i+nres)
1868 C
1869 C Calculate SC interaction energy.
1870 C
1871         do iint=1,nint_gr(i)
1872           do j=istart(i,iint),iend(i,iint)
1873             ind=ind+1
1874             itypj=iabs(itype(j))
1875             if (itypj.eq.ntyp1) cycle
1876 c            dscj_inv=dsc_inv(itypj)
1877             dscj_inv=vbld_inv(j+nres)
1878             sig0ij=sigma(itypi,itypj)
1879             r0ij=r0(itypi,itypj)
1880             chi1=chi(itypi,itypj)
1881             chi2=chi(itypj,itypi)
1882             chi12=chi1*chi2
1883             chip1=chip(itypi)
1884             chip2=chip(itypj)
1885             chip12=chip1*chip2
1886             alf1=alp(itypi)
1887             alf2=alp(itypj)
1888             alf12=0.5D0*(alf1+alf2)
1889 C For diagnostics only!!!
1890 c           chi1=0.0D0
1891 c           chi2=0.0D0
1892 c           chi12=0.0D0
1893 c           chip1=0.0D0
1894 c           chip2=0.0D0
1895 c           chip12=0.0D0
1896 c           alf1=0.0D0
1897 c           alf2=0.0D0
1898 c           alf12=0.0D0
1899 C            xj=c(1,nres+j)-xi
1900 C            yj=c(2,nres+j)-yi
1901 C            zj=c(3,nres+j)-zi
1902           xj=mod(xj,boxxsize)
1903           if (xj.lt.0) xj=xj+boxxsize
1904           yj=mod(yj,boxysize)
1905           if (yj.lt.0) yj=yj+boxysize
1906           zj=mod(zj,boxzsize)
1907           if (zj.lt.0) zj=zj+boxzsize
1908        if ((zj.gt.bordlipbot)
1909      &.and.(zj.lt.bordliptop)) then
1910 C the energy transfer exist
1911         if (zj.lt.buflipbot) then
1912 C what fraction I am in
1913          fracinbuf=1.0d0-
1914      &        ((zj-bordlipbot)/lipbufthick)
1915 C lipbufthick is thickenes of lipid buffore
1916          sslipj=sscalelip(fracinbuf)
1917          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1918         elseif (zj.gt.bufliptop) then
1919          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1920          sslipj=sscalelip(fracinbuf)
1921          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1922         else
1923          sslipj=1.0d0
1924          ssgradlipj=0.0
1925         endif
1926        else
1927          sslipj=0.0d0
1928          ssgradlipj=0.0
1929        endif
1930       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1931      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1932       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1933      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1934 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1935 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1936       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1937       xj_safe=xj
1938       yj_safe=yj
1939       zj_safe=zj
1940       subchap=0
1941       do xshift=-1,1
1942       do yshift=-1,1
1943       do zshift=-1,1
1944           xj=xj_safe+xshift*boxxsize
1945           yj=yj_safe+yshift*boxysize
1946           zj=zj_safe+zshift*boxzsize
1947           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1948           if(dist_temp.lt.dist_init) then
1949             dist_init=dist_temp
1950             xj_temp=xj
1951             yj_temp=yj
1952             zj_temp=zj
1953             subchap=1
1954           endif
1955        enddo
1956        enddo
1957        enddo
1958        if (subchap.eq.1) then
1959           xj=xj_temp-xi
1960           yj=yj_temp-yi
1961           zj=zj_temp-zi
1962        else
1963           xj=xj_safe-xi
1964           yj=yj_safe-yi
1965           zj=zj_safe-zi
1966        endif
1967             dxj=dc_norm(1,nres+j)
1968             dyj=dc_norm(2,nres+j)
1969             dzj=dc_norm(3,nres+j)
1970             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1971             rij=dsqrt(rrij)
1972 C Calculate angle-dependent terms of energy and contributions to their
1973 C derivatives.
1974             call sc_angular
1975             sigsq=1.0D0/sigsq
1976             sig=sig0ij*dsqrt(sigsq)
1977             rij_shift=1.0D0/rij-sig+r0ij
1978 C I hate to put IF's in the loops, but here don't have another choice!!!!
1979             if (rij_shift.le.0.0D0) then
1980               evdw=1.0D20
1981               return
1982             endif
1983             sigder=-sig*sigsq
1984 c---------------------------------------------------------------
1985             rij_shift=1.0D0/rij_shift
1986             fac=rij_shift**expon
1987             e1=fac*fac*aa
1988             e2=fac*bb
1989             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1990             eps2der=evdwij*eps3rt
1991             eps3der=evdwij*eps2rt
1992             fac_augm=rrij**expon
1993             e_augm=augm(itypi,itypj)*fac_augm
1994             evdwij=evdwij*eps2rt*eps3rt
1995             evdw=evdw+evdwij+e_augm
1996             if (lprn) then
1997             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1998             epsi=bb**2/aa
1999             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2000      &        restyp(itypi),i,restyp(itypj),j,
2001      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2002      &        chi1,chi2,chip1,chip2,
2003      &        eps1,eps2rt**2,eps3rt**2,
2004      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2005      &        evdwij+e_augm
2006             endif
2007 C Calculate gradient components.
2008             e1=e1*eps1*eps2rt**2*eps3rt**2
2009             fac=-expon*(e1+evdwij)*rij_shift
2010             sigder=fac*sigder
2011             fac=rij*fac-2*expon*rrij*e_augm
2012             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2013 C Calculate the radial part of the gradient
2014             gg(1)=xj*fac
2015             gg(2)=yj*fac
2016             gg(3)=zj*fac
2017 C Calculate angular part of the gradient.
2018             call sc_grad
2019           enddo      ! j
2020         enddo        ! iint
2021       enddo          ! i
2022       end
2023 C-----------------------------------------------------------------------------
2024       subroutine sc_angular
2025 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2026 C om12. Called by ebp, egb, and egbv.
2027       implicit none
2028       include 'COMMON.CALC'
2029       include 'COMMON.IOUNITS'
2030       erij(1)=xj*rij
2031       erij(2)=yj*rij
2032       erij(3)=zj*rij
2033       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2034       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2035       om12=dxi*dxj+dyi*dyj+dzi*dzj
2036       chiom12=chi12*om12
2037 C Calculate eps1(om12) and its derivative in om12
2038       faceps1=1.0D0-om12*chiom12
2039       faceps1_inv=1.0D0/faceps1
2040       eps1=dsqrt(faceps1_inv)
2041 C Following variable is eps1*deps1/dom12
2042       eps1_om12=faceps1_inv*chiom12
2043 c diagnostics only
2044 c      faceps1_inv=om12
2045 c      eps1=om12
2046 c      eps1_om12=1.0d0
2047 c      write (iout,*) "om12",om12," eps1",eps1
2048 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2049 C and om12.
2050       om1om2=om1*om2
2051       chiom1=chi1*om1
2052       chiom2=chi2*om2
2053       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2054       sigsq=1.0D0-facsig*faceps1_inv
2055       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2056       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2057       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2058 c diagnostics only
2059 c      sigsq=1.0d0
2060 c      sigsq_om1=0.0d0
2061 c      sigsq_om2=0.0d0
2062 c      sigsq_om12=0.0d0
2063 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2064 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2065 c     &    " eps1",eps1
2066 C Calculate eps2 and its derivatives in om1, om2, and om12.
2067       chipom1=chip1*om1
2068       chipom2=chip2*om2
2069       chipom12=chip12*om12
2070       facp=1.0D0-om12*chipom12
2071       facp_inv=1.0D0/facp
2072       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2073 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2074 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2075 C Following variable is the square root of eps2
2076       eps2rt=1.0D0-facp1*facp_inv
2077 C Following three variables are the derivatives of the square root of eps
2078 C in om1, om2, and om12.
2079       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2080       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2081       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2082 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2083       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2084 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2085 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2086 c     &  " eps2rt_om12",eps2rt_om12
2087 C Calculate whole angle-dependent part of epsilon and contributions
2088 C to its derivatives
2089       return
2090       end
2091 C----------------------------------------------------------------------------
2092       subroutine sc_grad
2093       implicit real*8 (a-h,o-z)
2094       include 'DIMENSIONS'
2095       include 'COMMON.CHAIN'
2096       include 'COMMON.DERIV'
2097       include 'COMMON.CALC'
2098       include 'COMMON.IOUNITS'
2099       double precision dcosom1(3),dcosom2(3)
2100 cc      print *,'sss=',sss
2101       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2102       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2103       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2104      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2105 c diagnostics only
2106 c      eom1=0.0d0
2107 c      eom2=0.0d0
2108 c      eom12=evdwij*eps1_om12
2109 c end diagnostics
2110 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2111 c     &  " sigder",sigder
2112 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2113 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2114       do k=1,3
2115         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2116         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2117       enddo
2118       do k=1,3
2119         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2120       enddo
2121 c      write (iout,*) "gg",(gg(k),k=1,3)
2122       do k=1,3
2123         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2124      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2125      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2126         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2127      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2128      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2129 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2130 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2131 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2132 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2133       enddo
2134 C
2135 C Calculate the components of the gradient in DC and X
2136 C
2137 cgrad      do k=i,j-1
2138 cgrad        do l=1,3
2139 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2140 cgrad        enddo
2141 cgrad      enddo
2142       do l=1,3
2143         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2144         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2145       enddo
2146       return
2147       end
2148 C-----------------------------------------------------------------------
2149       subroutine e_softsphere(evdw)
2150 C
2151 C This subroutine calculates the interaction energy of nonbonded side chains
2152 C assuming the LJ potential of interaction.
2153 C
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       parameter (accur=1.0d-10)
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.DERIV'
2162       include 'COMMON.INTERACT'
2163       include 'COMMON.TORSION'
2164       include 'COMMON.SBRIDGE'
2165       include 'COMMON.NAMES'
2166       include 'COMMON.IOUNITS'
2167       include 'COMMON.CONTACTS'
2168       dimension gg(3)
2169 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2170       evdw=0.0D0
2171       do i=iatsc_s,iatsc_e
2172         itypi=iabs(itype(i))
2173         if (itypi.eq.ntyp1) cycle
2174         itypi1=iabs(itype(i+1))
2175         xi=c(1,nres+i)
2176         yi=c(2,nres+i)
2177         zi=c(3,nres+i)
2178 C
2179 C Calculate SC interaction energy.
2180 C
2181         do iint=1,nint_gr(i)
2182 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2183 cd   &                  'iend=',iend(i,iint)
2184           do j=istart(i,iint),iend(i,iint)
2185             itypj=iabs(itype(j))
2186             if (itypj.eq.ntyp1) cycle
2187             xj=c(1,nres+j)-xi
2188             yj=c(2,nres+j)-yi
2189             zj=c(3,nres+j)-zi
2190             rij=xj*xj+yj*yj+zj*zj
2191 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2192             r0ij=r0(itypi,itypj)
2193             r0ijsq=r0ij*r0ij
2194 c            print *,i,j,r0ij,dsqrt(rij)
2195             if (rij.lt.r0ijsq) then
2196               evdwij=0.25d0*(rij-r0ijsq)**2
2197               fac=rij-r0ijsq
2198             else
2199               evdwij=0.0d0
2200               fac=0.0d0
2201             endif
2202             evdw=evdw+evdwij
2203 C
2204 C Calculate the components of the gradient in DC and X
2205 C
2206             gg(1)=xj*fac
2207             gg(2)=yj*fac
2208             gg(3)=zj*fac
2209             do k=1,3
2210               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2211               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2212               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2213               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2214             enddo
2215 cgrad            do k=i,j-1
2216 cgrad              do l=1,3
2217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2218 cgrad              enddo
2219 cgrad            enddo
2220           enddo ! j
2221         enddo ! iint
2222       enddo ! i
2223       return
2224       end
2225 C--------------------------------------------------------------------------
2226       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2227      &              eello_turn4)
2228 C
2229 C Soft-sphere potential of p-p interaction
2230 C
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233       include 'COMMON.CONTROL'
2234       include 'COMMON.IOUNITS'
2235       include 'COMMON.GEO'
2236       include 'COMMON.VAR'
2237       include 'COMMON.LOCAL'
2238       include 'COMMON.CHAIN'
2239       include 'COMMON.DERIV'
2240       include 'COMMON.INTERACT'
2241       include 'COMMON.CONTACTS'
2242       include 'COMMON.TORSION'
2243       include 'COMMON.VECTORS'
2244       include 'COMMON.FFIELD'
2245       dimension ggg(3)
2246 C      write(iout,*) 'In EELEC_soft_sphere'
2247       ees=0.0D0
2248       evdw1=0.0D0
2249       eel_loc=0.0d0
2250       eello_turn3=0.0d0
2251       eello_turn4=0.0d0
2252       ind=0
2253       do i=iatel_s,iatel_e
2254         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2255         dxi=dc(1,i)
2256         dyi=dc(2,i)
2257         dzi=dc(3,i)
2258         xmedi=c(1,i)+0.5d0*dxi
2259         ymedi=c(2,i)+0.5d0*dyi
2260         zmedi=c(3,i)+0.5d0*dzi
2261           xmedi=mod(xmedi,boxxsize)
2262           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2263           ymedi=mod(ymedi,boxysize)
2264           if (ymedi.lt.0) ymedi=ymedi+boxysize
2265           zmedi=mod(zmedi,boxzsize)
2266           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2267         num_conti=0
2268 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2269         do j=ielstart(i),ielend(i)
2270           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2271           ind=ind+1
2272           iteli=itel(i)
2273           itelj=itel(j)
2274           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2275           r0ij=rpp(iteli,itelj)
2276           r0ijsq=r0ij*r0ij
2277           dxj=dc(1,j)
2278           dyj=dc(2,j)
2279           dzj=dc(3,j)
2280           xj=c(1,j)+0.5D0*dxj
2281           yj=c(2,j)+0.5D0*dyj
2282           zj=c(3,j)+0.5D0*dzj
2283           xj=mod(xj,boxxsize)
2284           if (xj.lt.0) xj=xj+boxxsize
2285           yj=mod(yj,boxysize)
2286           if (yj.lt.0) yj=yj+boxysize
2287           zj=mod(zj,boxzsize)
2288           if (zj.lt.0) zj=zj+boxzsize
2289       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2290       xj_safe=xj
2291       yj_safe=yj
2292       zj_safe=zj
2293       isubchap=0
2294       do xshift=-1,1
2295       do yshift=-1,1
2296       do zshift=-1,1
2297           xj=xj_safe+xshift*boxxsize
2298           yj=yj_safe+yshift*boxysize
2299           zj=zj_safe+zshift*boxzsize
2300           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2301           if(dist_temp.lt.dist_init) then
2302             dist_init=dist_temp
2303             xj_temp=xj
2304             yj_temp=yj
2305             zj_temp=zj
2306             isubchap=1
2307           endif
2308        enddo
2309        enddo
2310        enddo
2311        if (isubchap.eq.1) then
2312           xj=xj_temp-xmedi
2313           yj=yj_temp-ymedi
2314           zj=zj_temp-zmedi
2315        else
2316           xj=xj_safe-xmedi
2317           yj=yj_safe-ymedi
2318           zj=zj_safe-zmedi
2319        endif
2320           rij=xj*xj+yj*yj+zj*zj
2321             sss=sscale(sqrt(rij))
2322             sssgrad=sscagrad(sqrt(rij))
2323           if (rij.lt.r0ijsq) then
2324             evdw1ij=0.25d0*(rij-r0ijsq)**2
2325             fac=rij-r0ijsq
2326           else
2327             evdw1ij=0.0d0
2328             fac=0.0d0
2329           endif
2330           evdw1=evdw1+evdw1ij*sss
2331 C
2332 C Calculate contributions to the Cartesian gradient.
2333 C
2334           ggg(1)=fac*xj*sssgrad
2335           ggg(2)=fac*yj*sssgrad
2336           ggg(3)=fac*zj*sssgrad
2337           do k=1,3
2338             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2339             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2340           enddo
2341 *
2342 * Loop over residues i+1 thru j-1.
2343 *
2344 cgrad          do k=i+1,j-1
2345 cgrad            do l=1,3
2346 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2347 cgrad            enddo
2348 cgrad          enddo
2349         enddo ! j
2350       enddo   ! i
2351 cgrad      do i=nnt,nct-1
2352 cgrad        do k=1,3
2353 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2354 cgrad        enddo
2355 cgrad        do j=i+1,nct-1
2356 cgrad          do k=1,3
2357 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2358 cgrad          enddo
2359 cgrad        enddo
2360 cgrad      enddo
2361       return
2362       end
2363 c------------------------------------------------------------------------------
2364       subroutine vec_and_deriv
2365       implicit real*8 (a-h,o-z)
2366       include 'DIMENSIONS'
2367 #ifdef MPI
2368       include 'mpif.h'
2369 #endif
2370       include 'COMMON.IOUNITS'
2371       include 'COMMON.GEO'
2372       include 'COMMON.VAR'
2373       include 'COMMON.LOCAL'
2374       include 'COMMON.CHAIN'
2375       include 'COMMON.VECTORS'
2376       include 'COMMON.SETUP'
2377       include 'COMMON.TIME1'
2378       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2379 C Compute the local reference systems. For reference system (i), the
2380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2382 #ifdef PARVEC
2383       do i=ivec_start,ivec_end
2384 #else
2385       do i=1,nres-1
2386 #endif
2387           if (i.eq.nres-1) then
2388 C Case of the last full residue
2389 C Compute the Z-axis
2390             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2391             costh=dcos(pi-theta(nres))
2392             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2393             do k=1,3
2394               uz(k,i)=fac*uz(k,i)
2395             enddo
2396 C Compute the derivatives of uz
2397             uzder(1,1,1)= 0.0d0
2398             uzder(2,1,1)=-dc_norm(3,i-1)
2399             uzder(3,1,1)= dc_norm(2,i-1)
2400             uzder(1,2,1)= dc_norm(3,i-1)
2401             uzder(2,2,1)= 0.0d0
2402             uzder(3,2,1)=-dc_norm(1,i-1)
2403             uzder(1,3,1)=-dc_norm(2,i-1)
2404             uzder(2,3,1)= dc_norm(1,i-1)
2405             uzder(3,3,1)= 0.0d0
2406             uzder(1,1,2)= 0.0d0
2407             uzder(2,1,2)= dc_norm(3,i)
2408             uzder(3,1,2)=-dc_norm(2,i)
2409             uzder(1,2,2)=-dc_norm(3,i)
2410             uzder(2,2,2)= 0.0d0
2411             uzder(3,2,2)= dc_norm(1,i)
2412             uzder(1,3,2)= dc_norm(2,i)
2413             uzder(2,3,2)=-dc_norm(1,i)
2414             uzder(3,3,2)= 0.0d0
2415 C Compute the Y-axis
2416             facy=fac
2417             do k=1,3
2418               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2419             enddo
2420 C Compute the derivatives of uy
2421             do j=1,3
2422               do k=1,3
2423                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2424      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2425                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2426               enddo
2427               uyder(j,j,1)=uyder(j,j,1)-costh
2428               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2429             enddo
2430             do j=1,2
2431               do k=1,3
2432                 do l=1,3
2433                   uygrad(l,k,j,i)=uyder(l,k,j)
2434                   uzgrad(l,k,j,i)=uzder(l,k,j)
2435                 enddo
2436               enddo
2437             enddo
2438             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2439             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2440             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2441             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2442           else
2443 C Other residues
2444 C Compute the Z-axis
2445             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2446             costh=dcos(pi-theta(i+2))
2447             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2448             do k=1,3
2449               uz(k,i)=fac*uz(k,i)
2450             enddo
2451 C Compute the derivatives of uz
2452             uzder(1,1,1)= 0.0d0
2453             uzder(2,1,1)=-dc_norm(3,i+1)
2454             uzder(3,1,1)= dc_norm(2,i+1)
2455             uzder(1,2,1)= dc_norm(3,i+1)
2456             uzder(2,2,1)= 0.0d0
2457             uzder(3,2,1)=-dc_norm(1,i+1)
2458             uzder(1,3,1)=-dc_norm(2,i+1)
2459             uzder(2,3,1)= dc_norm(1,i+1)
2460             uzder(3,3,1)= 0.0d0
2461             uzder(1,1,2)= 0.0d0
2462             uzder(2,1,2)= dc_norm(3,i)
2463             uzder(3,1,2)=-dc_norm(2,i)
2464             uzder(1,2,2)=-dc_norm(3,i)
2465             uzder(2,2,2)= 0.0d0
2466             uzder(3,2,2)= dc_norm(1,i)
2467             uzder(1,3,2)= dc_norm(2,i)
2468             uzder(2,3,2)=-dc_norm(1,i)
2469             uzder(3,3,2)= 0.0d0
2470 C Compute the Y-axis
2471             facy=fac
2472             do k=1,3
2473               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2474             enddo
2475 C Compute the derivatives of uy
2476             do j=1,3
2477               do k=1,3
2478                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2479      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2480                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2481               enddo
2482               uyder(j,j,1)=uyder(j,j,1)-costh
2483               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2484             enddo
2485             do j=1,2
2486               do k=1,3
2487                 do l=1,3
2488                   uygrad(l,k,j,i)=uyder(l,k,j)
2489                   uzgrad(l,k,j,i)=uzder(l,k,j)
2490                 enddo
2491               enddo
2492             enddo
2493             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2494             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2495             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2496             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2497           endif
2498       enddo
2499       do i=1,nres-1
2500         vbld_inv_temp(1)=vbld_inv(i+1)
2501         if (i.lt.nres-1) then
2502           vbld_inv_temp(2)=vbld_inv(i+2)
2503           else
2504           vbld_inv_temp(2)=vbld_inv(i)
2505           endif
2506         do j=1,2
2507           do k=1,3
2508             do l=1,3
2509               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2510               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2511             enddo
2512           enddo
2513         enddo
2514       enddo
2515 #if defined(PARVEC) && defined(MPI)
2516       if (nfgtasks1.gt.1) then
2517         time00=MPI_Wtime()
2518 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2519 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2520 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2521         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2528      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2529      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2530         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2531      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2532      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2533         time_gather=time_gather+MPI_Wtime()-time00
2534       endif
2535 c      if (fg_rank.eq.0) then
2536 c        write (iout,*) "Arrays UY and UZ"
2537 c        do i=1,nres-1
2538 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2539 c     &     (uz(k,i),k=1,3)
2540 c        enddo
2541 c      endif
2542 #endif
2543       return
2544       end
2545 C-----------------------------------------------------------------------------
2546       subroutine check_vecgrad
2547       implicit real*8 (a-h,o-z)
2548       include 'DIMENSIONS'
2549       include 'COMMON.IOUNITS'
2550       include 'COMMON.GEO'
2551       include 'COMMON.VAR'
2552       include 'COMMON.LOCAL'
2553       include 'COMMON.CHAIN'
2554       include 'COMMON.VECTORS'
2555       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2556       dimension uyt(3,maxres),uzt(3,maxres)
2557       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2558       double precision delta /1.0d-7/
2559       call vec_and_deriv
2560 cd      do i=1,nres
2561 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2562 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2563 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2564 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2565 cd     &     (dc_norm(if90,i),if90=1,3)
2566 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2567 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2568 cd          write(iout,'(a)')
2569 cd      enddo
2570       do i=1,nres
2571         do j=1,2
2572           do k=1,3
2573             do l=1,3
2574               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2575               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2576             enddo
2577           enddo
2578         enddo
2579       enddo
2580       call vec_and_deriv
2581       do i=1,nres
2582         do j=1,3
2583           uyt(j,i)=uy(j,i)
2584           uzt(j,i)=uz(j,i)
2585         enddo
2586       enddo
2587       do i=1,nres
2588 cd        write (iout,*) 'i=',i
2589         do k=1,3
2590           erij(k)=dc_norm(k,i)
2591         enddo
2592         do j=1,3
2593           do k=1,3
2594             dc_norm(k,i)=erij(k)
2595           enddo
2596           dc_norm(j,i)=dc_norm(j,i)+delta
2597 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2598 c          do k=1,3
2599 c            dc_norm(k,i)=dc_norm(k,i)/fac
2600 c          enddo
2601 c          write (iout,*) (dc_norm(k,i),k=1,3)
2602 c          write (iout,*) (erij(k),k=1,3)
2603           call vec_and_deriv
2604           do k=1,3
2605             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2606             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2607             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2608             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2609           enddo
2610 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2611 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2612 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2613         enddo
2614         do k=1,3
2615           dc_norm(k,i)=erij(k)
2616         enddo
2617 cd        do k=1,3
2618 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2619 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2620 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2621 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2622 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2623 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2624 cd          write (iout,'(a)')
2625 cd        enddo
2626       enddo
2627       return
2628       end
2629 C--------------------------------------------------------------------------
2630       subroutine set_matrices
2631       implicit real*8 (a-h,o-z)
2632       include 'DIMENSIONS'
2633 #ifdef MPI
2634       include "mpif.h"
2635       include "COMMON.SETUP"
2636       integer IERR
2637       integer status(MPI_STATUS_SIZE)
2638 #endif
2639       include 'COMMON.IOUNITS'
2640       include 'COMMON.GEO'
2641       include 'COMMON.VAR'
2642       include 'COMMON.LOCAL'
2643       include 'COMMON.CHAIN'
2644       include 'COMMON.DERIV'
2645       include 'COMMON.INTERACT'
2646       include 'COMMON.CONTACTS'
2647       include 'COMMON.TORSION'
2648       include 'COMMON.VECTORS'
2649       include 'COMMON.FFIELD'
2650       double precision auxvec(2),auxmat(2,2)
2651 C
2652 C Compute the virtual-bond-torsional-angle dependent quantities needed
2653 C to calculate the el-loc multibody terms of various order.
2654 C
2655 c      write(iout,*) 'nphi=',nphi,nres
2656 #ifdef PARMAT
2657       do i=ivec_start+2,ivec_end+2
2658 #else
2659       do i=3,nres+1
2660 #endif
2661 #ifdef NEWCORR
2662         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2663           iti = itortyp(itype(i-2))
2664         else
2665           iti=ntortyp+1
2666         endif
2667 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2668         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2669           iti1 = itortyp(itype(i-1))
2670         else
2671           iti1=ntortyp+1
2672         endif
2673 c        write(iout,*),i
2674         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2675      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2676      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2677         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2678      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2679      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2680 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2681 c     &*(cos(theta(i)/2.0)
2682         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2683      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2684      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2685 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2686 c     &*(cos(theta(i)/2.0)
2687         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2688      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2689      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2690 c        if (ggb1(1,i).eq.0.0d0) then
2691 c        write(iout,*) 'i=',i,ggb1(1,i),
2692 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2693 c     &bnew1(2,1,iti)*cos(theta(i)),
2694 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2695 c        endif
2696         b1(2,i-2)=bnew1(1,2,iti)
2697         gtb1(2,i-2)=0.0
2698         b2(2,i-2)=bnew2(1,2,iti)
2699         gtb2(2,i-2)=0.0
2700         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2701         EE(1,2,i-2)=eeold(1,2,iti)
2702         EE(2,1,i-2)=eeold(2,1,iti)
2703         EE(2,2,i-2)=eeold(2,2,iti)
2704         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2705         gtEE(1,2,i-2)=0.0d0
2706         gtEE(2,2,i-2)=0.0d0
2707         gtEE(2,1,i-2)=0.0d0
2708 c        EE(2,2,iti)=0.0d0
2709 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2710 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2711 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2712 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2713        b1tilde(1,i-2)=b1(1,i-2)
2714        b1tilde(2,i-2)=-b1(2,i-2)
2715        b2tilde(1,i-2)=b2(1,i-2)
2716        b2tilde(2,i-2)=-b2(2,i-2)
2717 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2718 c       write(iout,*)  'b1=',b1(1,i-2)
2719 c       write (iout,*) 'theta=', theta(i-1)
2720        enddo
2721 #else
2722         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2723           iti = itortyp(itype(i-2))
2724         else
2725           iti=ntortyp+1
2726         endif
2727 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2728         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2729           iti1 = itortyp(itype(i-1))
2730         else
2731           iti1=ntortyp+1
2732         endif
2733         b1(1,i-2)=b(3,iti)
2734         b1(2,i-2)=b(5,iti)
2735         b2(1,i-2)=b(2,iti)
2736         b2(2,i-2)=b(4,iti)
2737        b1tilde(1,i-2)=b1(1,i-2)
2738        b1tilde(2,i-2)=-b1(2,i-2)
2739        b2tilde(1,i-2)=b2(1,i-2)
2740        b2tilde(2,i-2)=-b2(2,i-2)
2741         EE(1,2,i-2)=eeold(1,2,iti)
2742         EE(2,1,i-2)=eeold(2,1,iti)
2743         EE(2,2,i-2)=eeold(2,2,iti)
2744         EE(1,1,i-2)=eeold(1,1,iti)
2745       enddo
2746 #endif
2747 #ifdef PARMAT
2748       do i=ivec_start+2,ivec_end+2
2749 #else
2750       do i=3,nres+1
2751 #endif
2752         if (i .lt. nres+1) then
2753           sin1=dsin(phi(i))
2754           cos1=dcos(phi(i))
2755           sintab(i-2)=sin1
2756           costab(i-2)=cos1
2757           obrot(1,i-2)=cos1
2758           obrot(2,i-2)=sin1
2759           sin2=dsin(2*phi(i))
2760           cos2=dcos(2*phi(i))
2761           sintab2(i-2)=sin2
2762           costab2(i-2)=cos2
2763           obrot2(1,i-2)=cos2
2764           obrot2(2,i-2)=sin2
2765           Ug(1,1,i-2)=-cos1
2766           Ug(1,2,i-2)=-sin1
2767           Ug(2,1,i-2)=-sin1
2768           Ug(2,2,i-2)= cos1
2769           Ug2(1,1,i-2)=-cos2
2770           Ug2(1,2,i-2)=-sin2
2771           Ug2(2,1,i-2)=-sin2
2772           Ug2(2,2,i-2)= cos2
2773         else
2774           costab(i-2)=1.0d0
2775           sintab(i-2)=0.0d0
2776           obrot(1,i-2)=1.0d0
2777           obrot(2,i-2)=0.0d0
2778           obrot2(1,i-2)=0.0d0
2779           obrot2(2,i-2)=0.0d0
2780           Ug(1,1,i-2)=1.0d0
2781           Ug(1,2,i-2)=0.0d0
2782           Ug(2,1,i-2)=0.0d0
2783           Ug(2,2,i-2)=1.0d0
2784           Ug2(1,1,i-2)=0.0d0
2785           Ug2(1,2,i-2)=0.0d0
2786           Ug2(2,1,i-2)=0.0d0
2787           Ug2(2,2,i-2)=0.0d0
2788         endif
2789         if (i .gt. 3 .and. i .lt. nres+1) then
2790           obrot_der(1,i-2)=-sin1
2791           obrot_der(2,i-2)= cos1
2792           Ugder(1,1,i-2)= sin1
2793           Ugder(1,2,i-2)=-cos1
2794           Ugder(2,1,i-2)=-cos1
2795           Ugder(2,2,i-2)=-sin1
2796           dwacos2=cos2+cos2
2797           dwasin2=sin2+sin2
2798           obrot2_der(1,i-2)=-dwasin2
2799           obrot2_der(2,i-2)= dwacos2
2800           Ug2der(1,1,i-2)= dwasin2
2801           Ug2der(1,2,i-2)=-dwacos2
2802           Ug2der(2,1,i-2)=-dwacos2
2803           Ug2der(2,2,i-2)=-dwasin2
2804         else
2805           obrot_der(1,i-2)=0.0d0
2806           obrot_der(2,i-2)=0.0d0
2807           Ugder(1,1,i-2)=0.0d0
2808           Ugder(1,2,i-2)=0.0d0
2809           Ugder(2,1,i-2)=0.0d0
2810           Ugder(2,2,i-2)=0.0d0
2811           obrot2_der(1,i-2)=0.0d0
2812           obrot2_der(2,i-2)=0.0d0
2813           Ug2der(1,1,i-2)=0.0d0
2814           Ug2der(1,2,i-2)=0.0d0
2815           Ug2der(2,1,i-2)=0.0d0
2816           Ug2der(2,2,i-2)=0.0d0
2817         endif
2818 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2819         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2820           iti = itortyp(itype(i-2))
2821         else
2822           iti=ntortyp
2823         endif
2824 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2825         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2826           iti1 = itortyp(itype(i-1))
2827         else
2828           iti1=ntortyp
2829         endif
2830 cd        write (iout,*) '*******i',i,' iti1',iti
2831 cd        write (iout,*) 'b1',b1(:,iti)
2832 cd        write (iout,*) 'b2',b2(:,iti)
2833 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2834 c        if (i .gt. iatel_s+2) then
2835         if (i .gt. nnt+2) then
2836           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2837 #ifdef NEWCORR
2838           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2839 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2840 #endif
2841 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2842 c     &    EE(1,2,iti),EE(2,2,iti)
2843           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2844           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2845 c          write(iout,*) "Macierz EUG",
2846 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2847 c     &    eug(2,2,i-2)
2848           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2849      &    then
2850           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2851           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2852           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2853           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2854           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2855           endif
2856         else
2857           do k=1,2
2858             Ub2(k,i-2)=0.0d0
2859             Ctobr(k,i-2)=0.0d0
2860             Dtobr2(k,i-2)=0.0d0
2861             do l=1,2
2862               EUg(l,k,i-2)=0.0d0
2863               CUg(l,k,i-2)=0.0d0
2864               DUg(l,k,i-2)=0.0d0
2865               DtUg2(l,k,i-2)=0.0d0
2866             enddo
2867           enddo
2868         endif
2869         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2870         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2871         do k=1,2
2872           muder(k,i-2)=Ub2der(k,i-2)
2873         enddo
2874 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2875         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2876           if (itype(i-1).le.ntyp) then
2877             iti1 = itortyp(itype(i-1))
2878           else
2879             iti1=ntortyp
2880           endif
2881         else
2882           iti1=ntortyp
2883         endif
2884         do k=1,2
2885           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2886         enddo
2887 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2888 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2889 cd        write (iout,*) 'mu1',mu1(:,i-2)
2890 cd        write (iout,*) 'mu2',mu2(:,i-2)
2891         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2892      &  then
2893         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2894         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2895         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2896         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2897         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2898 C Vectors and matrices dependent on a single virtual-bond dihedral.
2899         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2900         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2901         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2902         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2903         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2904         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2905         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2906         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2907         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2908         endif
2909       enddo
2910 C Matrices dependent on two consecutive virtual-bond dihedrals.
2911 C The order of matrices is from left to right.
2912       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2913      &then
2914 c      do i=max0(ivec_start,2),ivec_end
2915       do i=2,nres-1
2916         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2917         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2918         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2919         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2920         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2921         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2922         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2923         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2924       enddo
2925       endif
2926 #if defined(MPI) && defined(PARMAT)
2927 #ifdef DEBUG
2928 c      if (fg_rank.eq.0) then
2929         write (iout,*) "Arrays UG and UGDER before GATHER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     ((ug(l,k,i),l=1,2),k=1,2),
2933      &     ((ugder(l,k,i),l=1,2),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays UG2 and UG2DER"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     ((ug2(l,k,i),l=1,2),k=1,2),
2939      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2940         enddo
2941         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2942         do i=1,nres-1
2943           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2944      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2945      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2946         enddo
2947         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2948         do i=1,nres-1
2949           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2950      &     costab(i),sintab(i),costab2(i),sintab2(i)
2951         enddo
2952         write (iout,*) "Array MUDER"
2953         do i=1,nres-1
2954           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2955         enddo
2956 c      endif
2957 #endif
2958       if (nfgtasks.gt.1) then
2959         time00=MPI_Wtime()
2960 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2961 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2962 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2963 #ifdef MATGATHER
2964         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2965      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2966      &   FG_COMM1,IERR)
2967         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2968      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2969      &   FG_COMM1,IERR)
2970         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2971      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2972      &   FG_COMM1,IERR)
2973         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2974      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2975      &   FG_COMM1,IERR)
2976         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2977      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2978      &   FG_COMM1,IERR)
2979         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2980      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2981      &   FG_COMM1,IERR)
2982         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2983      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2984      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2985         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2986      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2987      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2988         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2989      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2990      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2991         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2992      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2993      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2994         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2995      &  then
2996         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3012      &   ivec_count(fg_rank1),
3013      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3014      &   FG_COMM1,IERR)
3015         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3016      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3017      &   FG_COMM1,IERR)
3018         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3019      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3020      &   FG_COMM1,IERR)
3021         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3022      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3023      &   FG_COMM1,IERR)
3024         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3025      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3026      &   FG_COMM1,IERR)
3027         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3028      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3029      &   FG_COMM1,IERR)
3030         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3031      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3032      &   FG_COMM1,IERR)
3033         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3034      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3035      &   FG_COMM1,IERR)
3036         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3037      &   ivec_count(fg_rank1),
3038      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3042      &   FG_COMM1,IERR)
3043        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3050      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3051      &   FG_COMM1,IERR)
3052         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3053      &   ivec_count(fg_rank1),
3054      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3057      &   ivec_count(fg_rank1),
3058      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3061      &   ivec_count(fg_rank1),
3062      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3063      &   MPI_MAT2,FG_COMM1,IERR)
3064         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3065      &   ivec_count(fg_rank1),
3066      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3067      &   MPI_MAT2,FG_COMM1,IERR)
3068         endif
3069 #else
3070 c Passes matrix info through the ring
3071       isend=fg_rank1
3072       irecv=fg_rank1-1
3073       if (irecv.lt.0) irecv=nfgtasks1-1
3074       iprev=irecv
3075       inext=fg_rank1+1
3076       if (inext.ge.nfgtasks1) inext=0
3077       do i=1,nfgtasks1-1
3078 c        write (iout,*) "isend",isend," irecv",irecv
3079 c        call flush(iout)
3080         lensend=lentyp(isend)
3081         lenrecv=lentyp(irecv)
3082 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3083 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3084 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3085 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3086 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3087 c        write (iout,*) "Gather ROTAT1"
3088 c        call flush(iout)
3089 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3090 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3091 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3092 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3093 c        write (iout,*) "Gather ROTAT2"
3094 c        call flush(iout)
3095         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3096      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3097      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3098      &   iprev,4400+irecv,FG_COMM,status,IERR)
3099 c        write (iout,*) "Gather ROTAT_OLD"
3100 c        call flush(iout)
3101         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3102      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3103      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3104      &   iprev,5500+irecv,FG_COMM,status,IERR)
3105 c        write (iout,*) "Gather PRECOMP11"
3106 c        call flush(iout)
3107         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3108      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3109      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3110      &   iprev,6600+irecv,FG_COMM,status,IERR)
3111 c        write (iout,*) "Gather PRECOMP12"
3112 c        call flush(iout)
3113         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3114      &  then
3115         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3116      &   MPI_ROTAT2(lensend),inext,7700+isend,
3117      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3118      &   iprev,7700+irecv,FG_COMM,status,IERR)
3119 c        write (iout,*) "Gather PRECOMP21"
3120 c        call flush(iout)
3121         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3122      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3123      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3124      &   iprev,8800+irecv,FG_COMM,status,IERR)
3125 c        write (iout,*) "Gather PRECOMP22"
3126 c        call flush(iout)
3127         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3128      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3129      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3130      &   MPI_PRECOMP23(lenrecv),
3131      &   iprev,9900+irecv,FG_COMM,status,IERR)
3132 c        write (iout,*) "Gather PRECOMP23"
3133 c        call flush(iout)
3134         endif
3135         isend=irecv
3136         irecv=irecv-1
3137         if (irecv.lt.0) irecv=nfgtasks1-1
3138       enddo
3139 #endif
3140         time_gather=time_gather+MPI_Wtime()-time00
3141       endif
3142 #ifdef DEBUG
3143 c      if (fg_rank.eq.0) then
3144         write (iout,*) "Arrays UG and UGDER"
3145         do i=1,nres-1
3146           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3147      &     ((ug(l,k,i),l=1,2),k=1,2),
3148      &     ((ugder(l,k,i),l=1,2),k=1,2)
3149         enddo
3150         write (iout,*) "Arrays UG2 and UG2DER"
3151         do i=1,nres-1
3152           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3153      &     ((ug2(l,k,i),l=1,2),k=1,2),
3154      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3155         enddo
3156         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3157         do i=1,nres-1
3158           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3159      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3160      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3161         enddo
3162         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3163         do i=1,nres-1
3164           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3165      &     costab(i),sintab(i),costab2(i),sintab2(i)
3166         enddo
3167         write (iout,*) "Array MUDER"
3168         do i=1,nres-1
3169           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3170         enddo
3171 c      endif
3172 #endif
3173 #endif
3174 cd      do i=1,nres
3175 cd        iti = itortyp(itype(i))
3176 cd        write (iout,*) i
3177 cd        do j=1,2
3178 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3179 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3180 cd        enddo
3181 cd      enddo
3182       return
3183       end
3184 C--------------------------------------------------------------------------
3185       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3186 C
3187 C This subroutine calculates the average interaction energy and its gradient
3188 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3189 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3190 C The potential depends both on the distance of peptide-group centers and on
3191 C the orientation of the CA-CA virtual bonds.
3192 C
3193       implicit real*8 (a-h,o-z)
3194 #ifdef MPI
3195       include 'mpif.h'
3196 #endif
3197       include 'DIMENSIONS'
3198       include 'COMMON.CONTROL'
3199       include 'COMMON.SETUP'
3200       include 'COMMON.IOUNITS'
3201       include 'COMMON.GEO'
3202       include 'COMMON.VAR'
3203       include 'COMMON.LOCAL'
3204       include 'COMMON.CHAIN'
3205       include 'COMMON.DERIV'
3206       include 'COMMON.INTERACT'
3207       include 'COMMON.CONTACTS'
3208       include 'COMMON.TORSION'
3209       include 'COMMON.VECTORS'
3210       include 'COMMON.FFIELD'
3211       include 'COMMON.TIME1'
3212       include 'COMMON.SPLITELE'
3213       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3214      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3215       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3216      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3217       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3218      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3219      &    num_conti,j1,j2
3220 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3221 #ifdef MOMENT
3222       double precision scal_el /1.0d0/
3223 #else
3224       double precision scal_el /0.5d0/
3225 #endif
3226 C 12/13/98
3227 C 13-go grudnia roku pamietnego...
3228       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3229      &                   0.0d0,1.0d0,0.0d0,
3230      &                   0.0d0,0.0d0,1.0d0/
3231 cd      write(iout,*) 'In EELEC'
3232 cd      do i=1,nloctyp
3233 cd        write(iout,*) 'Type',i
3234 cd        write(iout,*) 'B1',B1(:,i)
3235 cd        write(iout,*) 'B2',B2(:,i)
3236 cd        write(iout,*) 'CC',CC(:,:,i)
3237 cd        write(iout,*) 'DD',DD(:,:,i)
3238 cd        write(iout,*) 'EE',EE(:,:,i)
3239 cd      enddo
3240 cd      call check_vecgrad
3241 cd      stop
3242       if (icheckgrad.eq.1) then
3243         do i=1,nres-1
3244           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3245           do k=1,3
3246             dc_norm(k,i)=dc(k,i)*fac
3247           enddo
3248 c          write (iout,*) 'i',i,' fac',fac
3249         enddo
3250       endif
3251       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3252      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3253      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3254 c        call vec_and_deriv
3255 #ifdef TIMING
3256         time01=MPI_Wtime()
3257 #endif
3258         call set_matrices
3259 #ifdef TIMING
3260         time_mat=time_mat+MPI_Wtime()-time01
3261 #endif
3262       endif
3263 cd      do i=1,nres-1
3264 cd        write (iout,*) 'i=',i
3265 cd        do k=1,3
3266 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3267 cd        enddo
3268 cd        do k=1,3
3269 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3270 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3271 cd        enddo
3272 cd      enddo
3273       t_eelecij=0.0d0
3274       ees=0.0D0
3275       evdw1=0.0D0
3276       eel_loc=0.0d0
3277       eello_turn3=0.0d0
3278       eello_turn4=0.0d0
3279       ind=0
3280       do i=1,nres
3281         num_cont_hb(i)=0
3282       enddo
3283 cd      print '(a)','Enter EELEC'
3284 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3285       do i=1,nres
3286         gel_loc_loc(i)=0.0d0
3287         gcorr_loc(i)=0.0d0
3288       enddo
3289 c
3290 c
3291 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3292 C
3293 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3294 C
3295 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3296       do i=iturn3_start,iturn3_end
3297         if (i.le.1) cycle
3298 C        write(iout,*) "tu jest i",i
3299         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3300 C changes suggested by Ana to avoid out of bounds
3301      & .or.((i+4).gt.nres)
3302      & .or.((i-1).le.0)
3303 C end of changes by Ana
3304      &  .or. itype(i+2).eq.ntyp1
3305      &  .or. itype(i+3).eq.ntyp1) cycle
3306         if(i.gt.1)then
3307           if(itype(i-1).eq.ntyp1)cycle
3308         end if
3309         if(i.LT.nres-3)then
3310           if (itype(i+4).eq.ntyp1) cycle
3311         end if
3312         dxi=dc(1,i)
3313         dyi=dc(2,i)
3314         dzi=dc(3,i)
3315         dx_normi=dc_norm(1,i)
3316         dy_normi=dc_norm(2,i)
3317         dz_normi=dc_norm(3,i)
3318         xmedi=c(1,i)+0.5d0*dxi
3319         ymedi=c(2,i)+0.5d0*dyi
3320         zmedi=c(3,i)+0.5d0*dzi
3321           xmedi=mod(xmedi,boxxsize)
3322           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3323           ymedi=mod(ymedi,boxysize)
3324           if (ymedi.lt.0) ymedi=ymedi+boxysize
3325           zmedi=mod(zmedi,boxzsize)
3326           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3327         num_conti=0
3328         call eelecij(i,i+2,ees,evdw1,eel_loc)
3329         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3330         num_cont_hb(i)=num_conti
3331       enddo
3332       do i=iturn4_start,iturn4_end
3333         if (i.le.1) cycle
3334         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3335 C changes suggested by Ana to avoid out of bounds
3336      & .or.((i+5).gt.nres)
3337      & .or.((i-1).le.0)
3338 C end of changes suggested by Ana
3339      &    .or. itype(i+3).eq.ntyp1
3340      &    .or. itype(i+4).eq.ntyp1
3341      &    .or. itype(i+5).eq.ntyp1
3342      &    .or. itype(i).eq.ntyp1
3343      &    .or. itype(i-1).eq.ntyp1
3344      &                             ) cycle
3345         dxi=dc(1,i)
3346         dyi=dc(2,i)
3347         dzi=dc(3,i)
3348         dx_normi=dc_norm(1,i)
3349         dy_normi=dc_norm(2,i)
3350         dz_normi=dc_norm(3,i)
3351         xmedi=c(1,i)+0.5d0*dxi
3352         ymedi=c(2,i)+0.5d0*dyi
3353         zmedi=c(3,i)+0.5d0*dzi
3354 C Return atom into box, boxxsize is size of box in x dimension
3355 c  194   continue
3356 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3357 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3358 C Condition for being inside the proper box
3359 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3360 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3361 c        go to 194
3362 c        endif
3363 c  195   continue
3364 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3365 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3366 C Condition for being inside the proper box
3367 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3368 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3369 c        go to 195
3370 c        endif
3371 c  196   continue
3372 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3373 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3374 C Condition for being inside the proper box
3375 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3376 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3377 c        go to 196
3378 c        endif
3379           xmedi=mod(xmedi,boxxsize)
3380           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3381           ymedi=mod(ymedi,boxysize)
3382           if (ymedi.lt.0) ymedi=ymedi+boxysize
3383           zmedi=mod(zmedi,boxzsize)
3384           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3385
3386         num_conti=num_cont_hb(i)
3387 c        write(iout,*) "JESTEM W PETLI"
3388         call eelecij(i,i+3,ees,evdw1,eel_loc)
3389         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3390      &   call eturn4(i,eello_turn4)
3391         num_cont_hb(i)=num_conti
3392       enddo   ! i
3393 C Loop over all neighbouring boxes
3394 C      do xshift=-1,1
3395 C      do yshift=-1,1
3396 C      do zshift=-1,1
3397 c
3398 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3399 c
3400       do i=iatel_s,iatel_e
3401         if (i.le.1) cycle
3402         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3403 C changes suggested by Ana to avoid out of bounds
3404      & .or.((i+2).gt.nres)
3405      & .or.((i-1).le.0)
3406 C end of changes by Ana
3407      &  .or. itype(i+2).eq.ntyp1
3408      &  .or. itype(i-1).eq.ntyp1
3409      &                ) cycle
3410         dxi=dc(1,i)
3411         dyi=dc(2,i)
3412         dzi=dc(3,i)
3413         dx_normi=dc_norm(1,i)
3414         dy_normi=dc_norm(2,i)
3415         dz_normi=dc_norm(3,i)
3416         xmedi=c(1,i)+0.5d0*dxi
3417         ymedi=c(2,i)+0.5d0*dyi
3418         zmedi=c(3,i)+0.5d0*dzi
3419           xmedi=mod(xmedi,boxxsize)
3420           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3421           ymedi=mod(ymedi,boxysize)
3422           if (ymedi.lt.0) ymedi=ymedi+boxysize
3423           zmedi=mod(zmedi,boxzsize)
3424           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3425 C          xmedi=xmedi+xshift*boxxsize
3426 C          ymedi=ymedi+yshift*boxysize
3427 C          zmedi=zmedi+zshift*boxzsize
3428
3429 C Return tom into box, boxxsize is size of box in x dimension
3430 c  164   continue
3431 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3432 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3433 C Condition for being inside the proper box
3434 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3435 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3436 c        go to 164
3437 c        endif
3438 c  165   continue
3439 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3440 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3441 C Condition for being inside the proper box
3442 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3443 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3444 c        go to 165
3445 c        endif
3446 c  166   continue
3447 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3448 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3449 cC Condition for being inside the proper box
3450 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3451 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3452 c        go to 166
3453 c        endif
3454
3455 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3456         num_conti=num_cont_hb(i)
3457         do j=ielstart(i),ielend(i)
3458 C          write (iout,*) i,j
3459          if (j.le.1) cycle
3460           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3461 C changes suggested by Ana to avoid out of bounds
3462      & .or.((j+2).gt.nres)
3463      & .or.((j-1).le.0)
3464 C end of changes by Ana
3465      & .or.itype(j+2).eq.ntyp1
3466      & .or.itype(j-1).eq.ntyp1
3467      &) cycle
3468           call eelecij(i,j,ees,evdw1,eel_loc)
3469         enddo ! j
3470         num_cont_hb(i)=num_conti
3471       enddo   ! i
3472 C     enddo   ! zshift
3473 C      enddo   ! yshift
3474 C      enddo   ! xshift
3475
3476 c      write (iout,*) "Number of loop steps in EELEC:",ind
3477 cd      do i=1,nres
3478 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3479 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3480 cd      enddo
3481 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3482 ccc      eel_loc=eel_loc+eello_turn3
3483 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3484       return
3485       end
3486 C-------------------------------------------------------------------------------
3487       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3488       implicit real*8 (a-h,o-z)
3489       include 'DIMENSIONS'
3490 #ifdef MPI
3491       include "mpif.h"
3492 #endif
3493       include 'COMMON.CONTROL'
3494       include 'COMMON.IOUNITS'
3495       include 'COMMON.GEO'
3496       include 'COMMON.VAR'
3497       include 'COMMON.LOCAL'
3498       include 'COMMON.CHAIN'
3499       include 'COMMON.DERIV'
3500       include 'COMMON.INTERACT'
3501       include 'COMMON.CONTACTS'
3502       include 'COMMON.TORSION'
3503       include 'COMMON.VECTORS'
3504       include 'COMMON.FFIELD'
3505       include 'COMMON.TIME1'
3506       include 'COMMON.SPLITELE'
3507       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3508      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3509       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3510      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3511      &    gmuij2(4),gmuji2(4)
3512       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3513      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3514      &    num_conti,j1,j2
3515 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3516 #ifdef MOMENT
3517       double precision scal_el /1.0d0/
3518 #else
3519       double precision scal_el /0.5d0/
3520 #endif
3521 C 12/13/98
3522 C 13-go grudnia roku pamietnego...
3523       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3524      &                   0.0d0,1.0d0,0.0d0,
3525      &                   0.0d0,0.0d0,1.0d0/
3526 c          time00=MPI_Wtime()
3527 cd      write (iout,*) "eelecij",i,j
3528 c          ind=ind+1
3529           iteli=itel(i)
3530           itelj=itel(j)
3531           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3532           aaa=app(iteli,itelj)
3533           bbb=bpp(iteli,itelj)
3534           ael6i=ael6(iteli,itelj)
3535           ael3i=ael3(iteli,itelj)
3536           dxj=dc(1,j)
3537           dyj=dc(2,j)
3538           dzj=dc(3,j)
3539           dx_normj=dc_norm(1,j)
3540           dy_normj=dc_norm(2,j)
3541           dz_normj=dc_norm(3,j)
3542 C          xj=c(1,j)+0.5D0*dxj-xmedi
3543 C          yj=c(2,j)+0.5D0*dyj-ymedi
3544 C          zj=c(3,j)+0.5D0*dzj-zmedi
3545           xj=c(1,j)+0.5D0*dxj
3546           yj=c(2,j)+0.5D0*dyj
3547           zj=c(3,j)+0.5D0*dzj
3548           xj=mod(xj,boxxsize)
3549           if (xj.lt.0) xj=xj+boxxsize
3550           yj=mod(yj,boxysize)
3551           if (yj.lt.0) yj=yj+boxysize
3552           zj=mod(zj,boxzsize)
3553           if (zj.lt.0) zj=zj+boxzsize
3554           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3555       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3556       xj_safe=xj
3557       yj_safe=yj
3558       zj_safe=zj
3559       isubchap=0
3560       do xshift=-1,1
3561       do yshift=-1,1
3562       do zshift=-1,1
3563           xj=xj_safe+xshift*boxxsize
3564           yj=yj_safe+yshift*boxysize
3565           zj=zj_safe+zshift*boxzsize
3566           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3567           if(dist_temp.lt.dist_init) then
3568             dist_init=dist_temp
3569             xj_temp=xj
3570             yj_temp=yj
3571             zj_temp=zj
3572             isubchap=1
3573           endif
3574        enddo
3575        enddo
3576        enddo
3577        if (isubchap.eq.1) then
3578           xj=xj_temp-xmedi
3579           yj=yj_temp-ymedi
3580           zj=zj_temp-zmedi
3581        else
3582           xj=xj_safe-xmedi
3583           yj=yj_safe-ymedi
3584           zj=zj_safe-zmedi
3585        endif
3586 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3587 c  174   continue
3588 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3589 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3590 C Condition for being inside the proper box
3591 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3592 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3593 c        go to 174
3594 c        endif
3595 c  175   continue
3596 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3597 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3598 C Condition for being inside the proper box
3599 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3600 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3601 c        go to 175
3602 c        endif
3603 c  176   continue
3604 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3605 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3606 C Condition for being inside the proper box
3607 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3608 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3609 c        go to 176
3610 c        endif
3611 C        endif !endPBC condintion
3612 C        xj=xj-xmedi
3613 C        yj=yj-ymedi
3614 C        zj=zj-zmedi
3615           rij=xj*xj+yj*yj+zj*zj
3616
3617             sss=sscale(sqrt(rij))
3618             sssgrad=sscagrad(sqrt(rij))
3619 c            if (sss.gt.0.0d0) then
3620           rrmij=1.0D0/rij
3621           rij=dsqrt(rij)
3622           rmij=1.0D0/rij
3623           r3ij=rrmij*rmij
3624           r6ij=r3ij*r3ij
3625           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3626           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3627           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3628           fac=cosa-3.0D0*cosb*cosg
3629           ev1=aaa*r6ij*r6ij
3630 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3631           if (j.eq.i+2) ev1=scal_el*ev1
3632           ev2=bbb*r6ij
3633           fac3=ael6i*r6ij
3634           fac4=ael3i*r3ij
3635           evdwij=(ev1+ev2)
3636           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3637           el2=fac4*fac
3638 C MARYSIA
3639           eesij=(el1+el2)
3640 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3641           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3642           ees=ees+eesij
3643           evdw1=evdw1+evdwij*sss
3644 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3645 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3646 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3647 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3648
3649           if (energy_dec) then
3650               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3651      &'evdw1',i,j,evdwij
3652      &,iteli,itelj,aaa,evdw1
3653               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3654           endif
3655
3656 C
3657 C Calculate contributions to the Cartesian gradient.
3658 C
3659 #ifdef SPLITELE
3660           facvdw=-6*rrmij*(ev1+evdwij)*sss
3661           facel=-3*rrmij*(el1+eesij)
3662           fac1=fac
3663           erij(1)=xj*rmij
3664           erij(2)=yj*rmij
3665           erij(3)=zj*rmij
3666 *
3667 * Radial derivatives. First process both termini of the fragment (i,j)
3668 *
3669           ggg(1)=facel*xj
3670           ggg(2)=facel*yj
3671           ggg(3)=facel*zj
3672 c          do k=1,3
3673 c            ghalf=0.5D0*ggg(k)
3674 c            gelc(k,i)=gelc(k,i)+ghalf
3675 c            gelc(k,j)=gelc(k,j)+ghalf
3676 c          enddo
3677 c 9/28/08 AL Gradient compotents will be summed only at the end
3678           do k=1,3
3679             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3680             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3681           enddo
3682 *
3683 * Loop over residues i+1 thru j-1.
3684 *
3685 cgrad          do k=i+1,j-1
3686 cgrad            do l=1,3
3687 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3688 cgrad            enddo
3689 cgrad          enddo
3690           if (sss.gt.0.0) then
3691           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3692           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3693           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3694           else
3695           ggg(1)=0.0
3696           ggg(2)=0.0
3697           ggg(3)=0.0
3698           endif
3699 c          do k=1,3
3700 c            ghalf=0.5D0*ggg(k)
3701 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3702 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3703 c          enddo
3704 c 9/28/08 AL Gradient compotents will be summed only at the end
3705           do k=1,3
3706             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3707             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3708           enddo
3709 *
3710 * Loop over residues i+1 thru j-1.
3711 *
3712 cgrad          do k=i+1,j-1
3713 cgrad            do l=1,3
3714 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3715 cgrad            enddo
3716 cgrad          enddo
3717 #else
3718 C MARYSIA
3719           facvdw=(ev1+evdwij)*sss
3720           facel=(el1+eesij)
3721           fac1=fac
3722           fac=-3*rrmij*(facvdw+facvdw+facel)
3723           erij(1)=xj*rmij
3724           erij(2)=yj*rmij
3725           erij(3)=zj*rmij
3726 *
3727 * Radial derivatives. First process both termini of the fragment (i,j)
3728 *
3729           ggg(1)=fac*xj
3730           ggg(2)=fac*yj
3731           ggg(3)=fac*zj
3732 c          do k=1,3
3733 c            ghalf=0.5D0*ggg(k)
3734 c            gelc(k,i)=gelc(k,i)+ghalf
3735 c            gelc(k,j)=gelc(k,j)+ghalf
3736 c          enddo
3737 c 9/28/08 AL Gradient compotents will be summed only at the end
3738           do k=1,3
3739             gelc_long(k,j)=gelc(k,j)+ggg(k)
3740             gelc_long(k,i)=gelc(k,i)-ggg(k)
3741           enddo
3742 *
3743 * Loop over residues i+1 thru j-1.
3744 *
3745 cgrad          do k=i+1,j-1
3746 cgrad            do l=1,3
3747 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3748 cgrad            enddo
3749 cgrad          enddo
3750 c 9/28/08 AL Gradient compotents will be summed only at the end
3751           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3752           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3753           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3754           do k=1,3
3755             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3756             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3757           enddo
3758 #endif
3759 *
3760 * Angular part
3761 *
3762           ecosa=2.0D0*fac3*fac1+fac4
3763           fac4=-3.0D0*fac4
3764           fac3=-6.0D0*fac3
3765           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3766           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3767           do k=1,3
3768             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3769             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3770           enddo
3771 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3772 cd   &          (dcosg(k),k=1,3)
3773           do k=1,3
3774             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3775           enddo
3776 c          do k=1,3
3777 c            ghalf=0.5D0*ggg(k)
3778 c            gelc(k,i)=gelc(k,i)+ghalf
3779 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3780 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3781 c            gelc(k,j)=gelc(k,j)+ghalf
3782 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3783 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3784 c          enddo
3785 cgrad          do k=i+1,j-1
3786 cgrad            do l=1,3
3787 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3788 cgrad            enddo
3789 cgrad          enddo
3790           do k=1,3
3791             gelc(k,i)=gelc(k,i)
3792      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3793      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3794             gelc(k,j)=gelc(k,j)
3795      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3796      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3797             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3798             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3799           enddo
3800 C MARYSIA
3801 c          endif !sscale
3802           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3803      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3804      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3805 C
3806 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3807 C   energy of a peptide unit is assumed in the form of a second-order
3808 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3809 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3810 C   are computed for EVERY pair of non-contiguous peptide groups.
3811 C
3812
3813           if (j.lt.nres-1) then
3814             j1=j+1
3815             j2=j-1
3816           else
3817             j1=j-1
3818             j2=j-2
3819           endif
3820           kkk=0
3821           lll=0
3822           do k=1,2
3823             do l=1,2
3824               kkk=kkk+1
3825               muij(kkk)=mu(k,i)*mu(l,j)
3826 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3827 #ifdef NEWCORR
3828              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3829 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3830              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3831              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3832 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3833              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3834 #endif
3835             enddo
3836           enddo
3837 cd         write (iout,*) 'EELEC: i',i,' j',j
3838 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3839 cd          write(iout,*) 'muij',muij
3840           ury=scalar(uy(1,i),erij)
3841           urz=scalar(uz(1,i),erij)
3842           vry=scalar(uy(1,j),erij)
3843           vrz=scalar(uz(1,j),erij)
3844           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3845           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3846           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3847           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3848           fac=dsqrt(-ael6i)*r3ij
3849           a22=a22*fac
3850           a23=a23*fac
3851           a32=a32*fac
3852           a33=a33*fac
3853 cd          write (iout,'(4i5,4f10.5)')
3854 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3855 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3856 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3857 cd     &      uy(:,j),uz(:,j)
3858 cd          write (iout,'(4f10.5)')
3859 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3860 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3861 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3862 cd           write (iout,'(9f10.5/)')
3863 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3864 C Derivatives of the elements of A in virtual-bond vectors
3865           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3866           do k=1,3
3867             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3868             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3869             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3870             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3871             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3872             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3873             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3874             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3875             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3876             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3877             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3878             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3879           enddo
3880 C Compute radial contributions to the gradient
3881           facr=-3.0d0*rrmij
3882           a22der=a22*facr
3883           a23der=a23*facr
3884           a32der=a32*facr
3885           a33der=a33*facr
3886           agg(1,1)=a22der*xj
3887           agg(2,1)=a22der*yj
3888           agg(3,1)=a22der*zj
3889           agg(1,2)=a23der*xj
3890           agg(2,2)=a23der*yj
3891           agg(3,2)=a23der*zj
3892           agg(1,3)=a32der*xj
3893           agg(2,3)=a32der*yj
3894           agg(3,3)=a32der*zj
3895           agg(1,4)=a33der*xj
3896           agg(2,4)=a33der*yj
3897           agg(3,4)=a33der*zj
3898 C Add the contributions coming from er
3899           fac3=-3.0d0*fac
3900           do k=1,3
3901             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3902             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3903             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3904             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3905           enddo
3906           do k=1,3
3907 C Derivatives in DC(i)
3908 cgrad            ghalf1=0.5d0*agg(k,1)
3909 cgrad            ghalf2=0.5d0*agg(k,2)
3910 cgrad            ghalf3=0.5d0*agg(k,3)
3911 cgrad            ghalf4=0.5d0*agg(k,4)
3912             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3913      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3914             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3915      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3916             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3917      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3918             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3919      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3920 C Derivatives in DC(i+1)
3921             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3922      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3923             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3924      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3925             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3926      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3927             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3928      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3929 C Derivatives in DC(j)
3930             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3931      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3932             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3933      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3934             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3935      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3936             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3937      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3938 C Derivatives in DC(j+1) or DC(nres-1)
3939             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3940      &      -3.0d0*vryg(k,3)*ury)
3941             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3942      &      -3.0d0*vrzg(k,3)*ury)
3943             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3944      &      -3.0d0*vryg(k,3)*urz)
3945             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3946      &      -3.0d0*vrzg(k,3)*urz)
3947 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3948 cgrad              do l=1,4
3949 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3950 cgrad              enddo
3951 cgrad            endif
3952           enddo
3953           acipa(1,1)=a22
3954           acipa(1,2)=a23
3955           acipa(2,1)=a32
3956           acipa(2,2)=a33
3957           a22=-a22
3958           a23=-a23
3959           do l=1,2
3960             do k=1,3
3961               agg(k,l)=-agg(k,l)
3962               aggi(k,l)=-aggi(k,l)
3963               aggi1(k,l)=-aggi1(k,l)
3964               aggj(k,l)=-aggj(k,l)
3965               aggj1(k,l)=-aggj1(k,l)
3966             enddo
3967           enddo
3968           if (j.lt.nres-1) then
3969             a22=-a22
3970             a32=-a32
3971             do l=1,3,2
3972               do k=1,3
3973                 agg(k,l)=-agg(k,l)
3974                 aggi(k,l)=-aggi(k,l)
3975                 aggi1(k,l)=-aggi1(k,l)
3976                 aggj(k,l)=-aggj(k,l)
3977                 aggj1(k,l)=-aggj1(k,l)
3978               enddo
3979             enddo
3980           else
3981             a22=-a22
3982             a23=-a23
3983             a32=-a32
3984             a33=-a33
3985             do l=1,4
3986               do k=1,3
3987                 agg(k,l)=-agg(k,l)
3988                 aggi(k,l)=-aggi(k,l)
3989                 aggi1(k,l)=-aggi1(k,l)
3990                 aggj(k,l)=-aggj(k,l)
3991                 aggj1(k,l)=-aggj1(k,l)
3992               enddo
3993             enddo
3994           endif
3995           ENDIF ! WCORR
3996           IF (wel_loc.gt.0.0d0) THEN
3997 C Contribution to the local-electrostatic energy coming from the i-j pair
3998           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3999      &     +a33*muij(4)
4000 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4001 c     &                     ' eel_loc_ij',eel_loc_ij
4002 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4003 C Calculate patrial derivative for theta angle
4004 #ifdef NEWCORR
4005          geel_loc_ij=a22*gmuij1(1)
4006      &     +a23*gmuij1(2)
4007      &     +a32*gmuij1(3)
4008      &     +a33*gmuij1(4)
4009 c         write(iout,*) "derivative over thatai"
4010 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4011 c     &   a33*gmuij1(4)
4012          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4013      &      geel_loc_ij*wel_loc
4014 c         write(iout,*) "derivative over thatai-1"
4015 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4016 c     &   a33*gmuij2(4)
4017          geel_loc_ij=
4018      &     a22*gmuij2(1)
4019      &     +a23*gmuij2(2)
4020      &     +a32*gmuij2(3)
4021      &     +a33*gmuij2(4)
4022          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4023      &      geel_loc_ij*wel_loc
4024 c  Derivative over j residue
4025          geel_loc_ji=a22*gmuji1(1)
4026      &     +a23*gmuji1(2)
4027      &     +a32*gmuji1(3)
4028      &     +a33*gmuji1(4)
4029 c         write(iout,*) "derivative over thataj"
4030 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4031 c     &   a33*gmuji1(4)
4032
4033         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4034      &      geel_loc_ji*wel_loc
4035          geel_loc_ji=
4036      &     +a22*gmuji2(1)
4037      &     +a23*gmuji2(2)
4038      &     +a32*gmuji2(3)
4039      &     +a33*gmuji2(4)
4040 c         write(iout,*) "derivative over thataj-1"
4041 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4042 c     &   a33*gmuji2(4)
4043          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4044      &      geel_loc_ji*wel_loc
4045 #endif
4046 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4047
4048           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4049      &            'eelloc',i,j,eel_loc_ij
4050 c           if (eel_loc_ij.ne.0)
4051 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4052 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4053
4054           eel_loc=eel_loc+eel_loc_ij
4055 C Partial derivatives in virtual-bond dihedral angles gamma
4056           if (i.gt.1)
4057      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4058      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4059      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4060           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4061      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4062      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4063 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4064           do l=1,3
4065             ggg(l)=agg(l,1)*muij(1)+
4066      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4067             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4068             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4069 cgrad            ghalf=0.5d0*ggg(l)
4070 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4071 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4072           enddo
4073 cgrad          do k=i+1,j2
4074 cgrad            do l=1,3
4075 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4076 cgrad            enddo
4077 cgrad          enddo
4078 C Remaining derivatives of eello
4079           do l=1,3
4080             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4081      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4082             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4083      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4084             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4085      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4086             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4087      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4088           enddo
4089           ENDIF
4090 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4091 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4092           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4093      &       .and. num_conti.le.maxconts) then
4094 c            write (iout,*) i,j," entered corr"
4095 C
4096 C Calculate the contact function. The ith column of the array JCONT will
4097 C contain the numbers of atoms that make contacts with the atom I (of numbers
4098 C greater than I). The arrays FACONT and GACONT will contain the values of
4099 C the contact function and its derivative.
4100 c           r0ij=1.02D0*rpp(iteli,itelj)
4101 c           r0ij=1.11D0*rpp(iteli,itelj)
4102             r0ij=2.20D0*rpp(iteli,itelj)
4103 c           r0ij=1.55D0*rpp(iteli,itelj)
4104             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4105             if (fcont.gt.0.0D0) then
4106               num_conti=num_conti+1
4107               if (num_conti.gt.maxconts) then
4108                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4109      &                         ' will skip next contacts for this conf.'
4110               else
4111                 jcont_hb(num_conti,i)=j
4112 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4113 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4114                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4115      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4116 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4117 C  terms.
4118                 d_cont(num_conti,i)=rij
4119 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4120 C     --- Electrostatic-interaction matrix ---
4121                 a_chuj(1,1,num_conti,i)=a22
4122                 a_chuj(1,2,num_conti,i)=a23
4123                 a_chuj(2,1,num_conti,i)=a32
4124                 a_chuj(2,2,num_conti,i)=a33
4125 C     --- Gradient of rij
4126                 do kkk=1,3
4127                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4128                 enddo
4129                 kkll=0
4130                 do k=1,2
4131                   do l=1,2
4132                     kkll=kkll+1
4133                     do m=1,3
4134                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4135                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4136                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4137                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4138                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4139                     enddo
4140                   enddo
4141                 enddo
4142                 ENDIF
4143                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4144 C Calculate contact energies
4145                 cosa4=4.0D0*cosa
4146                 wij=cosa-3.0D0*cosb*cosg
4147                 cosbg1=cosb+cosg
4148                 cosbg2=cosb-cosg
4149 c               fac3=dsqrt(-ael6i)/r0ij**3
4150                 fac3=dsqrt(-ael6i)*r3ij
4151 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4152                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4153                 if (ees0tmp.gt.0) then
4154                   ees0pij=dsqrt(ees0tmp)
4155                 else
4156                   ees0pij=0
4157                 endif
4158 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4159                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4160                 if (ees0tmp.gt.0) then
4161                   ees0mij=dsqrt(ees0tmp)
4162                 else
4163                   ees0mij=0
4164                 endif
4165 c               ees0mij=0.0D0
4166                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4167                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4168 C Diagnostics. Comment out or remove after debugging!
4169 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4170 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4171 c               ees0m(num_conti,i)=0.0D0
4172 C End diagnostics.
4173 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4174 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4175 C Angular derivatives of the contact function
4176                 ees0pij1=fac3/ees0pij
4177                 ees0mij1=fac3/ees0mij
4178                 fac3p=-3.0D0*fac3*rrmij
4179                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4180                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4181 c               ees0mij1=0.0D0
4182                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4183                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4184                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4185                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4186                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4187                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4188                 ecosap=ecosa1+ecosa2
4189                 ecosbp=ecosb1+ecosb2
4190                 ecosgp=ecosg1+ecosg2
4191                 ecosam=ecosa1-ecosa2
4192                 ecosbm=ecosb1-ecosb2
4193                 ecosgm=ecosg1-ecosg2
4194 C Diagnostics
4195 c               ecosap=ecosa1
4196 c               ecosbp=ecosb1
4197 c               ecosgp=ecosg1
4198 c               ecosam=0.0D0
4199 c               ecosbm=0.0D0
4200 c               ecosgm=0.0D0
4201 C End diagnostics
4202                 facont_hb(num_conti,i)=fcont
4203                 fprimcont=fprimcont/rij
4204 cd              facont_hb(num_conti,i)=1.0D0
4205 C Following line is for diagnostics.
4206 cd              fprimcont=0.0D0
4207                 do k=1,3
4208                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4209                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4210                 enddo
4211                 do k=1,3
4212                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4213                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4214                 enddo
4215                 gggp(1)=gggp(1)+ees0pijp*xj
4216                 gggp(2)=gggp(2)+ees0pijp*yj
4217                 gggp(3)=gggp(3)+ees0pijp*zj
4218                 gggm(1)=gggm(1)+ees0mijp*xj
4219                 gggm(2)=gggm(2)+ees0mijp*yj
4220                 gggm(3)=gggm(3)+ees0mijp*zj
4221 C Derivatives due to the contact function
4222                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4223                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4224                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4225                 do k=1,3
4226 c
4227 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4228 c          following the change of gradient-summation algorithm.
4229 c
4230 cgrad                  ghalfp=0.5D0*gggp(k)
4231 cgrad                  ghalfm=0.5D0*gggm(k)
4232                   gacontp_hb1(k,num_conti,i)=!ghalfp
4233      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4234      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4235                   gacontp_hb2(k,num_conti,i)=!ghalfp
4236      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4237      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4238                   gacontp_hb3(k,num_conti,i)=gggp(k)
4239                   gacontm_hb1(k,num_conti,i)=!ghalfm
4240      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4241      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4242                   gacontm_hb2(k,num_conti,i)=!ghalfm
4243      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4244      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4245                   gacontm_hb3(k,num_conti,i)=gggm(k)
4246                 enddo
4247 C Diagnostics. Comment out or remove after debugging!
4248 cdiag           do k=1,3
4249 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4250 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4251 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4252 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4253 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4254 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4255 cdiag           enddo
4256               ENDIF ! wcorr
4257               endif  ! num_conti.le.maxconts
4258             endif  ! fcont.gt.0
4259           endif    ! j.gt.i+1
4260           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4261             do k=1,4
4262               do l=1,3
4263                 ghalf=0.5d0*agg(l,k)
4264                 aggi(l,k)=aggi(l,k)+ghalf
4265                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4266                 aggj(l,k)=aggj(l,k)+ghalf
4267               enddo
4268             enddo
4269             if (j.eq.nres-1 .and. i.lt.j-2) then
4270               do k=1,4
4271                 do l=1,3
4272                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4273                 enddo
4274               enddo
4275             endif
4276           endif
4277 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4278       return
4279       end
4280 C-----------------------------------------------------------------------------
4281       subroutine eturn3(i,eello_turn3)
4282 C Third- and fourth-order contributions from turns
4283       implicit real*8 (a-h,o-z)
4284       include 'DIMENSIONS'
4285       include 'COMMON.IOUNITS'
4286       include 'COMMON.GEO'
4287       include 'COMMON.VAR'
4288       include 'COMMON.LOCAL'
4289       include 'COMMON.CHAIN'
4290       include 'COMMON.DERIV'
4291       include 'COMMON.INTERACT'
4292       include 'COMMON.CONTACTS'
4293       include 'COMMON.TORSION'
4294       include 'COMMON.VECTORS'
4295       include 'COMMON.FFIELD'
4296       include 'COMMON.CONTROL'
4297       dimension ggg(3)
4298       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4299      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4300      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4301      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4302      &  auxgmat2(2,2),auxgmatt2(2,2)
4303       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4304      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4305       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4306      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4307      &    num_conti,j1,j2
4308       j=i+2
4309 c      write (iout,*) "eturn3",i,j,j1,j2
4310       a_temp(1,1)=a22
4311       a_temp(1,2)=a23
4312       a_temp(2,1)=a32
4313       a_temp(2,2)=a33
4314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4315 C
4316 C               Third-order contributions
4317 C
4318 C                 (i+2)o----(i+3)
4319 C                      | |
4320 C                      | |
4321 C                 (i+1)o----i
4322 C
4323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4324 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4325         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4326 c auxalary matices for theta gradient
4327 c auxalary matrix for i+1 and constant i+2
4328         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4329 c auxalary matrix for i+2 and constant i+1
4330         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4331         call transpose2(auxmat(1,1),auxmat1(1,1))
4332         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4333         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4334         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4335         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4336         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4337         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4338 C Derivatives in theta
4339         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4340      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4341         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4342      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4343
4344         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4345      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4346 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4347 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4348 cd     &    ' eello_turn3_num',4*eello_turn3_num
4349 C Derivatives in gamma(i)
4350         call matmat2(EUgder(1,1,i+1),EUg(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)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4354 C Derivatives in gamma(i+1)
4355         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4356         call transpose2(auxmat2(1,1),auxmat3(1,1))
4357         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4358         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4359      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4360 C Cartesian derivatives
4361         do l=1,3
4362 c            ghalf1=0.5d0*agg(l,1)
4363 c            ghalf2=0.5d0*agg(l,2)
4364 c            ghalf3=0.5d0*agg(l,3)
4365 c            ghalf4=0.5d0*agg(l,4)
4366           a_temp(1,1)=aggi(l,1)!+ghalf1
4367           a_temp(1,2)=aggi(l,2)!+ghalf2
4368           a_temp(2,1)=aggi(l,3)!+ghalf3
4369           a_temp(2,2)=aggi(l,4)!+ghalf4
4370           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4371           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4372      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4373           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4374           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4375           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4376           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4377           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4378           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4379      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4380           a_temp(1,1)=aggj(l,1)!+ghalf1
4381           a_temp(1,2)=aggj(l,2)!+ghalf2
4382           a_temp(2,1)=aggj(l,3)!+ghalf3
4383           a_temp(2,2)=aggj(l,4)!+ghalf4
4384           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4385           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4386      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4387           a_temp(1,1)=aggj1(l,1)
4388           a_temp(1,2)=aggj1(l,2)
4389           a_temp(2,1)=aggj1(l,3)
4390           a_temp(2,2)=aggj1(l,4)
4391           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4392           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4393      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4394         enddo
4395       return
4396       end
4397 C-------------------------------------------------------------------------------
4398       subroutine eturn4(i,eello_turn4)
4399 C Third- and fourth-order contributions from turns
4400       implicit real*8 (a-h,o-z)
4401       include 'DIMENSIONS'
4402       include 'COMMON.IOUNITS'
4403       include 'COMMON.GEO'
4404       include 'COMMON.VAR'
4405       include 'COMMON.LOCAL'
4406       include 'COMMON.CHAIN'
4407       include 'COMMON.DERIV'
4408       include 'COMMON.INTERACT'
4409       include 'COMMON.CONTACTS'
4410       include 'COMMON.TORSION'
4411       include 'COMMON.VECTORS'
4412       include 'COMMON.FFIELD'
4413       include 'COMMON.CONTROL'
4414       dimension ggg(3)
4415       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4416      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4417      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4418      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4419      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4420      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4421      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4422       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4423      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4424       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4425      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4426      &    num_conti,j1,j2
4427       j=i+3
4428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4429 C
4430 C               Fourth-order contributions
4431 C
4432 C                 (i+3)o----(i+4)
4433 C                     /  |
4434 C               (i+2)o   |
4435 C                     \  |
4436 C                 (i+1)o----i
4437 C
4438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4439 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4440 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4441 c        write(iout,*)"WCHODZE W PROGRAM"
4442         a_temp(1,1)=a22
4443         a_temp(1,2)=a23
4444         a_temp(2,1)=a32
4445         a_temp(2,2)=a33
4446         iti1=itortyp(itype(i+1))
4447         iti2=itortyp(itype(i+2))
4448         iti3=itortyp(itype(i+3))
4449 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4450         call transpose2(EUg(1,1,i+1),e1t(1,1))
4451         call transpose2(Eug(1,1,i+2),e2t(1,1))
4452         call transpose2(Eug(1,1,i+3),e3t(1,1))
4453 C Ematrix derivative in theta
4454         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4455         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4456         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4457         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4458 c       eta1 in derivative theta
4459         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4460         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4461 c       auxgvec is derivative of Ub2 so i+3 theta
4462         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4463 c       auxalary matrix of E i+1
4464         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4465 c        s1=0.0
4466 c        gs1=0.0
4467         s1=scalar2(b1(1,i+2),auxvec(1))
4468 c derivative of theta i+2 with constant i+3
4469         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4470 c derivative of theta i+2 with constant i+2
4471         gs32=scalar2(b1(1,i+2),auxgvec(1))
4472 c derivative of E matix in theta of i+1
4473         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4474
4475         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4476 c       ea31 in derivative theta
4477         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4478         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4479 c auxilary matrix auxgvec of Ub2 with constant E matirx
4480         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4481 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4482         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4483
4484 c        s2=0.0
4485 c        gs2=0.0
4486         s2=scalar2(b1(1,i+1),auxvec(1))
4487 c derivative of theta i+1 with constant i+3
4488         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4489 c derivative of theta i+2 with constant i+1
4490         gs21=scalar2(b1(1,i+1),auxgvec(1))
4491 c derivative of theta i+3 with constant i+1
4492         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4493 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4494 c     &  gtb1(1,i+1)
4495         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4496 c two derivatives over diffetent matrices
4497 c gtae3e2 is derivative over i+3
4498         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4499 c ae3gte2 is derivative over i+2
4500         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4501         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4502 c three possible derivative over theta E matices
4503 c i+1
4504         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4505 c i+2
4506         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4507 c i+3
4508         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4509         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4510
4511         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4512         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4513         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4514
4515         eello_turn4=eello_turn4-(s1+s2+s3)
4516 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4517         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4518      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4519 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4520 cd     &    ' eello_turn4_num',8*eello_turn4_num
4521 #ifdef NEWCORR
4522         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4523      &                  -(gs13+gsE13+gsEE1)*wturn4
4524         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4525      &                    -(gs23+gs21+gsEE2)*wturn4
4526         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4527      &                    -(gs32+gsE31+gsEE3)*wturn4
4528 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4529 c     &   gs2
4530 #endif
4531         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4532      &      'eturn4',i,j,-(s1+s2+s3)
4533 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4534 c     &    ' eello_turn4_num',8*eello_turn4_num
4535 C Derivatives in gamma(i)
4536         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4537         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4538         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4539         s1=scalar2(b1(1,i+2),auxvec(1))
4540         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4541         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4542         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4543 C Derivatives in gamma(i+1)
4544         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4545         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4546         s2=scalar2(b1(1,i+1),auxvec(1))
4547         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4548         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4549         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4550         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4551 C Derivatives in gamma(i+2)
4552         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4553         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4554         s1=scalar2(b1(1,i+2),auxvec(1))
4555         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4556         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4557         s2=scalar2(b1(1,i+1),auxvec(1))
4558         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4559         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4560         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4561         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4562 C Cartesian derivatives
4563 C Derivatives of this turn contributions in DC(i+2)
4564         if (j.lt.nres-1) then
4565           do l=1,3
4566             a_temp(1,1)=agg(l,1)
4567             a_temp(1,2)=agg(l,2)
4568             a_temp(2,1)=agg(l,3)
4569             a_temp(2,2)=agg(l,4)
4570             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4571             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4572             s1=scalar2(b1(1,i+2),auxvec(1))
4573             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4574             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4575             s2=scalar2(b1(1,i+1),auxvec(1))
4576             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4577             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4578             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579             ggg(l)=-(s1+s2+s3)
4580             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4581           enddo
4582         endif
4583 C Remaining derivatives of this turn contribution
4584         do l=1,3
4585           a_temp(1,1)=aggi(l,1)
4586           a_temp(1,2)=aggi(l,2)
4587           a_temp(2,1)=aggi(l,3)
4588           a_temp(2,2)=aggi(l,4)
4589           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4590           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4591           s1=scalar2(b1(1,i+2),auxvec(1))
4592           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4593           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4594           s2=scalar2(b1(1,i+1),auxvec(1))
4595           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4596           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4597           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4598           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4599           a_temp(1,1)=aggi1(l,1)
4600           a_temp(1,2)=aggi1(l,2)
4601           a_temp(2,1)=aggi1(l,3)
4602           a_temp(2,2)=aggi1(l,4)
4603           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4604           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4605           s1=scalar2(b1(1,i+2),auxvec(1))
4606           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4607           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4608           s2=scalar2(b1(1,i+1),auxvec(1))
4609           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4610           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4611           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4612           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4613           a_temp(1,1)=aggj(l,1)
4614           a_temp(1,2)=aggj(l,2)
4615           a_temp(2,1)=aggj(l,3)
4616           a_temp(2,2)=aggj(l,4)
4617           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4618           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4619           s1=scalar2(b1(1,i+2),auxvec(1))
4620           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4621           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4622           s2=scalar2(b1(1,i+1),auxvec(1))
4623           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4624           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4625           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4626           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4627           a_temp(1,1)=aggj1(l,1)
4628           a_temp(1,2)=aggj1(l,2)
4629           a_temp(2,1)=aggj1(l,3)
4630           a_temp(2,2)=aggj1(l,4)
4631           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4632           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4633           s1=scalar2(b1(1,i+2),auxvec(1))
4634           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4635           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4636           s2=scalar2(b1(1,i+1),auxvec(1))
4637           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4638           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4639           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4640 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4641           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4642         enddo
4643       return
4644       end
4645 C-----------------------------------------------------------------------------
4646       subroutine vecpr(u,v,w)
4647       implicit real*8(a-h,o-z)
4648       dimension u(3),v(3),w(3)
4649       w(1)=u(2)*v(3)-u(3)*v(2)
4650       w(2)=-u(1)*v(3)+u(3)*v(1)
4651       w(3)=u(1)*v(2)-u(2)*v(1)
4652       return
4653       end
4654 C-----------------------------------------------------------------------------
4655       subroutine unormderiv(u,ugrad,unorm,ungrad)
4656 C This subroutine computes the derivatives of a normalized vector u, given
4657 C the derivatives computed without normalization conditions, ugrad. Returns
4658 C ungrad.
4659       implicit none
4660       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4661       double precision vec(3)
4662       double precision scalar
4663       integer i,j
4664 c      write (2,*) 'ugrad',ugrad
4665 c      write (2,*) 'u',u
4666       do i=1,3
4667         vec(i)=scalar(ugrad(1,i),u(1))
4668       enddo
4669 c      write (2,*) 'vec',vec
4670       do i=1,3
4671         do j=1,3
4672           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4673         enddo
4674       enddo
4675 c      write (2,*) 'ungrad',ungrad
4676       return
4677       end
4678 C-----------------------------------------------------------------------------
4679       subroutine escp_soft_sphere(evdw2,evdw2_14)
4680 C
4681 C This subroutine calculates the excluded-volume interaction energy between
4682 C peptide-group centers and side chains and its gradient in virtual-bond and
4683 C side-chain vectors.
4684 C
4685       implicit real*8 (a-h,o-z)
4686       include 'DIMENSIONS'
4687       include 'COMMON.GEO'
4688       include 'COMMON.VAR'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.CHAIN'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.INTERACT'
4693       include 'COMMON.FFIELD'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.CONTROL'
4696       dimension ggg(3)
4697       evdw2=0.0D0
4698       evdw2_14=0.0d0
4699       r0_scp=4.5d0
4700 cd    print '(a)','Enter ESCP'
4701 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4702 C      do xshift=-1,1
4703 C      do yshift=-1,1
4704 C      do zshift=-1,1
4705       do i=iatscp_s,iatscp_e
4706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4707         iteli=itel(i)
4708         xi=0.5D0*(c(1,i)+c(1,i+1))
4709         yi=0.5D0*(c(2,i)+c(2,i+1))
4710         zi=0.5D0*(c(3,i)+c(3,i+1))
4711 C Return atom into box, boxxsize is size of box in x dimension
4712 c  134   continue
4713 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4714 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4715 C Condition for being inside the proper box
4716 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4717 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4718 c        go to 134
4719 c        endif
4720 c  135   continue
4721 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4722 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4723 C Condition for being inside the proper box
4724 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4725 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4726 c        go to 135
4727 c c       endif
4728 c  136   continue
4729 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4730 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4731 cC Condition for being inside the proper box
4732 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4733 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4734 c        go to 136
4735 c        endif
4736           xi=mod(xi,boxxsize)
4737           if (xi.lt.0) xi=xi+boxxsize
4738           yi=mod(yi,boxysize)
4739           if (yi.lt.0) yi=yi+boxysize
4740           zi=mod(zi,boxzsize)
4741           if (zi.lt.0) zi=zi+boxzsize
4742 C          xi=xi+xshift*boxxsize
4743 C          yi=yi+yshift*boxysize
4744 C          zi=zi+zshift*boxzsize
4745         do iint=1,nscp_gr(i)
4746
4747         do j=iscpstart(i,iint),iscpend(i,iint)
4748           if (itype(j).eq.ntyp1) cycle
4749           itypj=iabs(itype(j))
4750 C Uncomment following three lines for SC-p interactions
4751 c         xj=c(1,nres+j)-xi
4752 c         yj=c(2,nres+j)-yi
4753 c         zj=c(3,nres+j)-zi
4754 C Uncomment following three lines for Ca-p interactions
4755           xj=c(1,j)
4756           yj=c(2,j)
4757           zj=c(3,j)
4758 c  174   continue
4759 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4760 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4761 C Condition for being inside the proper box
4762 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4763 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4764 c        go to 174
4765 c        endif
4766 c  175   continue
4767 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4768 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4769 cC Condition for being inside the proper box
4770 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4771 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4772 c        go to 175
4773 c        endif
4774 c  176   continue
4775 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4776 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4777 C Condition for being inside the proper box
4778 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4779 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4780 c        go to 176
4781           xj=mod(xj,boxxsize)
4782           if (xj.lt.0) xj=xj+boxxsize
4783           yj=mod(yj,boxysize)
4784           if (yj.lt.0) yj=yj+boxysize
4785           zj=mod(zj,boxzsize)
4786           if (zj.lt.0) zj=zj+boxzsize
4787       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4788       xj_safe=xj
4789       yj_safe=yj
4790       zj_safe=zj
4791       subchap=0
4792       do xshift=-1,1
4793       do yshift=-1,1
4794       do zshift=-1,1
4795           xj=xj_safe+xshift*boxxsize
4796           yj=yj_safe+yshift*boxysize
4797           zj=zj_safe+zshift*boxzsize
4798           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4799           if(dist_temp.lt.dist_init) then
4800             dist_init=dist_temp
4801             xj_temp=xj
4802             yj_temp=yj
4803             zj_temp=zj
4804             subchap=1
4805           endif
4806        enddo
4807        enddo
4808        enddo
4809        if (subchap.eq.1) then
4810           xj=xj_temp-xi
4811           yj=yj_temp-yi
4812           zj=zj_temp-zi
4813        else
4814           xj=xj_safe-xi
4815           yj=yj_safe-yi
4816           zj=zj_safe-zi
4817        endif
4818 c c       endif
4819 C          xj=xj-xi
4820 C          yj=yj-yi
4821 C          zj=zj-zi
4822           rij=xj*xj+yj*yj+zj*zj
4823
4824           r0ij=r0_scp
4825           r0ijsq=r0ij*r0ij
4826           if (rij.lt.r0ijsq) then
4827             evdwij=0.25d0*(rij-r0ijsq)**2
4828             fac=rij-r0ijsq
4829           else
4830             evdwij=0.0d0
4831             fac=0.0d0
4832           endif
4833           evdw2=evdw2+evdwij
4834 C
4835 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4836 C
4837           ggg(1)=xj*fac
4838           ggg(2)=yj*fac
4839           ggg(3)=zj*fac
4840 cgrad          if (j.lt.i) then
4841 cd          write (iout,*) 'j<i'
4842 C Uncomment following three lines for SC-p interactions
4843 c           do k=1,3
4844 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4845 c           enddo
4846 cgrad          else
4847 cd          write (iout,*) 'j>i'
4848 cgrad            do k=1,3
4849 cgrad              ggg(k)=-ggg(k)
4850 C Uncomment following line for SC-p interactions
4851 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4852 cgrad            enddo
4853 cgrad          endif
4854 cgrad          do k=1,3
4855 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4856 cgrad          enddo
4857 cgrad          kstart=min0(i+1,j)
4858 cgrad          kend=max0(i-1,j-1)
4859 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4860 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4861 cgrad          do k=kstart,kend
4862 cgrad            do l=1,3
4863 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4864 cgrad            enddo
4865 cgrad          enddo
4866           do k=1,3
4867             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4868             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4869           enddo
4870         enddo
4871
4872         enddo ! iint
4873       enddo ! i
4874 C      enddo !zshift
4875 C      enddo !yshift
4876 C      enddo !xshift
4877       return
4878       end
4879 C-----------------------------------------------------------------------------
4880       subroutine escp(evdw2,evdw2_14)
4881 C
4882 C This subroutine calculates the excluded-volume interaction energy between
4883 C peptide-group centers and side chains and its gradient in virtual-bond and
4884 C side-chain vectors.
4885 C
4886       implicit real*8 (a-h,o-z)
4887       include 'DIMENSIONS'
4888       include 'COMMON.GEO'
4889       include 'COMMON.VAR'
4890       include 'COMMON.LOCAL'
4891       include 'COMMON.CHAIN'
4892       include 'COMMON.DERIV'
4893       include 'COMMON.INTERACT'
4894       include 'COMMON.FFIELD'
4895       include 'COMMON.IOUNITS'
4896       include 'COMMON.CONTROL'
4897       include 'COMMON.SPLITELE'
4898       dimension ggg(3)
4899       evdw2=0.0D0
4900       evdw2_14=0.0d0
4901 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4902 cd    print '(a)','Enter ESCP'
4903 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4904 C      do xshift=-1,1
4905 C      do yshift=-1,1
4906 C      do zshift=-1,1
4907       do i=iatscp_s,iatscp_e
4908         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4909         iteli=itel(i)
4910         xi=0.5D0*(c(1,i)+c(1,i+1))
4911         yi=0.5D0*(c(2,i)+c(2,i+1))
4912         zi=0.5D0*(c(3,i)+c(3,i+1))
4913           xi=mod(xi,boxxsize)
4914           if (xi.lt.0) xi=xi+boxxsize
4915           yi=mod(yi,boxysize)
4916           if (yi.lt.0) yi=yi+boxysize
4917           zi=mod(zi,boxzsize)
4918           if (zi.lt.0) zi=zi+boxzsize
4919 c          xi=xi+xshift*boxxsize
4920 c          yi=yi+yshift*boxysize
4921 c          zi=zi+zshift*boxzsize
4922 c        print *,xi,yi,zi,'polozenie i'
4923 C Return atom into box, boxxsize is size of box in x dimension
4924 c  134   continue
4925 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4926 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4927 C Condition for being inside the proper box
4928 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4929 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4930 c        go to 134
4931 c        endif
4932 c  135   continue
4933 c          print *,xi,boxxsize,"pierwszy"
4934
4935 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4936 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4937 C Condition for being inside the proper box
4938 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4939 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4940 c        go to 135
4941 c        endif
4942 c  136   continue
4943 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4944 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4945 C Condition for being inside the proper box
4946 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4947 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4948 c        go to 136
4949 c        endif
4950         do iint=1,nscp_gr(i)
4951
4952         do j=iscpstart(i,iint),iscpend(i,iint)
4953           itypj=iabs(itype(j))
4954           if (itypj.eq.ntyp1) cycle
4955 C Uncomment following three lines for SC-p interactions
4956 c         xj=c(1,nres+j)-xi
4957 c         yj=c(2,nres+j)-yi
4958 c         zj=c(3,nres+j)-zi
4959 C Uncomment following three lines for Ca-p interactions
4960           xj=c(1,j)
4961           yj=c(2,j)
4962           zj=c(3,j)
4963           xj=mod(xj,boxxsize)
4964           if (xj.lt.0) xj=xj+boxxsize
4965           yj=mod(yj,boxysize)
4966           if (yj.lt.0) yj=yj+boxysize
4967           zj=mod(zj,boxzsize)
4968           if (zj.lt.0) zj=zj+boxzsize
4969 c  174   continue
4970 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4971 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4972 C Condition for being inside the proper box
4973 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4974 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4975 c        go to 174
4976 c        endif
4977 c  175   continue
4978 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4979 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4980 cC Condition for being inside the proper box
4981 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4982 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4983 c        go to 175
4984 c        endif
4985 c  176   continue
4986 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4987 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4988 C Condition for being inside the proper box
4989 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4990 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4991 c        go to 176
4992 c        endif
4993 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4994       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4995       xj_safe=xj
4996       yj_safe=yj
4997       zj_safe=zj
4998       subchap=0
4999       do xshift=-1,1
5000       do yshift=-1,1
5001       do zshift=-1,1
5002           xj=xj_safe+xshift*boxxsize
5003           yj=yj_safe+yshift*boxysize
5004           zj=zj_safe+zshift*boxzsize
5005           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5006           if(dist_temp.lt.dist_init) then
5007             dist_init=dist_temp
5008             xj_temp=xj
5009             yj_temp=yj
5010             zj_temp=zj
5011             subchap=1
5012           endif
5013        enddo
5014        enddo
5015        enddo
5016        if (subchap.eq.1) then
5017           xj=xj_temp-xi
5018           yj=yj_temp-yi
5019           zj=zj_temp-zi
5020        else
5021           xj=xj_safe-xi
5022           yj=yj_safe-yi
5023           zj=zj_safe-zi
5024        endif
5025 c          print *,xj,yj,zj,'polozenie j'
5026           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5027 c          print *,rrij
5028           sss=sscale(1.0d0/(dsqrt(rrij)))
5029 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5030 c          if (sss.eq.0) print *,'czasem jest OK'
5031           if (sss.le.0.0d0) cycle
5032           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5033           fac=rrij**expon2
5034           e1=fac*fac*aad(itypj,iteli)
5035           e2=fac*bad(itypj,iteli)
5036           if (iabs(j-i) .le. 2) then
5037             e1=scal14*e1
5038             e2=scal14*e2
5039             evdw2_14=evdw2_14+(e1+e2)*sss
5040           endif
5041           evdwij=e1+e2
5042           evdw2=evdw2+evdwij*sss
5043           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5044      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5045      &       bad(itypj,iteli)
5046 C
5047 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5048 C
5049           fac=-(evdwij+e1)*rrij*sss
5050           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5051           ggg(1)=xj*fac
5052           ggg(2)=yj*fac
5053           ggg(3)=zj*fac
5054 cgrad          if (j.lt.i) then
5055 cd          write (iout,*) 'j<i'
5056 C Uncomment following three lines for SC-p interactions
5057 c           do k=1,3
5058 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5059 c           enddo
5060 cgrad          else
5061 cd          write (iout,*) 'j>i'
5062 cgrad            do k=1,3
5063 cgrad              ggg(k)=-ggg(k)
5064 C Uncomment following line for SC-p interactions
5065 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5066 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5067 cgrad            enddo
5068 cgrad          endif
5069 cgrad          do k=1,3
5070 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5071 cgrad          enddo
5072 cgrad          kstart=min0(i+1,j)
5073 cgrad          kend=max0(i-1,j-1)
5074 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5075 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5076 cgrad          do k=kstart,kend
5077 cgrad            do l=1,3
5078 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5079 cgrad            enddo
5080 cgrad          enddo
5081           do k=1,3
5082             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5083             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5084           enddo
5085 c        endif !endif for sscale cutoff
5086         enddo ! j
5087
5088         enddo ! iint
5089       enddo ! i
5090 c      enddo !zshift
5091 c      enddo !yshift
5092 c      enddo !xshift
5093       do i=1,nct
5094         do j=1,3
5095           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5096           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5097           gradx_scp(j,i)=expon*gradx_scp(j,i)
5098         enddo
5099       enddo
5100 C******************************************************************************
5101 C
5102 C                              N O T E !!!
5103 C
5104 C To save time the factor EXPON has been extracted from ALL components
5105 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5106 C use!
5107 C
5108 C******************************************************************************
5109       return
5110       end
5111 C--------------------------------------------------------------------------
5112       subroutine edis(ehpb)
5113 C
5114 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5115 C
5116       implicit real*8 (a-h,o-z)
5117       include 'DIMENSIONS'
5118       include 'COMMON.SBRIDGE'
5119       include 'COMMON.CHAIN'
5120       include 'COMMON.DERIV'
5121       include 'COMMON.VAR'
5122       include 'COMMON.INTERACT'
5123       include 'COMMON.IOUNITS'
5124       dimension ggg(3)
5125       ehpb=0.0D0
5126 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5127 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5128       if (link_end.eq.0) return
5129       do i=link_start,link_end
5130 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5131 C CA-CA distance used in regularization of structure.
5132         ii=ihpb(i)
5133         jj=jhpb(i)
5134 C iii and jjj point to the residues for which the distance is assigned.
5135         if (ii.gt.nres) then
5136           iii=ii-nres
5137           jjj=jj-nres
5138         else
5139           iii=ii
5140           jjj=jj
5141         endif
5142 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5143 c     &    dhpb(i),dhpb1(i),forcon(i)
5144 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5145 C    distance and angle dependent SS bond potential.
5146 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5147 C     & iabs(itype(jjj)).eq.1) then
5148 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5149 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5150         if (.not.dyn_ss .and. i.le.nss) then
5151 C 15/02/13 CC dynamic SSbond - additional check
5152          if (ii.gt.nres
5153      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5154           call ssbond_ene(iii,jjj,eij)
5155           ehpb=ehpb+2*eij
5156          endif
5157 cd          write (iout,*) "eij",eij
5158         else
5159 C Calculate the distance between the two points and its difference from the
5160 C target distance.
5161           dd=dist(ii,jj)
5162             rdis=dd-dhpb(i)
5163 C Get the force constant corresponding to this distance.
5164             waga=forcon(i)
5165 C Calculate the contribution to energy.
5166             ehpb=ehpb+waga*rdis*rdis
5167 C
5168 C Evaluate gradient.
5169 C
5170             fac=waga*rdis/dd
5171 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5172 cd   &   ' waga=',waga,' fac=',fac
5173             do j=1,3
5174               ggg(j)=fac*(c(j,jj)-c(j,ii))
5175             enddo
5176 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5177 C If this is a SC-SC distance, we need to calculate the contributions to the
5178 C Cartesian gradient in the SC vectors (ghpbx).
5179           if (iii.lt.ii) then
5180           do j=1,3
5181             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5182             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5183           enddo
5184           endif
5185 cgrad        do j=iii,jjj-1
5186 cgrad          do k=1,3
5187 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5188 cgrad          enddo
5189 cgrad        enddo
5190           do k=1,3
5191             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5192             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5193           enddo
5194         endif
5195       enddo
5196       ehpb=0.5D0*ehpb
5197       return
5198       end
5199 C--------------------------------------------------------------------------
5200       subroutine ssbond_ene(i,j,eij)
5201 C
5202 C Calculate the distance and angle dependent SS-bond potential energy
5203 C using a free-energy function derived based on RHF/6-31G** ab initio
5204 C calculations of diethyl disulfide.
5205 C
5206 C A. Liwo and U. Kozlowska, 11/24/03
5207 C
5208       implicit real*8 (a-h,o-z)
5209       include 'DIMENSIONS'
5210       include 'COMMON.SBRIDGE'
5211       include 'COMMON.CHAIN'
5212       include 'COMMON.DERIV'
5213       include 'COMMON.LOCAL'
5214       include 'COMMON.INTERACT'
5215       include 'COMMON.VAR'
5216       include 'COMMON.IOUNITS'
5217       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5218       itypi=iabs(itype(i))
5219       xi=c(1,nres+i)
5220       yi=c(2,nres+i)
5221       zi=c(3,nres+i)
5222       dxi=dc_norm(1,nres+i)
5223       dyi=dc_norm(2,nres+i)
5224       dzi=dc_norm(3,nres+i)
5225 c      dsci_inv=dsc_inv(itypi)
5226       dsci_inv=vbld_inv(nres+i)
5227       itypj=iabs(itype(j))
5228 c      dscj_inv=dsc_inv(itypj)
5229       dscj_inv=vbld_inv(nres+j)
5230       xj=c(1,nres+j)-xi
5231       yj=c(2,nres+j)-yi
5232       zj=c(3,nres+j)-zi
5233       dxj=dc_norm(1,nres+j)
5234       dyj=dc_norm(2,nres+j)
5235       dzj=dc_norm(3,nres+j)
5236       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5237       rij=dsqrt(rrij)
5238       erij(1)=xj*rij
5239       erij(2)=yj*rij
5240       erij(3)=zj*rij
5241       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5242       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5243       om12=dxi*dxj+dyi*dyj+dzi*dzj
5244       do k=1,3
5245         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5246         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5247       enddo
5248       rij=1.0d0/rij
5249       deltad=rij-d0cm
5250       deltat1=1.0d0-om1
5251       deltat2=1.0d0+om2
5252       deltat12=om2-om1+2.0d0
5253       cosphi=om12-om1*om2
5254       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5255      &  +akct*deltad*deltat12
5256      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5257 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5258 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5259 c     &  " deltat12",deltat12," eij",eij
5260       ed=2*akcm*deltad+akct*deltat12
5261       pom1=akct*deltad
5262       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5263       eom1=-2*akth*deltat1-pom1-om2*pom2
5264       eom2= 2*akth*deltat2+pom1-om1*pom2
5265       eom12=pom2
5266       do k=1,3
5267         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5268         ghpbx(k,i)=ghpbx(k,i)-ggk
5269      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5270      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5271         ghpbx(k,j)=ghpbx(k,j)+ggk
5272      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5273      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5274         ghpbc(k,i)=ghpbc(k,i)-ggk
5275         ghpbc(k,j)=ghpbc(k,j)+ggk
5276       enddo
5277 C
5278 C Calculate the components of the gradient in DC and X
5279 C
5280 cgrad      do k=i,j-1
5281 cgrad        do l=1,3
5282 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5283 cgrad        enddo
5284 cgrad      enddo
5285       return
5286       end
5287 C--------------------------------------------------------------------------
5288       subroutine ebond(estr)
5289 c
5290 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5291 c
5292       implicit real*8 (a-h,o-z)
5293       include 'DIMENSIONS'
5294       include 'COMMON.LOCAL'
5295       include 'COMMON.GEO'
5296       include 'COMMON.INTERACT'
5297       include 'COMMON.DERIV'
5298       include 'COMMON.VAR'
5299       include 'COMMON.CHAIN'
5300       include 'COMMON.IOUNITS'
5301       include 'COMMON.NAMES'
5302       include 'COMMON.FFIELD'
5303       include 'COMMON.CONTROL'
5304       include 'COMMON.SETUP'
5305       double precision u(3),ud(3)
5306       estr=0.0d0
5307       estr1=0.0d0
5308       do i=ibondp_start,ibondp_end
5309         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5310 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5311 c          do j=1,3
5312 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5313 c     &      *dc(j,i-1)/vbld(i)
5314 c          enddo
5315 c          if (energy_dec) write(iout,*)
5316 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5317 c        else
5318 C       Checking if it involves dummy (NH3+ or COO-) group
5319          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5320 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5321         diff = vbld(i)-vbldpDUM
5322          else
5323 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5324         diff = vbld(i)-vbldp0
5325          endif
5326         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5327      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5328         estr=estr+diff*diff
5329         do j=1,3
5330           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5331         enddo
5332 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5333 c        endif
5334       enddo
5335       estr=0.5d0*AKP*estr+estr1
5336 c
5337 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5338 c
5339       do i=ibond_start,ibond_end
5340         iti=iabs(itype(i))
5341         if (iti.ne.10 .and. iti.ne.ntyp1) then
5342           nbi=nbondterm(iti)
5343           if (nbi.eq.1) then
5344             diff=vbld(i+nres)-vbldsc0(1,iti)
5345             if (energy_dec)  write (iout,*)
5346      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5347      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5348             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5349             do j=1,3
5350               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5351             enddo
5352           else
5353             do j=1,nbi
5354               diff=vbld(i+nres)-vbldsc0(j,iti)
5355               ud(j)=aksc(j,iti)*diff
5356               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5357             enddo
5358             uprod=u(1)
5359             do j=2,nbi
5360               uprod=uprod*u(j)
5361             enddo
5362             usum=0.0d0
5363             usumsqder=0.0d0
5364             do j=1,nbi
5365               uprod1=1.0d0
5366               uprod2=1.0d0
5367               do k=1,nbi
5368                 if (k.ne.j) then
5369                   uprod1=uprod1*u(k)
5370                   uprod2=uprod2*u(k)*u(k)
5371                 endif
5372               enddo
5373               usum=usum+uprod1
5374               usumsqder=usumsqder+ud(j)*uprod2
5375             enddo
5376             estr=estr+uprod/usum
5377             do j=1,3
5378              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5379             enddo
5380           endif
5381         endif
5382       enddo
5383       return
5384       end
5385 #ifdef CRYST_THETA
5386 C--------------------------------------------------------------------------
5387       subroutine ebend(etheta)
5388 C
5389 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5390 C angles gamma and its derivatives in consecutive thetas and gammas.
5391 C
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.GEO'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.DERIV'
5398       include 'COMMON.VAR'
5399       include 'COMMON.CHAIN'
5400       include 'COMMON.IOUNITS'
5401       include 'COMMON.NAMES'
5402       include 'COMMON.FFIELD'
5403       include 'COMMON.CONTROL'
5404       common /calcthet/ term1,term2,termm,diffak,ratak,
5405      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5406      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5407       double precision y(2),z(2)
5408       delta=0.02d0*pi
5409 c      time11=dexp(-2*time)
5410 c      time12=1.0d0
5411       etheta=0.0D0
5412 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5413       do i=ithet_start,ithet_end
5414         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5415      &  .or.itype(i).eq.ntyp1) cycle
5416 C Zero the energy function and its derivative at 0 or pi.
5417         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5418         it=itype(i-1)
5419         ichir1=isign(1,itype(i-2))
5420         ichir2=isign(1,itype(i))
5421          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5422          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5423          if (itype(i-1).eq.10) then
5424           itype1=isign(10,itype(i-2))
5425           ichir11=isign(1,itype(i-2))
5426           ichir12=isign(1,itype(i-2))
5427           itype2=isign(10,itype(i))
5428           ichir21=isign(1,itype(i))
5429           ichir22=isign(1,itype(i))
5430          endif
5431
5432         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5433 #ifdef OSF
5434           phii=phi(i)
5435           if (phii.ne.phii) phii=150.0
5436 #else
5437           phii=phi(i)
5438 #endif
5439           y(1)=dcos(phii)
5440           y(2)=dsin(phii)
5441         else
5442           y(1)=0.0D0
5443           y(2)=0.0D0
5444         endif
5445         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5446 #ifdef OSF
5447           phii1=phi(i+1)
5448           if (phii1.ne.phii1) phii1=150.0
5449           phii1=pinorm(phii1)
5450           z(1)=cos(phii1)
5451 #else
5452           phii1=phi(i+1)
5453 #endif
5454           z(1)=dcos(phii1)
5455           z(2)=dsin(phii1)
5456         else
5457           z(1)=0.0D0
5458           z(2)=0.0D0
5459         endif
5460 C Calculate the "mean" value of theta from the part of the distribution
5461 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5462 C In following comments this theta will be referred to as t_c.
5463         thet_pred_mean=0.0d0
5464         do k=1,2
5465             athetk=athet(k,it,ichir1,ichir2)
5466             bthetk=bthet(k,it,ichir1,ichir2)
5467           if (it.eq.10) then
5468              athetk=athet(k,itype1,ichir11,ichir12)
5469              bthetk=bthet(k,itype2,ichir21,ichir22)
5470           endif
5471          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5472 c         write(iout,*) 'chuj tu', y(k),z(k)
5473         enddo
5474         dthett=thet_pred_mean*ssd
5475         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5476 C Derivatives of the "mean" values in gamma1 and gamma2.
5477         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5478      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5479          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5480      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5481          if (it.eq.10) then
5482       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5483      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5484         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5485      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5486          endif
5487         if (theta(i).gt.pi-delta) then
5488           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5489      &         E_tc0)
5490           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5491           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5492           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5493      &        E_theta)
5494           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5495      &        E_tc)
5496         else if (theta(i).lt.delta) then
5497           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5498           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5499           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5500      &        E_theta)
5501           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5502           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5503      &        E_tc)
5504         else
5505           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5506      &        E_theta,E_tc)
5507         endif
5508         etheta=etheta+ethetai
5509         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5510      &      'ebend',i,ethetai,theta(i),itype(i)
5511         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5512         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5513         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5514       enddo
5515 C Ufff.... We've done all this!!!
5516       return
5517       end
5518 C---------------------------------------------------------------------------
5519       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5520      &     E_tc)
5521       implicit real*8 (a-h,o-z)
5522       include 'DIMENSIONS'
5523       include 'COMMON.LOCAL'
5524       include 'COMMON.IOUNITS'
5525       common /calcthet/ term1,term2,termm,diffak,ratak,
5526      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5527      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5528 C Calculate the contributions to both Gaussian lobes.
5529 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5530 C The "polynomial part" of the "standard deviation" of this part of
5531 C the distributioni.
5532 ccc        write (iout,*) thetai,thet_pred_mean
5533         sig=polthet(3,it)
5534         do j=2,0,-1
5535           sig=sig*thet_pred_mean+polthet(j,it)
5536         enddo
5537 C Derivative of the "interior part" of the "standard deviation of the"
5538 C gamma-dependent Gaussian lobe in t_c.
5539         sigtc=3*polthet(3,it)
5540         do j=2,1,-1
5541           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5542         enddo
5543         sigtc=sig*sigtc
5544 C Set the parameters of both Gaussian lobes of the distribution.
5545 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5546         fac=sig*sig+sigc0(it)
5547         sigcsq=fac+fac
5548         sigc=1.0D0/sigcsq
5549 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5550         sigsqtc=-4.0D0*sigcsq*sigtc
5551 c       print *,i,sig,sigtc,sigsqtc
5552 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5553         sigtc=-sigtc/(fac*fac)
5554 C Following variable is sigma(t_c)**(-2)
5555         sigcsq=sigcsq*sigcsq
5556         sig0i=sig0(it)
5557         sig0inv=1.0D0/sig0i**2
5558         delthec=thetai-thet_pred_mean
5559         delthe0=thetai-theta0i
5560         term1=-0.5D0*sigcsq*delthec*delthec
5561         term2=-0.5D0*sig0inv*delthe0*delthe0
5562 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5563 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5564 C NaNs in taking the logarithm. We extract the largest exponent which is added
5565 C to the energy (this being the log of the distribution) at the end of energy
5566 C term evaluation for this virtual-bond angle.
5567         if (term1.gt.term2) then
5568           termm=term1
5569           term2=dexp(term2-termm)
5570           term1=1.0d0
5571         else
5572           termm=term2
5573           term1=dexp(term1-termm)
5574           term2=1.0d0
5575         endif
5576 C The ratio between the gamma-independent and gamma-dependent lobes of
5577 C the distribution is a Gaussian function of thet_pred_mean too.
5578         diffak=gthet(2,it)-thet_pred_mean
5579         ratak=diffak/gthet(3,it)**2
5580         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5581 C Let's differentiate it in thet_pred_mean NOW.
5582         aktc=ak*ratak
5583 C Now put together the distribution terms to make complete distribution.
5584         termexp=term1+ak*term2
5585         termpre=sigc+ak*sig0i
5586 C Contribution of the bending energy from this theta is just the -log of
5587 C the sum of the contributions from the two lobes and the pre-exponential
5588 C factor. Simple enough, isn't it?
5589         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5590 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5591 C NOW the derivatives!!!
5592 C 6/6/97 Take into account the deformation.
5593         E_theta=(delthec*sigcsq*term1
5594      &       +ak*delthe0*sig0inv*term2)/termexp
5595         E_tc=((sigtc+aktc*sig0i)/termpre
5596      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5597      &       aktc*term2)/termexp)
5598       return
5599       end
5600 c-----------------------------------------------------------------------------
5601       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.LOCAL'
5605       include 'COMMON.IOUNITS'
5606       common /calcthet/ term1,term2,termm,diffak,ratak,
5607      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5608      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5609       delthec=thetai-thet_pred_mean
5610       delthe0=thetai-theta0i
5611 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5612       t3 = thetai-thet_pred_mean
5613       t6 = t3**2
5614       t9 = term1
5615       t12 = t3*sigcsq
5616       t14 = t12+t6*sigsqtc
5617       t16 = 1.0d0
5618       t21 = thetai-theta0i
5619       t23 = t21**2
5620       t26 = term2
5621       t27 = t21*t26
5622       t32 = termexp
5623       t40 = t32**2
5624       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5625      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5626      & *(-t12*t9-ak*sig0inv*t27)
5627       return
5628       end
5629 #else
5630 C--------------------------------------------------------------------------
5631       subroutine ebend(etheta)
5632 C
5633 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5634 C angles gamma and its derivatives in consecutive thetas and gammas.
5635 C ab initio-derived potentials from
5636 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5637 C
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'COMMON.LOCAL'
5641       include 'COMMON.GEO'
5642       include 'COMMON.INTERACT'
5643       include 'COMMON.DERIV'
5644       include 'COMMON.VAR'
5645       include 'COMMON.CHAIN'
5646       include 'COMMON.IOUNITS'
5647       include 'COMMON.NAMES'
5648       include 'COMMON.FFIELD'
5649       include 'COMMON.CONTROL'
5650       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5651      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5652      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5653      & sinph1ph2(maxdouble,maxdouble)
5654       logical lprn /.false./, lprn1 /.false./
5655       etheta=0.0D0
5656       do i=ithet_start,ithet_end
5657         if (i.eq.2) cycle
5658 c        print *,i,itype(i-1),itype(i),itype(i-2)
5659         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5660      &  .or.(itype(i).eq.ntyp1)) cycle
5661 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5662
5663         if (iabs(itype(i+1)).eq.20) iblock=2
5664         if (iabs(itype(i+1)).ne.20) iblock=1
5665         dethetai=0.0d0
5666         dephii=0.0d0
5667         dephii1=0.0d0
5668         theti2=0.5d0*theta(i)
5669         ityp2=ithetyp((itype(i-1)))
5670         do k=1,nntheterm
5671           coskt(k)=dcos(k*theti2)
5672           sinkt(k)=dsin(k*theti2)
5673         enddo
5674         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5675 #ifdef OSF
5676           phii=phi(i)
5677           if (phii.ne.phii) phii=150.0
5678 #else
5679           phii=phi(i)
5680 #endif
5681           ityp1=ithetyp((itype(i-2)))
5682 C propagation of chirality for glycine type
5683           do k=1,nsingle
5684             cosph1(k)=dcos(k*phii)
5685             sinph1(k)=dsin(k*phii)
5686           enddo
5687         else
5688           phii=0.0d0
5689           ityp1=nthetyp+1
5690           do k=1,nsingle
5691             cosph1(k)=0.0d0
5692             sinph1(k)=0.0d0
5693           enddo
5694         endif
5695         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5696 #ifdef OSF
5697           phii1=phi(i+1)
5698           if (phii1.ne.phii1) phii1=150.0
5699           phii1=pinorm(phii1)
5700 #else
5701           phii1=phi(i+1)
5702 #endif
5703           ityp3=ithetyp((itype(i)))
5704           do k=1,nsingle
5705             cosph2(k)=dcos(k*phii1)
5706             sinph2(k)=dsin(k*phii1)
5707           enddo
5708         else
5709           phii1=0.0d0
5710           ityp3=nthetyp+1
5711           do k=1,nsingle
5712             cosph2(k)=0.0d0
5713             sinph2(k)=0.0d0
5714           enddo
5715         endif
5716         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5717         do k=1,ndouble
5718           do l=1,k-1
5719             ccl=cosph1(l)*cosph2(k-l)
5720             ssl=sinph1(l)*sinph2(k-l)
5721             scl=sinph1(l)*cosph2(k-l)
5722             csl=cosph1(l)*sinph2(k-l)
5723             cosph1ph2(l,k)=ccl-ssl
5724             cosph1ph2(k,l)=ccl+ssl
5725             sinph1ph2(l,k)=scl+csl
5726             sinph1ph2(k,l)=scl-csl
5727           enddo
5728         enddo
5729         if (lprn) then
5730         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5731      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5732         write (iout,*) "coskt and sinkt"
5733         do k=1,nntheterm
5734           write (iout,*) k,coskt(k),sinkt(k)
5735         enddo
5736         endif
5737         do k=1,ntheterm
5738           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5739           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5740      &      *coskt(k)
5741           if (lprn)
5742      &    write (iout,*) "k",k,"
5743      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5744      &     " ethetai",ethetai
5745         enddo
5746         if (lprn) then
5747         write (iout,*) "cosph and sinph"
5748         do k=1,nsingle
5749           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5750         enddo
5751         write (iout,*) "cosph1ph2 and sinph2ph2"
5752         do k=2,ndouble
5753           do l=1,k-1
5754             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5755      &         sinph1ph2(l,k),sinph1ph2(k,l)
5756           enddo
5757         enddo
5758         write(iout,*) "ethetai",ethetai
5759         endif
5760         do m=1,ntheterm2
5761           do k=1,nsingle
5762             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5763      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5764      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5765      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5766             ethetai=ethetai+sinkt(m)*aux
5767             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5768             dephii=dephii+k*sinkt(m)*(
5769      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5770      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5771             dephii1=dephii1+k*sinkt(m)*(
5772      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5773      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5774             if (lprn)
5775      &      write (iout,*) "m",m," k",k," bbthet",
5776      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5777      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5778      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5779      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5780           enddo
5781         enddo
5782         if (lprn)
5783      &  write(iout,*) "ethetai",ethetai
5784         do m=1,ntheterm3
5785           do k=2,ndouble
5786             do l=1,k-1
5787               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5788      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5789      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5790      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5791               ethetai=ethetai+sinkt(m)*aux
5792               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5793               dephii=dephii+l*sinkt(m)*(
5794      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5795      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5796      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5797      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5798               dephii1=dephii1+(k-l)*sinkt(m)*(
5799      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5800      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5801      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5802      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5803               if (lprn) then
5804               write (iout,*) "m",m," k",k," l",l," ffthet",
5805      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5806      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5807      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5808      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5809      &            " ethetai",ethetai
5810               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5811      &            cosph1ph2(k,l)*sinkt(m),
5812      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5813               endif
5814             enddo
5815           enddo
5816         enddo
5817 10      continue
5818 c        lprn1=.true.
5819         if (lprn1)
5820      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5821      &   i,theta(i)*rad2deg,phii*rad2deg,
5822      &   phii1*rad2deg,ethetai
5823 c        lprn1=.false.
5824         etheta=etheta+ethetai
5825         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5826      &      'ebend',i,ethetai
5827         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5828         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5829         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5830       enddo
5831       return
5832       end
5833 #endif
5834 #ifdef CRYST_SC
5835 c-----------------------------------------------------------------------------
5836       subroutine esc(escloc)
5837 C Calculate the local energy of a side chain and its derivatives in the
5838 C corresponding virtual-bond valence angles THETA and the spherical angles
5839 C ALPHA and OMEGA.
5840       implicit real*8 (a-h,o-z)
5841       include 'DIMENSIONS'
5842       include 'COMMON.GEO'
5843       include 'COMMON.LOCAL'
5844       include 'COMMON.VAR'
5845       include 'COMMON.INTERACT'
5846       include 'COMMON.DERIV'
5847       include 'COMMON.CHAIN'
5848       include 'COMMON.IOUNITS'
5849       include 'COMMON.NAMES'
5850       include 'COMMON.FFIELD'
5851       include 'COMMON.CONTROL'
5852       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5853      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5854       common /sccalc/ time11,time12,time112,theti,it,nlobit
5855       delta=0.02d0*pi
5856       escloc=0.0D0
5857 c     write (iout,'(a)') 'ESC'
5858       do i=loc_start,loc_end
5859         it=itype(i)
5860         if (it.eq.ntyp1) cycle
5861         if (it.eq.10) goto 1
5862         nlobit=nlob(iabs(it))
5863 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5864 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5865         theti=theta(i+1)-pipol
5866         x(1)=dtan(theti)
5867         x(2)=alph(i)
5868         x(3)=omeg(i)
5869
5870         if (x(2).gt.pi-delta) then
5871           xtemp(1)=x(1)
5872           xtemp(2)=pi-delta
5873           xtemp(3)=x(3)
5874           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5875           xtemp(2)=pi
5876           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5877           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5878      &        escloci,dersc(2))
5879           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5880      &        ddersc0(1),dersc(1))
5881           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5882      &        ddersc0(3),dersc(3))
5883           xtemp(2)=pi-delta
5884           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5885           xtemp(2)=pi
5886           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5887           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5888      &            dersc0(2),esclocbi,dersc02)
5889           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5890      &            dersc12,dersc01)
5891           call splinthet(x(2),0.5d0*delta,ss,ssd)
5892           dersc0(1)=dersc01
5893           dersc0(2)=dersc02
5894           dersc0(3)=0.0d0
5895           do k=1,3
5896             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5897           enddo
5898           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5899 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5900 c    &             esclocbi,ss,ssd
5901           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5902 c         escloci=esclocbi
5903 c         write (iout,*) escloci
5904         else if (x(2).lt.delta) then
5905           xtemp(1)=x(1)
5906           xtemp(2)=delta
5907           xtemp(3)=x(3)
5908           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5909           xtemp(2)=0.0d0
5910           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5911           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5912      &        escloci,dersc(2))
5913           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5914      &        ddersc0(1),dersc(1))
5915           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5916      &        ddersc0(3),dersc(3))
5917           xtemp(2)=delta
5918           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5919           xtemp(2)=0.0d0
5920           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5921           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5922      &            dersc0(2),esclocbi,dersc02)
5923           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5924      &            dersc12,dersc01)
5925           dersc0(1)=dersc01
5926           dersc0(2)=dersc02
5927           dersc0(3)=0.0d0
5928           call splinthet(x(2),0.5d0*delta,ss,ssd)
5929           do k=1,3
5930             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5931           enddo
5932           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5933 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5934 c    &             esclocbi,ss,ssd
5935           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5936 c         write (iout,*) escloci
5937         else
5938           call enesc(x,escloci,dersc,ddummy,.false.)
5939         endif
5940
5941         escloc=escloc+escloci
5942         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5943      &     'escloc',i,escloci
5944 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5945
5946         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5947      &   wscloc*dersc(1)
5948         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5949         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5950     1   continue
5951       enddo
5952       return
5953       end
5954 C---------------------------------------------------------------------------
5955       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5956       implicit real*8 (a-h,o-z)
5957       include 'DIMENSIONS'
5958       include 'COMMON.GEO'
5959       include 'COMMON.LOCAL'
5960       include 'COMMON.IOUNITS'
5961       common /sccalc/ time11,time12,time112,theti,it,nlobit
5962       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5963       double precision contr(maxlob,-1:1)
5964       logical mixed
5965 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5966         escloc_i=0.0D0
5967         do j=1,3
5968           dersc(j)=0.0D0
5969           if (mixed) ddersc(j)=0.0d0
5970         enddo
5971         x3=x(3)
5972
5973 C Because of periodicity of the dependence of the SC energy in omega we have
5974 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5975 C To avoid underflows, first compute & store the exponents.
5976
5977         do iii=-1,1
5978
5979           x(3)=x3+iii*dwapi
5980
5981           do j=1,nlobit
5982             do k=1,3
5983               z(k)=x(k)-censc(k,j,it)
5984             enddo
5985             do k=1,3
5986               Axk=0.0D0
5987               do l=1,3
5988                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5989               enddo
5990               Ax(k,j,iii)=Axk
5991             enddo
5992             expfac=0.0D0
5993             do k=1,3
5994               expfac=expfac+Ax(k,j,iii)*z(k)
5995             enddo
5996             contr(j,iii)=expfac
5997           enddo ! j
5998
5999         enddo ! iii
6000
6001         x(3)=x3
6002 C As in the case of ebend, we want to avoid underflows in exponentiation and
6003 C subsequent NaNs and INFs in energy calculation.
6004 C Find the largest exponent
6005         emin=contr(1,-1)
6006         do iii=-1,1
6007           do j=1,nlobit
6008             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6009           enddo
6010         enddo
6011         emin=0.5D0*emin
6012 cd      print *,'it=',it,' emin=',emin
6013
6014 C Compute the contribution to SC energy and derivatives
6015         do iii=-1,1
6016
6017           do j=1,nlobit
6018 #ifdef OSF
6019             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6020             if(adexp.ne.adexp) adexp=1.0
6021             expfac=dexp(adexp)
6022 #else
6023             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6024 #endif
6025 cd          print *,'j=',j,' expfac=',expfac
6026             escloc_i=escloc_i+expfac
6027             do k=1,3
6028               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6029             enddo
6030             if (mixed) then
6031               do k=1,3,2
6032                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6033      &            +gaussc(k,2,j,it))*expfac
6034               enddo
6035             endif
6036           enddo
6037
6038         enddo ! iii
6039
6040         dersc(1)=dersc(1)/cos(theti)**2
6041         ddersc(1)=ddersc(1)/cos(theti)**2
6042         ddersc(3)=ddersc(3)
6043
6044         escloci=-(dlog(escloc_i)-emin)
6045         do j=1,3
6046           dersc(j)=dersc(j)/escloc_i
6047         enddo
6048         if (mixed) then
6049           do j=1,3,2
6050             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6051           enddo
6052         endif
6053       return
6054       end
6055 C------------------------------------------------------------------------------
6056       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6057       implicit real*8 (a-h,o-z)
6058       include 'DIMENSIONS'
6059       include 'COMMON.GEO'
6060       include 'COMMON.LOCAL'
6061       include 'COMMON.IOUNITS'
6062       common /sccalc/ time11,time12,time112,theti,it,nlobit
6063       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6064       double precision contr(maxlob)
6065       logical mixed
6066
6067       escloc_i=0.0D0
6068
6069       do j=1,3
6070         dersc(j)=0.0D0
6071       enddo
6072
6073       do j=1,nlobit
6074         do k=1,2
6075           z(k)=x(k)-censc(k,j,it)
6076         enddo
6077         z(3)=dwapi
6078         do k=1,3
6079           Axk=0.0D0
6080           do l=1,3
6081             Axk=Axk+gaussc(l,k,j,it)*z(l)
6082           enddo
6083           Ax(k,j)=Axk
6084         enddo
6085         expfac=0.0D0
6086         do k=1,3
6087           expfac=expfac+Ax(k,j)*z(k)
6088         enddo
6089         contr(j)=expfac
6090       enddo ! j
6091
6092 C As in the case of ebend, we want to avoid underflows in exponentiation and
6093 C subsequent NaNs and INFs in energy calculation.
6094 C Find the largest exponent
6095       emin=contr(1)
6096       do j=1,nlobit
6097         if (emin.gt.contr(j)) emin=contr(j)
6098       enddo
6099       emin=0.5D0*emin
6100
6101 C Compute the contribution to SC energy and derivatives
6102
6103       dersc12=0.0d0
6104       do j=1,nlobit
6105         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6106         escloc_i=escloc_i+expfac
6107         do k=1,2
6108           dersc(k)=dersc(k)+Ax(k,j)*expfac
6109         enddo
6110         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6111      &            +gaussc(1,2,j,it))*expfac
6112         dersc(3)=0.0d0
6113       enddo
6114
6115       dersc(1)=dersc(1)/cos(theti)**2
6116       dersc12=dersc12/cos(theti)**2
6117       escloci=-(dlog(escloc_i)-emin)
6118       do j=1,2
6119         dersc(j)=dersc(j)/escloc_i
6120       enddo
6121       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6122       return
6123       end
6124 #else
6125 c----------------------------------------------------------------------------------
6126       subroutine esc(escloc)
6127 C Calculate the local energy of a side chain and its derivatives in the
6128 C corresponding virtual-bond valence angles THETA and the spherical angles
6129 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6130 C added by Urszula Kozlowska. 07/11/2007
6131 C
6132       implicit real*8 (a-h,o-z)
6133       include 'DIMENSIONS'
6134       include 'COMMON.GEO'
6135       include 'COMMON.LOCAL'
6136       include 'COMMON.VAR'
6137       include 'COMMON.SCROT'
6138       include 'COMMON.INTERACT'
6139       include 'COMMON.DERIV'
6140       include 'COMMON.CHAIN'
6141       include 'COMMON.IOUNITS'
6142       include 'COMMON.NAMES'
6143       include 'COMMON.FFIELD'
6144       include 'COMMON.CONTROL'
6145       include 'COMMON.VECTORS'
6146       double precision x_prime(3),y_prime(3),z_prime(3)
6147      &    , sumene,dsc_i,dp2_i,x(65),
6148      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6149      &    de_dxx,de_dyy,de_dzz,de_dt
6150       double precision s1_t,s1_6_t,s2_t,s2_6_t
6151       double precision
6152      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6153      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6154      & dt_dCi(3),dt_dCi1(3)
6155       common /sccalc/ time11,time12,time112,theti,it,nlobit
6156       delta=0.02d0*pi
6157       escloc=0.0D0
6158       do i=loc_start,loc_end
6159         if (itype(i).eq.ntyp1) cycle
6160         costtab(i+1) =dcos(theta(i+1))
6161         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6162         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6163         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6164         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6165         cosfac=dsqrt(cosfac2)
6166         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6167         sinfac=dsqrt(sinfac2)
6168         it=iabs(itype(i))
6169         if (it.eq.10) goto 1
6170 c
6171 C  Compute the axes of tghe local cartesian coordinates system; store in
6172 c   x_prime, y_prime and z_prime
6173 c
6174         do j=1,3
6175           x_prime(j) = 0.00
6176           y_prime(j) = 0.00
6177           z_prime(j) = 0.00
6178         enddo
6179 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6180 C     &   dc_norm(3,i+nres)
6181         do j = 1,3
6182           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6183           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6184         enddo
6185         do j = 1,3
6186           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6187         enddo
6188 c       write (2,*) "i",i
6189 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6190 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6191 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6192 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6193 c      & " xy",scalar(x_prime(1),y_prime(1)),
6194 c      & " xz",scalar(x_prime(1),z_prime(1)),
6195 c      & " yy",scalar(y_prime(1),y_prime(1)),
6196 c      & " yz",scalar(y_prime(1),z_prime(1)),
6197 c      & " zz",scalar(z_prime(1),z_prime(1))
6198 c
6199 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6200 C to local coordinate system. Store in xx, yy, zz.
6201 c
6202         xx=0.0d0
6203         yy=0.0d0
6204         zz=0.0d0
6205         do j = 1,3
6206           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6207           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6208           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6209         enddo
6210
6211         xxtab(i)=xx
6212         yytab(i)=yy
6213         zztab(i)=zz
6214 C
6215 C Compute the energy of the ith side cbain
6216 C
6217 c        write (2,*) "xx",xx," yy",yy," zz",zz
6218         it=iabs(itype(i))
6219         do j = 1,65
6220           x(j) = sc_parmin(j,it)
6221         enddo
6222 #ifdef CHECK_COORD
6223 Cc diagnostics - remove later
6224         xx1 = dcos(alph(2))
6225         yy1 = dsin(alph(2))*dcos(omeg(2))
6226         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6227         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6228      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6229      &    xx1,yy1,zz1
6230 C,"  --- ", xx_w,yy_w,zz_w
6231 c end diagnostics
6232 #endif
6233         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6234      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6235      &   + x(10)*yy*zz
6236         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6237      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6238      & + x(20)*yy*zz
6239         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6240      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6241      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6242      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6243      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6244      &  +x(40)*xx*yy*zz
6245         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6246      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6247      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6248      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6249      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6250      &  +x(60)*xx*yy*zz
6251         dsc_i   = 0.743d0+x(61)
6252         dp2_i   = 1.9d0+x(62)
6253         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6254      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6255         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6256      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6257         s1=(1+x(63))/(0.1d0 + dscp1)
6258         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6259         s2=(1+x(65))/(0.1d0 + dscp2)
6260         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6261         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6262      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6263 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6264 c     &   sumene4,
6265 c     &   dscp1,dscp2,sumene
6266 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6267         escloc = escloc + sumene
6268 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6269 c     & ,zz,xx,yy
6270 c#define DEBUG
6271 #ifdef DEBUG
6272 C
6273 C This section to check the numerical derivatives of the energy of ith side
6274 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6275 C #define DEBUG in the code to turn it on.
6276 C
6277         write (2,*) "sumene               =",sumene
6278         aincr=1.0d-7
6279         xxsave=xx
6280         xx=xx+aincr
6281         write (2,*) xx,yy,zz
6282         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6283         de_dxx_num=(sumenep-sumene)/aincr
6284         xx=xxsave
6285         write (2,*) "xx+ sumene from enesc=",sumenep
6286         yysave=yy
6287         yy=yy+aincr
6288         write (2,*) xx,yy,zz
6289         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6290         de_dyy_num=(sumenep-sumene)/aincr
6291         yy=yysave
6292         write (2,*) "yy+ sumene from enesc=",sumenep
6293         zzsave=zz
6294         zz=zz+aincr
6295         write (2,*) xx,yy,zz
6296         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6297         de_dzz_num=(sumenep-sumene)/aincr
6298         zz=zzsave
6299         write (2,*) "zz+ sumene from enesc=",sumenep
6300         costsave=cost2tab(i+1)
6301         sintsave=sint2tab(i+1)
6302         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6303         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6304         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6305         de_dt_num=(sumenep-sumene)/aincr
6306         write (2,*) " t+ sumene from enesc=",sumenep
6307         cost2tab(i+1)=costsave
6308         sint2tab(i+1)=sintsave
6309 C End of diagnostics section.
6310 #endif
6311 C
6312 C Compute the gradient of esc
6313 C
6314 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6315         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6316         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6317         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6318         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6319         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6320         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6321         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6322         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6323         pom1=(sumene3*sint2tab(i+1)+sumene1)
6324      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6325         pom2=(sumene4*cost2tab(i+1)+sumene2)
6326      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6327         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6328         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6329      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6330      &  +x(40)*yy*zz
6331         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6332         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6333      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6334      &  +x(60)*yy*zz
6335         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6336      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6337      &        +(pom1+pom2)*pom_dx
6338 #ifdef DEBUG
6339         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6340 #endif
6341 C
6342         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6343         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6344      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6345      &  +x(40)*xx*zz
6346         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6347         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6348      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6349      &  +x(59)*zz**2 +x(60)*xx*zz
6350         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6351      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6352      &        +(pom1-pom2)*pom_dy
6353 #ifdef DEBUG
6354         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6355 #endif
6356 C
6357         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6358      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6359      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6360      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6361      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6362      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6363      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6364      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6365 #ifdef DEBUG
6366         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6367 #endif
6368 C
6369         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6370      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6371      &  +pom1*pom_dt1+pom2*pom_dt2
6372 #ifdef DEBUG
6373         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6374 #endif
6375 c#undef DEBUG
6376 c
6377 C
6378        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6379        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6380        cosfac2xx=cosfac2*xx
6381        sinfac2yy=sinfac2*yy
6382        do k = 1,3
6383          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6384      &      vbld_inv(i+1)
6385          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6386      &      vbld_inv(i)
6387          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6388          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6389 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6390 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6391 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6392 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6393          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6394          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6395          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6396          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6397          dZZ_Ci1(k)=0.0d0
6398          dZZ_Ci(k)=0.0d0
6399          do j=1,3
6400            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6401      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6402            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6403      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6404          enddo
6405
6406          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6407          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6408          dZZ_XYZ(k)=vbld_inv(i+nres)*
6409      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6410 c
6411          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6412          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6413        enddo
6414
6415        do k=1,3
6416          dXX_Ctab(k,i)=dXX_Ci(k)
6417          dXX_C1tab(k,i)=dXX_Ci1(k)
6418          dYY_Ctab(k,i)=dYY_Ci(k)
6419          dYY_C1tab(k,i)=dYY_Ci1(k)
6420          dZZ_Ctab(k,i)=dZZ_Ci(k)
6421          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6422          dXX_XYZtab(k,i)=dXX_XYZ(k)
6423          dYY_XYZtab(k,i)=dYY_XYZ(k)
6424          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6425        enddo
6426
6427        do k = 1,3
6428 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6429 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6430 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6431 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6432 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6433 c     &    dt_dci(k)
6434 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6435 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6436          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6437      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6438          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6439      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6440          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6441      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6442        enddo
6443 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6444 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6445
6446 C to check gradient call subroutine check_grad
6447
6448     1 continue
6449       enddo
6450       return
6451       end
6452 c------------------------------------------------------------------------------
6453       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6454       implicit none
6455       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6456      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6457       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6458      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6459      &   + x(10)*yy*zz
6460       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6461      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6462      & + x(20)*yy*zz
6463       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6464      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6465      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6466      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6467      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6468      &  +x(40)*xx*yy*zz
6469       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6470      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6471      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6472      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6473      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6474      &  +x(60)*xx*yy*zz
6475       dsc_i   = 0.743d0+x(61)
6476       dp2_i   = 1.9d0+x(62)
6477       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6478      &          *(xx*cost2+yy*sint2))
6479       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6480      &          *(xx*cost2-yy*sint2))
6481       s1=(1+x(63))/(0.1d0 + dscp1)
6482       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6483       s2=(1+x(65))/(0.1d0 + dscp2)
6484       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6485       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6486      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6487       enesc=sumene
6488       return
6489       end
6490 #endif
6491 c------------------------------------------------------------------------------
6492       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6493 C
6494 C This procedure calculates two-body contact function g(rij) and its derivative:
6495 C
6496 C           eps0ij                                     !       x < -1
6497 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6498 C            0                                         !       x > 1
6499 C
6500 C where x=(rij-r0ij)/delta
6501 C
6502 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6503 C
6504       implicit none
6505       double precision rij,r0ij,eps0ij,fcont,fprimcont
6506       double precision x,x2,x4,delta
6507 c     delta=0.02D0*r0ij
6508 c      delta=0.2D0*r0ij
6509       x=(rij-r0ij)/delta
6510       if (x.lt.-1.0D0) then
6511         fcont=eps0ij
6512         fprimcont=0.0D0
6513       else if (x.le.1.0D0) then
6514         x2=x*x
6515         x4=x2*x2
6516         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6517         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6518       else
6519         fcont=0.0D0
6520         fprimcont=0.0D0
6521       endif
6522       return
6523       end
6524 c------------------------------------------------------------------------------
6525       subroutine splinthet(theti,delta,ss,ssder)
6526       implicit real*8 (a-h,o-z)
6527       include 'DIMENSIONS'
6528       include 'COMMON.VAR'
6529       include 'COMMON.GEO'
6530       thetup=pi-delta
6531       thetlow=delta
6532       if (theti.gt.pipol) then
6533         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6534       else
6535         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6536         ssder=-ssder
6537       endif
6538       return
6539       end
6540 c------------------------------------------------------------------------------
6541       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6542       implicit none
6543       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6544       double precision ksi,ksi2,ksi3,a1,a2,a3
6545       a1=fprim0*delta/(f1-f0)
6546       a2=3.0d0-2.0d0*a1
6547       a3=a1-2.0d0
6548       ksi=(x-x0)/delta
6549       ksi2=ksi*ksi
6550       ksi3=ksi2*ksi
6551       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6552       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6553       return
6554       end
6555 c------------------------------------------------------------------------------
6556       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6557       implicit none
6558       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6559       double precision ksi,ksi2,ksi3,a1,a2,a3
6560       ksi=(x-x0)/delta
6561       ksi2=ksi*ksi
6562       ksi3=ksi2*ksi
6563       a1=fprim0x*delta
6564       a2=3*(f1x-f0x)-2*fprim0x*delta
6565       a3=fprim0x*delta-2*(f1x-f0x)
6566       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6567       return
6568       end
6569 C-----------------------------------------------------------------------------
6570 #ifdef CRYST_TOR
6571 C-----------------------------------------------------------------------------
6572       subroutine etor(etors,edihcnstr)
6573       implicit real*8 (a-h,o-z)
6574       include 'DIMENSIONS'
6575       include 'COMMON.VAR'
6576       include 'COMMON.GEO'
6577       include 'COMMON.LOCAL'
6578       include 'COMMON.TORSION'
6579       include 'COMMON.INTERACT'
6580       include 'COMMON.DERIV'
6581       include 'COMMON.CHAIN'
6582       include 'COMMON.NAMES'
6583       include 'COMMON.IOUNITS'
6584       include 'COMMON.FFIELD'
6585       include 'COMMON.TORCNSTR'
6586       include 'COMMON.CONTROL'
6587       logical lprn
6588 C Set lprn=.true. for debugging
6589       lprn=.false.
6590 c      lprn=.true.
6591       etors=0.0D0
6592       do i=iphi_start,iphi_end
6593       etors_ii=0.0D0
6594         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6595      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6596         itori=itortyp(itype(i-2))
6597         itori1=itortyp(itype(i-1))
6598         phii=phi(i)
6599         gloci=0.0D0
6600 C Proline-Proline pair is a special case...
6601         if (itori.eq.3 .and. itori1.eq.3) then
6602           if (phii.gt.-dwapi3) then
6603             cosphi=dcos(3*phii)
6604             fac=1.0D0/(1.0D0-cosphi)
6605             etorsi=v1(1,3,3)*fac
6606             etorsi=etorsi+etorsi
6607             etors=etors+etorsi-v1(1,3,3)
6608             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6609             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6610           endif
6611           do j=1,3
6612             v1ij=v1(j+1,itori,itori1)
6613             v2ij=v2(j+1,itori,itori1)
6614             cosphi=dcos(j*phii)
6615             sinphi=dsin(j*phii)
6616             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6617             if (energy_dec) etors_ii=etors_ii+
6618      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6619             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6620           enddo
6621         else
6622           do j=1,nterm_old
6623             v1ij=v1(j,itori,itori1)
6624             v2ij=v2(j,itori,itori1)
6625             cosphi=dcos(j*phii)
6626             sinphi=dsin(j*phii)
6627             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6628             if (energy_dec) etors_ii=etors_ii+
6629      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6630             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6631           enddo
6632         endif
6633         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6634              'etor',i,etors_ii
6635         if (lprn)
6636      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6637      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6638      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6639         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6640 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6641       enddo
6642 ! 6/20/98 - dihedral angle constraints
6643       edihcnstr=0.0d0
6644       do i=1,ndih_constr
6645         itori=idih_constr(i)
6646         phii=phi(itori)
6647         difi=phii-phi0(i)
6648         if (difi.gt.drange(i)) then
6649           difi=difi-drange(i)
6650           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6651           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6652         else if (difi.lt.-drange(i)) then
6653           difi=difi+drange(i)
6654           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6655           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6656         endif
6657 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6658 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6659       enddo
6660 !      write (iout,*) 'edihcnstr',edihcnstr
6661       return
6662       end
6663 c------------------------------------------------------------------------------
6664       subroutine etor_d(etors_d)
6665       etors_d=0.0d0
6666       return
6667       end
6668 c----------------------------------------------------------------------------
6669 #else
6670       subroutine etor(etors,edihcnstr)
6671       implicit real*8 (a-h,o-z)
6672       include 'DIMENSIONS'
6673       include 'COMMON.VAR'
6674       include 'COMMON.GEO'
6675       include 'COMMON.LOCAL'
6676       include 'COMMON.TORSION'
6677       include 'COMMON.INTERACT'
6678       include 'COMMON.DERIV'
6679       include 'COMMON.CHAIN'
6680       include 'COMMON.NAMES'
6681       include 'COMMON.IOUNITS'
6682       include 'COMMON.FFIELD'
6683       include 'COMMON.TORCNSTR'
6684       include 'COMMON.CONTROL'
6685       logical lprn
6686 C Set lprn=.true. for debugging
6687       lprn=.false.
6688 c     lprn=.true.
6689       etors=0.0D0
6690       do i=iphi_start,iphi_end
6691 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6692 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6693 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6694 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6695         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6696      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6697 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6698 C For introducing the NH3+ and COO- group please check the etor_d for reference
6699 C and guidance
6700         etors_ii=0.0D0
6701          if (iabs(itype(i)).eq.20) then
6702          iblock=2
6703          else
6704          iblock=1
6705          endif
6706         itori=itortyp(itype(i-2))
6707         itori1=itortyp(itype(i-1))
6708         phii=phi(i)
6709         gloci=0.0D0
6710 C Regular cosine and sine terms
6711         do j=1,nterm(itori,itori1,iblock)
6712           v1ij=v1(j,itori,itori1,iblock)
6713           v2ij=v2(j,itori,itori1,iblock)
6714           cosphi=dcos(j*phii)
6715           sinphi=dsin(j*phii)
6716           etors=etors+v1ij*cosphi+v2ij*sinphi
6717           if (energy_dec) etors_ii=etors_ii+
6718      &                v1ij*cosphi+v2ij*sinphi
6719           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6720         enddo
6721 C Lorentz terms
6722 C                         v1
6723 C  E = SUM ----------------------------------- - v1
6724 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6725 C
6726         cosphi=dcos(0.5d0*phii)
6727         sinphi=dsin(0.5d0*phii)
6728         do j=1,nlor(itori,itori1,iblock)
6729           vl1ij=vlor1(j,itori,itori1)
6730           vl2ij=vlor2(j,itori,itori1)
6731           vl3ij=vlor3(j,itori,itori1)
6732           pom=vl2ij*cosphi+vl3ij*sinphi
6733           pom1=1.0d0/(pom*pom+1.0d0)
6734           etors=etors+vl1ij*pom1
6735           if (energy_dec) etors_ii=etors_ii+
6736      &                vl1ij*pom1
6737           pom=-pom*pom1*pom1
6738           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6739         enddo
6740 C Subtract the constant term
6741         etors=etors-v0(itori,itori1,iblock)
6742           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6743      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6744         if (lprn)
6745      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6746      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6747      &  (v1(j,itori,itori1,iblock),j=1,6),
6748      &  (v2(j,itori,itori1,iblock),j=1,6)
6749         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6750 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6751       enddo
6752 ! 6/20/98 - dihedral angle constraints
6753       edihcnstr=0.0d0
6754 c      do i=1,ndih_constr
6755       do i=idihconstr_start,idihconstr_end
6756         itori=idih_constr(i)
6757         phii=phi(itori)
6758         difi=pinorm(phii-phi0(i))
6759         if (difi.gt.drange(i)) then
6760           difi=difi-drange(i)
6761           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6762           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6763         else if (difi.lt.-drange(i)) then
6764           difi=difi+drange(i)
6765           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6766           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6767         else
6768           difi=0.0
6769         endif
6770 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6771 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6772 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6773       enddo
6774 cd       write (iout,*) 'edihcnstr',edihcnstr
6775       return
6776       end
6777 c----------------------------------------------------------------------------
6778       subroutine etor_d(etors_d)
6779 C 6/23/01 Compute double torsional energy
6780       implicit real*8 (a-h,o-z)
6781       include 'DIMENSIONS'
6782       include 'COMMON.VAR'
6783       include 'COMMON.GEO'
6784       include 'COMMON.LOCAL'
6785       include 'COMMON.TORSION'
6786       include 'COMMON.INTERACT'
6787       include 'COMMON.DERIV'
6788       include 'COMMON.CHAIN'
6789       include 'COMMON.NAMES'
6790       include 'COMMON.IOUNITS'
6791       include 'COMMON.FFIELD'
6792       include 'COMMON.TORCNSTR'
6793       include 'COMMON.CONTROL'
6794       logical lprn
6795 C Set lprn=.true. for debugging
6796       lprn=.false.
6797 c     lprn=.true.
6798       etors_d=0.0D0
6799 c      write(iout,*) "a tu??"
6800       do i=iphid_start,iphid_end
6801 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6802 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6803 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6804 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6805 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6806          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6807      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6808      &  (itype(i+1).eq.ntyp1)) cycle
6809 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6810         etors_d_ii=0.0D0
6811         itori=itortyp(itype(i-2))
6812         itori1=itortyp(itype(i-1))
6813         itori2=itortyp(itype(i))
6814         phii=phi(i)
6815         phii1=phi(i+1)
6816         gloci1=0.0D0
6817         gloci2=0.0D0
6818         iblock=1
6819         if (iabs(itype(i+1)).eq.20) iblock=2
6820 C Iblock=2 Proline type
6821 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6822 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6823 C        if (itype(i+1).eq.ntyp1) iblock=3
6824 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6825 C IS or IS NOT need for this
6826 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6827 C        is (itype(i-3).eq.ntyp1) ntblock=2
6828 C        ntblock is N-terminal blocking group
6829
6830 C Regular cosine and sine terms
6831         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6832 C Example of changes for NH3+ blocking group
6833 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6834 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6835           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6836           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6837           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6838           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6839           cosphi1=dcos(j*phii)
6840           sinphi1=dsin(j*phii)
6841           cosphi2=dcos(j*phii1)
6842           sinphi2=dsin(j*phii1)
6843           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6844      &     v2cij*cosphi2+v2sij*sinphi2
6845           if (energy_dec) etors_d_ii=etors_d_ii+
6846      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6847           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6848           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6849         enddo
6850         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6851           do l=1,k-1
6852             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6853             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6854             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6855             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6856             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6857             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6858             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6859             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6860             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6861      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6862             if (energy_dec) etors_d_ii=etors_d_ii+
6863      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6864      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6865             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6866      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6867             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6868      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6869           enddo
6870         enddo
6871           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6872      &         'etor_d',i,etors_d_ii
6873         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6874         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6875       enddo
6876       return
6877       end
6878 #endif
6879 c------------------------------------------------------------------------------
6880       subroutine eback_sc_corr(esccor)
6881 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6882 c        conformational states; temporarily implemented as differences
6883 c        between UNRES torsional potentials (dependent on three types of
6884 c        residues) and the torsional potentials dependent on all 20 types
6885 c        of residues computed from AM1  energy surfaces of terminally-blocked
6886 c        amino-acid residues.
6887       implicit real*8 (a-h,o-z)
6888       include 'DIMENSIONS'
6889       include 'COMMON.VAR'
6890       include 'COMMON.GEO'
6891       include 'COMMON.LOCAL'
6892       include 'COMMON.TORSION'
6893       include 'COMMON.SCCOR'
6894       include 'COMMON.INTERACT'
6895       include 'COMMON.DERIV'
6896       include 'COMMON.CHAIN'
6897       include 'COMMON.NAMES'
6898       include 'COMMON.IOUNITS'
6899       include 'COMMON.FFIELD'
6900       include 'COMMON.CONTROL'
6901       logical lprn
6902 C Set lprn=.true. for debugging
6903       lprn=.false.
6904 c      lprn=.true.
6905 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6906       esccor=0.0D0
6907       do i=itau_start,itau_end
6908         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6909         esccor_ii=0.0D0
6910         isccori=isccortyp(itype(i-2))
6911         isccori1=isccortyp(itype(i-1))
6912 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6913         phii=phi(i)
6914         do intertyp=1,3 !intertyp
6915 cc Added 09 May 2012 (Adasko)
6916 cc  Intertyp means interaction type of backbone mainchain correlation:
6917 c   1 = SC...Ca...Ca...Ca
6918 c   2 = Ca...Ca...Ca...SC
6919 c   3 = SC...Ca...Ca...SCi
6920         gloci=0.0D0
6921         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6922      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6923      &      (itype(i-1).eq.ntyp1)))
6924      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6925      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6926      &     .or.(itype(i).eq.ntyp1)))
6927      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6928      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6929      &      (itype(i-3).eq.ntyp1)))) cycle
6930         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6931         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6932      & cycle
6933        do j=1,nterm_sccor(isccori,isccori1)
6934           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6935           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6936           cosphi=dcos(j*tauangle(intertyp,i))
6937           sinphi=dsin(j*tauangle(intertyp,i))
6938           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6939           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6940         enddo
6941 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6942         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6943         if (lprn)
6944      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6945      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6946      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6947      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6948         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6949        enddo !intertyp
6950       enddo
6951
6952       return
6953       end
6954 c----------------------------------------------------------------------------
6955       subroutine multibody(ecorr)
6956 C This subroutine calculates multi-body contributions to energy following
6957 C the idea of Skolnick et al. If side chains I and J make a contact and
6958 C at the same time side chains I+1 and J+1 make a contact, an extra
6959 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6960       implicit real*8 (a-h,o-z)
6961       include 'DIMENSIONS'
6962       include 'COMMON.IOUNITS'
6963       include 'COMMON.DERIV'
6964       include 'COMMON.INTERACT'
6965       include 'COMMON.CONTACTS'
6966       double precision gx(3),gx1(3)
6967       logical lprn
6968
6969 C Set lprn=.true. for debugging
6970       lprn=.false.
6971
6972       if (lprn) then
6973         write (iout,'(a)') 'Contact function values:'
6974         do i=nnt,nct-2
6975           write (iout,'(i2,20(1x,i2,f10.5))')
6976      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6977         enddo
6978       endif
6979       ecorr=0.0D0
6980       do i=nnt,nct
6981         do j=1,3
6982           gradcorr(j,i)=0.0D0
6983           gradxorr(j,i)=0.0D0
6984         enddo
6985       enddo
6986       do i=nnt,nct-2
6987
6988         DO ISHIFT = 3,4
6989
6990         i1=i+ishift
6991         num_conti=num_cont(i)
6992         num_conti1=num_cont(i1)
6993         do jj=1,num_conti
6994           j=jcont(jj,i)
6995           do kk=1,num_conti1
6996             j1=jcont(kk,i1)
6997             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6998 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6999 cd   &                   ' ishift=',ishift
7000 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7001 C The system gains extra energy.
7002               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7003             endif   ! j1==j+-ishift
7004           enddo     ! kk
7005         enddo       ! jj
7006
7007         ENDDO ! ISHIFT
7008
7009       enddo         ! i
7010       return
7011       end
7012 c------------------------------------------------------------------------------
7013       double precision function esccorr(i,j,k,l,jj,kk)
7014       implicit real*8 (a-h,o-z)
7015       include 'DIMENSIONS'
7016       include 'COMMON.IOUNITS'
7017       include 'COMMON.DERIV'
7018       include 'COMMON.INTERACT'
7019       include 'COMMON.CONTACTS'
7020       double precision gx(3),gx1(3)
7021       logical lprn
7022       lprn=.false.
7023       eij=facont(jj,i)
7024       ekl=facont(kk,k)
7025 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7026 C Calculate the multi-body contribution to energy.
7027 C Calculate multi-body contributions to the gradient.
7028 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7029 cd   & k,l,(gacont(m,kk,k),m=1,3)
7030       do m=1,3
7031         gx(m) =ekl*gacont(m,jj,i)
7032         gx1(m)=eij*gacont(m,kk,k)
7033         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7034         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7035         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7036         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7037       enddo
7038       do m=i,j-1
7039         do ll=1,3
7040           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7041         enddo
7042       enddo
7043       do m=k,l-1
7044         do ll=1,3
7045           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7046         enddo
7047       enddo
7048       esccorr=-eij*ekl
7049       return
7050       end
7051 c------------------------------------------------------------------------------
7052       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7053 C This subroutine calculates multi-body contributions to hydrogen-bonding
7054       implicit real*8 (a-h,o-z)
7055       include 'DIMENSIONS'
7056       include 'COMMON.IOUNITS'
7057 #ifdef MPI
7058       include "mpif.h"
7059       parameter (max_cont=maxconts)
7060       parameter (max_dim=26)
7061       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7062       double precision zapas(max_dim,maxconts,max_fg_procs),
7063      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7064       common /przechowalnia/ zapas
7065       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7066      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7067 #endif
7068       include 'COMMON.SETUP'
7069       include 'COMMON.FFIELD'
7070       include 'COMMON.DERIV'
7071       include 'COMMON.INTERACT'
7072       include 'COMMON.CONTACTS'
7073       include 'COMMON.CONTROL'
7074       include 'COMMON.LOCAL'
7075       double precision gx(3),gx1(3),time00
7076       logical lprn,ldone
7077
7078 C Set lprn=.true. for debugging
7079       lprn=.false.
7080 #ifdef MPI
7081       n_corr=0
7082       n_corr1=0
7083       if (nfgtasks.le.1) goto 30
7084       if (lprn) then
7085         write (iout,'(a)') 'Contact function values before RECEIVE:'
7086         do i=nnt,nct-2
7087           write (iout,'(2i3,50(1x,i2,f5.2))')
7088      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7089      &    j=1,num_cont_hb(i))
7090         enddo
7091       endif
7092       call flush(iout)
7093       do i=1,ntask_cont_from
7094         ncont_recv(i)=0
7095       enddo
7096       do i=1,ntask_cont_to
7097         ncont_sent(i)=0
7098       enddo
7099 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7100 c     & ntask_cont_to
7101 C Make the list of contacts to send to send to other procesors
7102 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7103 c      call flush(iout)
7104       do i=iturn3_start,iturn3_end
7105 c        write (iout,*) "make contact list turn3",i," num_cont",
7106 c     &    num_cont_hb(i)
7107         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7108       enddo
7109       do i=iturn4_start,iturn4_end
7110 c        write (iout,*) "make contact list turn4",i," num_cont",
7111 c     &   num_cont_hb(i)
7112         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7113       enddo
7114       do ii=1,nat_sent
7115         i=iat_sent(ii)
7116 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7117 c     &    num_cont_hb(i)
7118         do j=1,num_cont_hb(i)
7119         do k=1,4
7120           jjc=jcont_hb(j,i)
7121           iproc=iint_sent_local(k,jjc,ii)
7122 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7123           if (iproc.gt.0) then
7124             ncont_sent(iproc)=ncont_sent(iproc)+1
7125             nn=ncont_sent(iproc)
7126             zapas(1,nn,iproc)=i
7127             zapas(2,nn,iproc)=jjc
7128             zapas(3,nn,iproc)=facont_hb(j,i)
7129             zapas(4,nn,iproc)=ees0p(j,i)
7130             zapas(5,nn,iproc)=ees0m(j,i)
7131             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7132             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7133             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7134             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7135             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7136             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7137             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7138             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7139             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7140             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7141             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7142             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7143             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7144             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7145             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7146             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7147             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7148             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7149             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7150             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7151             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7152           endif
7153         enddo
7154         enddo
7155       enddo
7156       if (lprn) then
7157       write (iout,*)
7158      &  "Numbers of contacts to be sent to other processors",
7159      &  (ncont_sent(i),i=1,ntask_cont_to)
7160       write (iout,*) "Contacts sent"
7161       do ii=1,ntask_cont_to
7162         nn=ncont_sent(ii)
7163         iproc=itask_cont_to(ii)
7164         write (iout,*) nn," contacts to processor",iproc,
7165      &   " of CONT_TO_COMM group"
7166         do i=1,nn
7167           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7168         enddo
7169       enddo
7170       call flush(iout)
7171       endif
7172       CorrelType=477
7173       CorrelID=fg_rank+1
7174       CorrelType1=478
7175       CorrelID1=nfgtasks+fg_rank+1
7176       ireq=0
7177 C Receive the numbers of needed contacts from other processors
7178       do ii=1,ntask_cont_from
7179         iproc=itask_cont_from(ii)
7180         ireq=ireq+1
7181         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7182      &    FG_COMM,req(ireq),IERR)
7183       enddo
7184 c      write (iout,*) "IRECV ended"
7185 c      call flush(iout)
7186 C Send the number of contacts needed by other processors
7187       do ii=1,ntask_cont_to
7188         iproc=itask_cont_to(ii)
7189         ireq=ireq+1
7190         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7191      &    FG_COMM,req(ireq),IERR)
7192       enddo
7193 c      write (iout,*) "ISEND ended"
7194 c      write (iout,*) "number of requests (nn)",ireq
7195       call flush(iout)
7196       if (ireq.gt.0)
7197      &  call MPI_Waitall(ireq,req,status_array,ierr)
7198 c      write (iout,*)
7199 c     &  "Numbers of contacts to be received from other processors",
7200 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7201 c      call flush(iout)
7202 C Receive contacts
7203       ireq=0
7204       do ii=1,ntask_cont_from
7205         iproc=itask_cont_from(ii)
7206         nn=ncont_recv(ii)
7207 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7208 c     &   " of CONT_TO_COMM group"
7209         call flush(iout)
7210         if (nn.gt.0) then
7211           ireq=ireq+1
7212           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7213      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7214 c          write (iout,*) "ireq,req",ireq,req(ireq)
7215         endif
7216       enddo
7217 C Send the contacts to processors that need them
7218       do ii=1,ntask_cont_to
7219         iproc=itask_cont_to(ii)
7220         nn=ncont_sent(ii)
7221 c        write (iout,*) nn," contacts to processor",iproc,
7222 c     &   " of CONT_TO_COMM group"
7223         if (nn.gt.0) then
7224           ireq=ireq+1
7225           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7226      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7227 c          write (iout,*) "ireq,req",ireq,req(ireq)
7228 c          do i=1,nn
7229 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7230 c          enddo
7231         endif
7232       enddo
7233 c      write (iout,*) "number of requests (contacts)",ireq
7234 c      write (iout,*) "req",(req(i),i=1,4)
7235 c      call flush(iout)
7236       if (ireq.gt.0)
7237      & call MPI_Waitall(ireq,req,status_array,ierr)
7238       do iii=1,ntask_cont_from
7239         iproc=itask_cont_from(iii)
7240         nn=ncont_recv(iii)
7241         if (lprn) then
7242         write (iout,*) "Received",nn," contacts from processor",iproc,
7243      &   " of CONT_FROM_COMM group"
7244         call flush(iout)
7245         do i=1,nn
7246           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7247         enddo
7248         call flush(iout)
7249         endif
7250         do i=1,nn
7251           ii=zapas_recv(1,i,iii)
7252 c Flag the received contacts to prevent double-counting
7253           jj=-zapas_recv(2,i,iii)
7254 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7255 c          call flush(iout)
7256           nnn=num_cont_hb(ii)+1
7257           num_cont_hb(ii)=nnn
7258           jcont_hb(nnn,ii)=jj
7259           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7260           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7261           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7262           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7263           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7264           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7265           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7266           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7267           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7268           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7269           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7270           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7271           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7272           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7273           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7274           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7275           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7276           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7277           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7278           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7279           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7280           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7281           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7282           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7283         enddo
7284       enddo
7285       call flush(iout)
7286       if (lprn) then
7287         write (iout,'(a)') 'Contact function values after receive:'
7288         do i=nnt,nct-2
7289           write (iout,'(2i3,50(1x,i3,f5.2))')
7290      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7291      &    j=1,num_cont_hb(i))
7292         enddo
7293         call flush(iout)
7294       endif
7295    30 continue
7296 #endif
7297       if (lprn) then
7298         write (iout,'(a)') 'Contact function values:'
7299         do i=nnt,nct-2
7300           write (iout,'(2i3,50(1x,i3,f5.2))')
7301      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7302      &    j=1,num_cont_hb(i))
7303         enddo
7304       endif
7305       ecorr=0.0D0
7306 C Remove the loop below after debugging !!!
7307       do i=nnt,nct
7308         do j=1,3
7309           gradcorr(j,i)=0.0D0
7310           gradxorr(j,i)=0.0D0
7311         enddo
7312       enddo
7313 C Calculate the local-electrostatic correlation terms
7314       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7315         i1=i+1
7316         num_conti=num_cont_hb(i)
7317         num_conti1=num_cont_hb(i+1)
7318         do jj=1,num_conti
7319           j=jcont_hb(jj,i)
7320           jp=iabs(j)
7321           do kk=1,num_conti1
7322             j1=jcont_hb(kk,i1)
7323             jp1=iabs(j1)
7324 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7325 c     &         ' jj=',jj,' kk=',kk
7326             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7327      &          .or. j.lt.0 .and. j1.gt.0) .and.
7328      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7329 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7330 C The system gains extra energy.
7331               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7332               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7333      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7334               n_corr=n_corr+1
7335             else if (j1.eq.j) then
7336 C Contacts I-J and I-(J+1) occur simultaneously.
7337 C The system loses extra energy.
7338 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7339             endif
7340           enddo ! kk
7341           do kk=1,num_conti
7342             j1=jcont_hb(kk,i)
7343 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7344 c    &         ' jj=',jj,' kk=',kk
7345             if (j1.eq.j+1) then
7346 C Contacts I-J and (I+1)-J occur simultaneously.
7347 C The system loses extra energy.
7348 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7349             endif ! j1==j+1
7350           enddo ! kk
7351         enddo ! jj
7352       enddo ! i
7353       return
7354       end
7355 c------------------------------------------------------------------------------
7356       subroutine add_hb_contact(ii,jj,itask)
7357       implicit real*8 (a-h,o-z)
7358       include "DIMENSIONS"
7359       include "COMMON.IOUNITS"
7360       integer max_cont
7361       integer max_dim
7362       parameter (max_cont=maxconts)
7363       parameter (max_dim=26)
7364       include "COMMON.CONTACTS"
7365       double precision zapas(max_dim,maxconts,max_fg_procs),
7366      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7367       common /przechowalnia/ zapas
7368       integer i,j,ii,jj,iproc,itask(4),nn
7369 c      write (iout,*) "itask",itask
7370       do i=1,2
7371         iproc=itask(i)
7372         if (iproc.gt.0) then
7373           do j=1,num_cont_hb(ii)
7374             jjc=jcont_hb(j,ii)
7375 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7376             if (jjc.eq.jj) then
7377               ncont_sent(iproc)=ncont_sent(iproc)+1
7378               nn=ncont_sent(iproc)
7379               zapas(1,nn,iproc)=ii
7380               zapas(2,nn,iproc)=jjc
7381               zapas(3,nn,iproc)=facont_hb(j,ii)
7382               zapas(4,nn,iproc)=ees0p(j,ii)
7383               zapas(5,nn,iproc)=ees0m(j,ii)
7384               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7385               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7386               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7387               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7388               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7389               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7390               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7391               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7392               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7393               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7394               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7395               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7396               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7397               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7398               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7399               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7400               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7401               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7402               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7403               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7404               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7405               exit
7406             endif
7407           enddo
7408         endif
7409       enddo
7410       return
7411       end
7412 c------------------------------------------------------------------------------
7413       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7414      &  n_corr1)
7415 C This subroutine calculates multi-body contributions to hydrogen-bonding
7416       implicit real*8 (a-h,o-z)
7417       include 'DIMENSIONS'
7418       include 'COMMON.IOUNITS'
7419 #ifdef MPI
7420       include "mpif.h"
7421       parameter (max_cont=maxconts)
7422       parameter (max_dim=70)
7423       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7424       double precision zapas(max_dim,maxconts,max_fg_procs),
7425      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7426       common /przechowalnia/ zapas
7427       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7428      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7429 #endif
7430       include 'COMMON.SETUP'
7431       include 'COMMON.FFIELD'
7432       include 'COMMON.DERIV'
7433       include 'COMMON.LOCAL'
7434       include 'COMMON.INTERACT'
7435       include 'COMMON.CONTACTS'
7436       include 'COMMON.CHAIN'
7437       include 'COMMON.CONTROL'
7438       double precision gx(3),gx1(3)
7439       integer num_cont_hb_old(maxres)
7440       logical lprn,ldone
7441       double precision eello4,eello5,eelo6,eello_turn6
7442       external eello4,eello5,eello6,eello_turn6
7443 C Set lprn=.true. for debugging
7444       lprn=.false.
7445       eturn6=0.0d0
7446 #ifdef MPI
7447       do i=1,nres
7448         num_cont_hb_old(i)=num_cont_hb(i)
7449       enddo
7450       n_corr=0
7451       n_corr1=0
7452       if (nfgtasks.le.1) goto 30
7453       if (lprn) then
7454         write (iout,'(a)') 'Contact function values before RECEIVE:'
7455         do i=nnt,nct-2
7456           write (iout,'(2i3,50(1x,i2,f5.2))')
7457      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7458      &    j=1,num_cont_hb(i))
7459         enddo
7460       endif
7461       call flush(iout)
7462       do i=1,ntask_cont_from
7463         ncont_recv(i)=0
7464       enddo
7465       do i=1,ntask_cont_to
7466         ncont_sent(i)=0
7467       enddo
7468 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7469 c     & ntask_cont_to
7470 C Make the list of contacts to send to send to other procesors
7471       do i=iturn3_start,iturn3_end
7472 c        write (iout,*) "make contact list turn3",i," num_cont",
7473 c     &    num_cont_hb(i)
7474         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7475       enddo
7476       do i=iturn4_start,iturn4_end
7477 c        write (iout,*) "make contact list turn4",i," num_cont",
7478 c     &   num_cont_hb(i)
7479         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7480       enddo
7481       do ii=1,nat_sent
7482         i=iat_sent(ii)
7483 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7484 c     &    num_cont_hb(i)
7485         do j=1,num_cont_hb(i)
7486         do k=1,4
7487           jjc=jcont_hb(j,i)
7488           iproc=iint_sent_local(k,jjc,ii)
7489 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7490           if (iproc.ne.0) then
7491             ncont_sent(iproc)=ncont_sent(iproc)+1
7492             nn=ncont_sent(iproc)
7493             zapas(1,nn,iproc)=i
7494             zapas(2,nn,iproc)=jjc
7495             zapas(3,nn,iproc)=d_cont(j,i)
7496             ind=3
7497             do kk=1,3
7498               ind=ind+1
7499               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7500             enddo
7501             do kk=1,2
7502               do ll=1,2
7503                 ind=ind+1
7504                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7505               enddo
7506             enddo
7507             do jj=1,5
7508               do kk=1,3
7509                 do ll=1,2
7510                   do mm=1,2
7511                     ind=ind+1
7512                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7513                   enddo
7514                 enddo
7515               enddo
7516             enddo
7517           endif
7518         enddo
7519         enddo
7520       enddo
7521       if (lprn) then
7522       write (iout,*)
7523      &  "Numbers of contacts to be sent to other processors",
7524      &  (ncont_sent(i),i=1,ntask_cont_to)
7525       write (iout,*) "Contacts sent"
7526       do ii=1,ntask_cont_to
7527         nn=ncont_sent(ii)
7528         iproc=itask_cont_to(ii)
7529         write (iout,*) nn," contacts to processor",iproc,
7530      &   " of CONT_TO_COMM group"
7531         do i=1,nn
7532           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7533         enddo
7534       enddo
7535       call flush(iout)
7536       endif
7537       CorrelType=477
7538       CorrelID=fg_rank+1
7539       CorrelType1=478
7540       CorrelID1=nfgtasks+fg_rank+1
7541       ireq=0
7542 C Receive the numbers of needed contacts from other processors
7543       do ii=1,ntask_cont_from
7544         iproc=itask_cont_from(ii)
7545         ireq=ireq+1
7546         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7547      &    FG_COMM,req(ireq),IERR)
7548       enddo
7549 c      write (iout,*) "IRECV ended"
7550 c      call flush(iout)
7551 C Send the number of contacts needed by other processors
7552       do ii=1,ntask_cont_to
7553         iproc=itask_cont_to(ii)
7554         ireq=ireq+1
7555         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7556      &    FG_COMM,req(ireq),IERR)
7557       enddo
7558 c      write (iout,*) "ISEND ended"
7559 c      write (iout,*) "number of requests (nn)",ireq
7560       call flush(iout)
7561       if (ireq.gt.0)
7562      &  call MPI_Waitall(ireq,req,status_array,ierr)
7563 c      write (iout,*)
7564 c     &  "Numbers of contacts to be received from other processors",
7565 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7566 c      call flush(iout)
7567 C Receive contacts
7568       ireq=0
7569       do ii=1,ntask_cont_from
7570         iproc=itask_cont_from(ii)
7571         nn=ncont_recv(ii)
7572 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7573 c     &   " of CONT_TO_COMM group"
7574         call flush(iout)
7575         if (nn.gt.0) then
7576           ireq=ireq+1
7577           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7578      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7579 c          write (iout,*) "ireq,req",ireq,req(ireq)
7580         endif
7581       enddo
7582 C Send the contacts to processors that need them
7583       do ii=1,ntask_cont_to
7584         iproc=itask_cont_to(ii)
7585         nn=ncont_sent(ii)
7586 c        write (iout,*) nn," contacts to processor",iproc,
7587 c     &   " of CONT_TO_COMM group"
7588         if (nn.gt.0) then
7589           ireq=ireq+1
7590           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7591      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7592 c          write (iout,*) "ireq,req",ireq,req(ireq)
7593 c          do i=1,nn
7594 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7595 c          enddo
7596         endif
7597       enddo
7598 c      write (iout,*) "number of requests (contacts)",ireq
7599 c      write (iout,*) "req",(req(i),i=1,4)
7600 c      call flush(iout)
7601       if (ireq.gt.0)
7602      & call MPI_Waitall(ireq,req,status_array,ierr)
7603       do iii=1,ntask_cont_from
7604         iproc=itask_cont_from(iii)
7605         nn=ncont_recv(iii)
7606         if (lprn) then
7607         write (iout,*) "Received",nn," contacts from processor",iproc,
7608      &   " of CONT_FROM_COMM group"
7609         call flush(iout)
7610         do i=1,nn
7611           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7612         enddo
7613         call flush(iout)
7614         endif
7615         do i=1,nn
7616           ii=zapas_recv(1,i,iii)
7617 c Flag the received contacts to prevent double-counting
7618           jj=-zapas_recv(2,i,iii)
7619 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7620 c          call flush(iout)
7621           nnn=num_cont_hb(ii)+1
7622           num_cont_hb(ii)=nnn
7623           jcont_hb(nnn,ii)=jj
7624           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7625           ind=3
7626           do kk=1,3
7627             ind=ind+1
7628             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7629           enddo
7630           do kk=1,2
7631             do ll=1,2
7632               ind=ind+1
7633               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7634             enddo
7635           enddo
7636           do jj=1,5
7637             do kk=1,3
7638               do ll=1,2
7639                 do mm=1,2
7640                   ind=ind+1
7641                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7642                 enddo
7643               enddo
7644             enddo
7645           enddo
7646         enddo
7647       enddo
7648       call flush(iout)
7649       if (lprn) then
7650         write (iout,'(a)') 'Contact function values after receive:'
7651         do i=nnt,nct-2
7652           write (iout,'(2i3,50(1x,i3,5f6.3))')
7653      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7654      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7655         enddo
7656         call flush(iout)
7657       endif
7658    30 continue
7659 #endif
7660       if (lprn) then
7661         write (iout,'(a)') 'Contact function values:'
7662         do i=nnt,nct-2
7663           write (iout,'(2i3,50(1x,i2,5f6.3))')
7664      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7665      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7666         enddo
7667       endif
7668       ecorr=0.0D0
7669       ecorr5=0.0d0
7670       ecorr6=0.0d0
7671 C Remove the loop below after debugging !!!
7672       do i=nnt,nct
7673         do j=1,3
7674           gradcorr(j,i)=0.0D0
7675           gradxorr(j,i)=0.0D0
7676         enddo
7677       enddo
7678 C Calculate the dipole-dipole interaction energies
7679       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7680       do i=iatel_s,iatel_e+1
7681         num_conti=num_cont_hb(i)
7682         do jj=1,num_conti
7683           j=jcont_hb(jj,i)
7684 #ifdef MOMENT
7685           call dipole(i,j,jj)
7686 #endif
7687         enddo
7688       enddo
7689       endif
7690 C Calculate the local-electrostatic correlation terms
7691 c                write (iout,*) "gradcorr5 in eello5 before loop"
7692 c                do iii=1,nres
7693 c                  write (iout,'(i5,3f10.5)')
7694 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7695 c                enddo
7696       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7697 c        write (iout,*) "corr loop i",i
7698         i1=i+1
7699         num_conti=num_cont_hb(i)
7700         num_conti1=num_cont_hb(i+1)
7701         do jj=1,num_conti
7702           j=jcont_hb(jj,i)
7703           jp=iabs(j)
7704           do kk=1,num_conti1
7705             j1=jcont_hb(kk,i1)
7706             jp1=iabs(j1)
7707 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7708 c     &         ' jj=',jj,' kk=',kk
7709 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7710             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7711      &          .or. j.lt.0 .and. j1.gt.0) .and.
7712      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7713 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7714 C The system gains extra energy.
7715               n_corr=n_corr+1
7716               sqd1=dsqrt(d_cont(jj,i))
7717               sqd2=dsqrt(d_cont(kk,i1))
7718               sred_geom = sqd1*sqd2
7719               IF (sred_geom.lt.cutoff_corr) THEN
7720                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7721      &            ekont,fprimcont)
7722 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7723 cd     &         ' jj=',jj,' kk=',kk
7724                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7725                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7726                 do l=1,3
7727                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7728                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7729                 enddo
7730                 n_corr1=n_corr1+1
7731 cd               write (iout,*) 'sred_geom=',sred_geom,
7732 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7733 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7734 cd               write (iout,*) "g_contij",g_contij
7735 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7736 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7737                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7738                 if (wcorr4.gt.0.0d0)
7739      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7740                   if (energy_dec.and.wcorr4.gt.0.0d0)
7741      1                 write (iout,'(a6,4i5,0pf7.3)')
7742      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7743 c                write (iout,*) "gradcorr5 before eello5"
7744 c                do iii=1,nres
7745 c                  write (iout,'(i5,3f10.5)')
7746 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7747 c                enddo
7748                 if (wcorr5.gt.0.0d0)
7749      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7750 c                write (iout,*) "gradcorr5 after eello5"
7751 c                do iii=1,nres
7752 c                  write (iout,'(i5,3f10.5)')
7753 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7754 c                enddo
7755                   if (energy_dec.and.wcorr5.gt.0.0d0)
7756      1                 write (iout,'(a6,4i5,0pf7.3)')
7757      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7758 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7759 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7760                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7761      &               .or. wturn6.eq.0.0d0))then
7762 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7763                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7764                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7765      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7766 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7767 cd     &            'ecorr6=',ecorr6
7768 cd                write (iout,'(4e15.5)') sred_geom,
7769 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7770 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7771 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7772                 else if (wturn6.gt.0.0d0
7773      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7774 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7775                   eturn6=eturn6+eello_turn6(i,jj,kk)
7776                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7777      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7778 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7779                 endif
7780               ENDIF
7781 1111          continue
7782             endif
7783           enddo ! kk
7784         enddo ! jj
7785       enddo ! i
7786       do i=1,nres
7787         num_cont_hb(i)=num_cont_hb_old(i)
7788       enddo
7789 c                write (iout,*) "gradcorr5 in eello5"
7790 c                do iii=1,nres
7791 c                  write (iout,'(i5,3f10.5)')
7792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7793 c                enddo
7794       return
7795       end
7796 c------------------------------------------------------------------------------
7797       subroutine add_hb_contact_eello(ii,jj,itask)
7798       implicit real*8 (a-h,o-z)
7799       include "DIMENSIONS"
7800       include "COMMON.IOUNITS"
7801       integer max_cont
7802       integer max_dim
7803       parameter (max_cont=maxconts)
7804       parameter (max_dim=70)
7805       include "COMMON.CONTACTS"
7806       double precision zapas(max_dim,maxconts,max_fg_procs),
7807      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7808       common /przechowalnia/ zapas
7809       integer i,j,ii,jj,iproc,itask(4),nn
7810 c      write (iout,*) "itask",itask
7811       do i=1,2
7812         iproc=itask(i)
7813         if (iproc.gt.0) then
7814           do j=1,num_cont_hb(ii)
7815             jjc=jcont_hb(j,ii)
7816 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7817             if (jjc.eq.jj) then
7818               ncont_sent(iproc)=ncont_sent(iproc)+1
7819               nn=ncont_sent(iproc)
7820               zapas(1,nn,iproc)=ii
7821               zapas(2,nn,iproc)=jjc
7822               zapas(3,nn,iproc)=d_cont(j,ii)
7823               ind=3
7824               do kk=1,3
7825                 ind=ind+1
7826                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7827               enddo
7828               do kk=1,2
7829                 do ll=1,2
7830                   ind=ind+1
7831                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7832                 enddo
7833               enddo
7834               do jj=1,5
7835                 do kk=1,3
7836                   do ll=1,2
7837                     do mm=1,2
7838                       ind=ind+1
7839                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7840                     enddo
7841                   enddo
7842                 enddo
7843               enddo
7844               exit
7845             endif
7846           enddo
7847         endif
7848       enddo
7849       return
7850       end
7851 c------------------------------------------------------------------------------
7852       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7853       implicit real*8 (a-h,o-z)
7854       include 'DIMENSIONS'
7855       include 'COMMON.IOUNITS'
7856       include 'COMMON.DERIV'
7857       include 'COMMON.INTERACT'
7858       include 'COMMON.CONTACTS'
7859       double precision gx(3),gx1(3)
7860       logical lprn
7861       lprn=.false.
7862       eij=facont_hb(jj,i)
7863       ekl=facont_hb(kk,k)
7864       ees0pij=ees0p(jj,i)
7865       ees0pkl=ees0p(kk,k)
7866       ees0mij=ees0m(jj,i)
7867       ees0mkl=ees0m(kk,k)
7868       ekont=eij*ekl
7869       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7870 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7871 C Following 4 lines for diagnostics.
7872 cd    ees0pkl=0.0D0
7873 cd    ees0pij=1.0D0
7874 cd    ees0mkl=0.0D0
7875 cd    ees0mij=1.0D0
7876 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7877 c     & 'Contacts ',i,j,
7878 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7879 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7880 c     & 'gradcorr_long'
7881 C Calculate the multi-body contribution to energy.
7882 c      ecorr=ecorr+ekont*ees
7883 C Calculate multi-body contributions to the gradient.
7884       coeffpees0pij=coeffp*ees0pij
7885       coeffmees0mij=coeffm*ees0mij
7886       coeffpees0pkl=coeffp*ees0pkl
7887       coeffmees0mkl=coeffm*ees0mkl
7888       do ll=1,3
7889 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7890         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7891      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7892      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7893         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7894      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7895      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7896 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7897         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7898      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7899      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7900         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7901      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7902      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7903         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7904      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7905      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7906         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7907         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7908         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7909      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7910      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7911         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7912         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7913 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7914       enddo
7915 c      write (iout,*)
7916 cgrad      do m=i+1,j-1
7917 cgrad        do ll=1,3
7918 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7919 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7920 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7921 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7922 cgrad        enddo
7923 cgrad      enddo
7924 cgrad      do m=k+1,l-1
7925 cgrad        do ll=1,3
7926 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7927 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7928 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7929 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7930 cgrad        enddo
7931 cgrad      enddo
7932 c      write (iout,*) "ehbcorr",ekont*ees
7933       ehbcorr=ekont*ees
7934       return
7935       end
7936 #ifdef MOMENT
7937 C---------------------------------------------------------------------------
7938       subroutine dipole(i,j,jj)
7939       implicit real*8 (a-h,o-z)
7940       include 'DIMENSIONS'
7941       include 'COMMON.IOUNITS'
7942       include 'COMMON.CHAIN'
7943       include 'COMMON.FFIELD'
7944       include 'COMMON.DERIV'
7945       include 'COMMON.INTERACT'
7946       include 'COMMON.CONTACTS'
7947       include 'COMMON.TORSION'
7948       include 'COMMON.VAR'
7949       include 'COMMON.GEO'
7950       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7951      &  auxmat(2,2)
7952       iti1 = itortyp(itype(i+1))
7953       if (j.lt.nres-1) then
7954         itj1 = itortyp(itype(j+1))
7955       else
7956         itj1=ntortyp
7957       endif
7958       do iii=1,2
7959         dipi(iii,1)=Ub2(iii,i)
7960         dipderi(iii)=Ub2der(iii,i)
7961         dipi(iii,2)=b1(iii,i+1)
7962         dipj(iii,1)=Ub2(iii,j)
7963         dipderj(iii)=Ub2der(iii,j)
7964         dipj(iii,2)=b1(iii,j+1)
7965       enddo
7966       kkk=0
7967       do iii=1,2
7968         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7969         do jjj=1,2
7970           kkk=kkk+1
7971           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7972         enddo
7973       enddo
7974       do kkk=1,5
7975         do lll=1,3
7976           mmm=0
7977           do iii=1,2
7978             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7979      &        auxvec(1))
7980             do jjj=1,2
7981               mmm=mmm+1
7982               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7983             enddo
7984           enddo
7985         enddo
7986       enddo
7987       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7988       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7989       do iii=1,2
7990         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7991       enddo
7992       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7993       do iii=1,2
7994         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7995       enddo
7996       return
7997       end
7998 #endif
7999 C---------------------------------------------------------------------------
8000       subroutine calc_eello(i,j,k,l,jj,kk)
8001 C
8002 C This subroutine computes matrices and vectors needed to calculate
8003 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8004 C
8005       implicit real*8 (a-h,o-z)
8006       include 'DIMENSIONS'
8007       include 'COMMON.IOUNITS'
8008       include 'COMMON.CHAIN'
8009       include 'COMMON.DERIV'
8010       include 'COMMON.INTERACT'
8011       include 'COMMON.CONTACTS'
8012       include 'COMMON.TORSION'
8013       include 'COMMON.VAR'
8014       include 'COMMON.GEO'
8015       include 'COMMON.FFIELD'
8016       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8017      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8018       logical lprn
8019       common /kutas/ lprn
8020 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8021 cd     & ' jj=',jj,' kk=',kk
8022 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8023 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8024 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8025       do iii=1,2
8026         do jjj=1,2
8027           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8028           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8029         enddo
8030       enddo
8031       call transpose2(aa1(1,1),aa1t(1,1))
8032       call transpose2(aa2(1,1),aa2t(1,1))
8033       do kkk=1,5
8034         do lll=1,3
8035           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8036      &      aa1tder(1,1,lll,kkk))
8037           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8038      &      aa2tder(1,1,lll,kkk))
8039         enddo
8040       enddo
8041       if (l.eq.j+1) then
8042 C parallel orientation of the two CA-CA-CA frames.
8043         if (i.gt.1) then
8044           iti=itortyp(itype(i))
8045         else
8046           iti=ntortyp
8047         endif
8048         itk1=itortyp(itype(k+1))
8049         itj=itortyp(itype(j))
8050         if (l.lt.nres-1) then
8051           itl1=itortyp(itype(l+1))
8052         else
8053           itl1=ntortyp
8054         endif
8055 C A1 kernel(j+1) A2T
8056 cd        do iii=1,2
8057 cd          write (iout,'(3f10.5,5x,3f10.5)')
8058 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8059 cd        enddo
8060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8061      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8062      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8063 C Following matrices are needed only for 6-th order cumulants
8064         IF (wcorr6.gt.0.0d0) THEN
8065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8066      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8067      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8069      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8070      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8071      &   ADtEAderx(1,1,1,1,1,1))
8072         lprn=.false.
8073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8074      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8075      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8076      &   ADtEA1derx(1,1,1,1,1,1))
8077         ENDIF
8078 C End 6-th order cumulants
8079 cd        lprn=.false.
8080 cd        if (lprn) then
8081 cd        write (2,*) 'In calc_eello6'
8082 cd        do iii=1,2
8083 cd          write (2,*) 'iii=',iii
8084 cd          do kkk=1,5
8085 cd            write (2,*) 'kkk=',kkk
8086 cd            do jjj=1,2
8087 cd              write (2,'(3(2f10.5),5x)')
8088 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8089 cd            enddo
8090 cd          enddo
8091 cd        enddo
8092 cd        endif
8093         call transpose2(EUgder(1,1,k),auxmat(1,1))
8094         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8095         call transpose2(EUg(1,1,k),auxmat(1,1))
8096         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8097         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8098         do iii=1,2
8099           do kkk=1,5
8100             do lll=1,3
8101               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8102      &          EAEAderx(1,1,lll,kkk,iii,1))
8103             enddo
8104           enddo
8105         enddo
8106 C A1T kernel(i+1) A2
8107         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8108      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8109      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8110 C Following matrices are needed only for 6-th order cumulants
8111         IF (wcorr6.gt.0.0d0) THEN
8112         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8113      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8114      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8115         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8116      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8117      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8118      &   ADtEAderx(1,1,1,1,1,2))
8119         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8120      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8121      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8122      &   ADtEA1derx(1,1,1,1,1,2))
8123         ENDIF
8124 C End 6-th order cumulants
8125         call transpose2(EUgder(1,1,l),auxmat(1,1))
8126         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8127         call transpose2(EUg(1,1,l),auxmat(1,1))
8128         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8129         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8130         do iii=1,2
8131           do kkk=1,5
8132             do lll=1,3
8133               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8134      &          EAEAderx(1,1,lll,kkk,iii,2))
8135             enddo
8136           enddo
8137         enddo
8138 C AEAb1 and AEAb2
8139 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8140 C They are needed only when the fifth- or the sixth-order cumulants are
8141 C indluded.
8142         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8143         call transpose2(AEA(1,1,1),auxmat(1,1))
8144         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8145         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8146         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8147         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8148         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8149         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8150         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8151         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8152         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8153         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8154         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8155         call transpose2(AEA(1,1,2),auxmat(1,1))
8156         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8157         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8158         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8159         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8160         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8161         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8162         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8163         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8164         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8165         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8166         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8167 C Calculate the Cartesian derivatives of the vectors.
8168         do iii=1,2
8169           do kkk=1,5
8170             do lll=1,3
8171               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8172               call matvec2(auxmat(1,1),b1(1,i),
8173      &          AEAb1derx(1,lll,kkk,iii,1,1))
8174               call matvec2(auxmat(1,1),Ub2(1,i),
8175      &          AEAb2derx(1,lll,kkk,iii,1,1))
8176               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8177      &          AEAb1derx(1,lll,kkk,iii,2,1))
8178               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8179      &          AEAb2derx(1,lll,kkk,iii,2,1))
8180               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8181               call matvec2(auxmat(1,1),b1(1,j),
8182      &          AEAb1derx(1,lll,kkk,iii,1,2))
8183               call matvec2(auxmat(1,1),Ub2(1,j),
8184      &          AEAb2derx(1,lll,kkk,iii,1,2))
8185               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8186      &          AEAb1derx(1,lll,kkk,iii,2,2))
8187               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8188      &          AEAb2derx(1,lll,kkk,iii,2,2))
8189             enddo
8190           enddo
8191         enddo
8192         ENDIF
8193 C End vectors
8194       else
8195 C Antiparallel orientation of the two CA-CA-CA frames.
8196         if (i.gt.1) then
8197           iti=itortyp(itype(i))
8198         else
8199           iti=ntortyp
8200         endif
8201         itk1=itortyp(itype(k+1))
8202         itl=itortyp(itype(l))
8203         itj=itortyp(itype(j))
8204         if (j.lt.nres-1) then
8205           itj1=itortyp(itype(j+1))
8206         else
8207           itj1=ntortyp
8208         endif
8209 C A2 kernel(j-1)T A1T
8210         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8211      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8212      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8213 C Following matrices are needed only for 6-th order cumulants
8214         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8215      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8216         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8217      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8218      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8219         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8220      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8221      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8222      &   ADtEAderx(1,1,1,1,1,1))
8223         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8224      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8225      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8226      &   ADtEA1derx(1,1,1,1,1,1))
8227         ENDIF
8228 C End 6-th order cumulants
8229         call transpose2(EUgder(1,1,k),auxmat(1,1))
8230         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8231         call transpose2(EUg(1,1,k),auxmat(1,1))
8232         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8233         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8234         do iii=1,2
8235           do kkk=1,5
8236             do lll=1,3
8237               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8238      &          EAEAderx(1,1,lll,kkk,iii,1))
8239             enddo
8240           enddo
8241         enddo
8242 C A2T kernel(i+1)T A1
8243         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8244      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8245      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8246 C Following matrices are needed only for 6-th order cumulants
8247         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8248      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8249         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8250      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8251      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8252         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8253      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8254      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8255      &   ADtEAderx(1,1,1,1,1,2))
8256         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8257      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8258      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8259      &   ADtEA1derx(1,1,1,1,1,2))
8260         ENDIF
8261 C End 6-th order cumulants
8262         call transpose2(EUgder(1,1,j),auxmat(1,1))
8263         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8264         call transpose2(EUg(1,1,j),auxmat(1,1))
8265         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8266         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8267         do iii=1,2
8268           do kkk=1,5
8269             do lll=1,3
8270               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8271      &          EAEAderx(1,1,lll,kkk,iii,2))
8272             enddo
8273           enddo
8274         enddo
8275 C AEAb1 and AEAb2
8276 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8277 C They are needed only when the fifth- or the sixth-order cumulants are
8278 C indluded.
8279         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8280      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8281         call transpose2(AEA(1,1,1),auxmat(1,1))
8282         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8283         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8284         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8285         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8286         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8287         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8288         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8289         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8290         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8291         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8292         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8293         call transpose2(AEA(1,1,2),auxmat(1,1))
8294         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8295         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8296         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8297         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8298         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8299         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8300         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8301         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8302         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8303         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8304         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8305 C Calculate the Cartesian derivatives of the vectors.
8306         do iii=1,2
8307           do kkk=1,5
8308             do lll=1,3
8309               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8310               call matvec2(auxmat(1,1),b1(1,i),
8311      &          AEAb1derx(1,lll,kkk,iii,1,1))
8312               call matvec2(auxmat(1,1),Ub2(1,i),
8313      &          AEAb2derx(1,lll,kkk,iii,1,1))
8314               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8315      &          AEAb1derx(1,lll,kkk,iii,2,1))
8316               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8317      &          AEAb2derx(1,lll,kkk,iii,2,1))
8318               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8319               call matvec2(auxmat(1,1),b1(1,l),
8320      &          AEAb1derx(1,lll,kkk,iii,1,2))
8321               call matvec2(auxmat(1,1),Ub2(1,l),
8322      &          AEAb2derx(1,lll,kkk,iii,1,2))
8323               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8324      &          AEAb1derx(1,lll,kkk,iii,2,2))
8325               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8326      &          AEAb2derx(1,lll,kkk,iii,2,2))
8327             enddo
8328           enddo
8329         enddo
8330         ENDIF
8331 C End vectors
8332       endif
8333       return
8334       end
8335 C---------------------------------------------------------------------------
8336       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8337      &  KK,KKderg,AKA,AKAderg,AKAderx)
8338       implicit none
8339       integer nderg
8340       logical transp
8341       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8342      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8343      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8344       integer iii,kkk,lll
8345       integer jjj,mmm
8346       logical lprn
8347       common /kutas/ lprn
8348       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8349       do iii=1,nderg
8350         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8351      &    AKAderg(1,1,iii))
8352       enddo
8353 cd      if (lprn) write (2,*) 'In kernel'
8354       do kkk=1,5
8355 cd        if (lprn) write (2,*) 'kkk=',kkk
8356         do lll=1,3
8357           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8358      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8359 cd          if (lprn) then
8360 cd            write (2,*) 'lll=',lll
8361 cd            write (2,*) 'iii=1'
8362 cd            do jjj=1,2
8363 cd              write (2,'(3(2f10.5),5x)')
8364 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8365 cd            enddo
8366 cd          endif
8367           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8368      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8369 cd          if (lprn) then
8370 cd            write (2,*) 'lll=',lll
8371 cd            write (2,*) 'iii=2'
8372 cd            do jjj=1,2
8373 cd              write (2,'(3(2f10.5),5x)')
8374 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8375 cd            enddo
8376 cd          endif
8377         enddo
8378       enddo
8379       return
8380       end
8381 C---------------------------------------------------------------------------
8382       double precision function eello4(i,j,k,l,jj,kk)
8383       implicit real*8 (a-h,o-z)
8384       include 'DIMENSIONS'
8385       include 'COMMON.IOUNITS'
8386       include 'COMMON.CHAIN'
8387       include 'COMMON.DERIV'
8388       include 'COMMON.INTERACT'
8389       include 'COMMON.CONTACTS'
8390       include 'COMMON.TORSION'
8391       include 'COMMON.VAR'
8392       include 'COMMON.GEO'
8393       double precision pizda(2,2),ggg1(3),ggg2(3)
8394 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8395 cd        eello4=0.0d0
8396 cd        return
8397 cd      endif
8398 cd      print *,'eello4:',i,j,k,l,jj,kk
8399 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8400 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8401 cold      eij=facont_hb(jj,i)
8402 cold      ekl=facont_hb(kk,k)
8403 cold      ekont=eij*ekl
8404       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8405 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8406       gcorr_loc(k-1)=gcorr_loc(k-1)
8407      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8408       if (l.eq.j+1) then
8409         gcorr_loc(l-1)=gcorr_loc(l-1)
8410      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8411       else
8412         gcorr_loc(j-1)=gcorr_loc(j-1)
8413      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8414       endif
8415       do iii=1,2
8416         do kkk=1,5
8417           do lll=1,3
8418             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8419      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8420 cd            derx(lll,kkk,iii)=0.0d0
8421           enddo
8422         enddo
8423       enddo
8424 cd      gcorr_loc(l-1)=0.0d0
8425 cd      gcorr_loc(j-1)=0.0d0
8426 cd      gcorr_loc(k-1)=0.0d0
8427 cd      eel4=1.0d0
8428 cd      write (iout,*)'Contacts have occurred for peptide groups',
8429 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8430 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8431       if (j.lt.nres-1) then
8432         j1=j+1
8433         j2=j-1
8434       else
8435         j1=j-1
8436         j2=j-2
8437       endif
8438       if (l.lt.nres-1) then
8439         l1=l+1
8440         l2=l-1
8441       else
8442         l1=l-1
8443         l2=l-2
8444       endif
8445       do ll=1,3
8446 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8447 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8448         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8449         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8450 cgrad        ghalf=0.5d0*ggg1(ll)
8451         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8452         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8453         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8454         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8455         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8456         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8457 cgrad        ghalf=0.5d0*ggg2(ll)
8458         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8459         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8460         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8461         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8462         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8463         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8464       enddo
8465 cgrad      do m=i+1,j-1
8466 cgrad        do ll=1,3
8467 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8468 cgrad        enddo
8469 cgrad      enddo
8470 cgrad      do m=k+1,l-1
8471 cgrad        do ll=1,3
8472 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8473 cgrad        enddo
8474 cgrad      enddo
8475 cgrad      do m=i+2,j2
8476 cgrad        do ll=1,3
8477 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8478 cgrad        enddo
8479 cgrad      enddo
8480 cgrad      do m=k+2,l2
8481 cgrad        do ll=1,3
8482 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8483 cgrad        enddo
8484 cgrad      enddo
8485 cd      do iii=1,nres-3
8486 cd        write (2,*) iii,gcorr_loc(iii)
8487 cd      enddo
8488       eello4=ekont*eel4
8489 cd      write (2,*) 'ekont',ekont
8490 cd      write (iout,*) 'eello4',ekont*eel4
8491       return
8492       end
8493 C---------------------------------------------------------------------------
8494       double precision function eello5(i,j,k,l,jj,kk)
8495       implicit real*8 (a-h,o-z)
8496       include 'DIMENSIONS'
8497       include 'COMMON.IOUNITS'
8498       include 'COMMON.CHAIN'
8499       include 'COMMON.DERIV'
8500       include 'COMMON.INTERACT'
8501       include 'COMMON.CONTACTS'
8502       include 'COMMON.TORSION'
8503       include 'COMMON.VAR'
8504       include 'COMMON.GEO'
8505       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8506       double precision ggg1(3),ggg2(3)
8507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8508 C                                                                              C
8509 C                            Parallel chains                                   C
8510 C                                                                              C
8511 C          o             o                   o             o                   C
8512 C         /l\           / \             \   / \           / \   /              C
8513 C        /   \         /   \             \ /   \         /   \ /               C
8514 C       j| o |l1       | o |              o| o |         | o |o                C
8515 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8516 C      \i/   \         /   \ /             /   \         /   \                 C
8517 C       o    k1             o                                                  C
8518 C         (I)          (II)                (III)          (IV)                 C
8519 C                                                                              C
8520 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8521 C                                                                              C
8522 C                            Antiparallel chains                               C
8523 C                                                                              C
8524 C          o             o                   o             o                   C
8525 C         /j\           / \             \   / \           / \   /              C
8526 C        /   \         /   \             \ /   \         /   \ /               C
8527 C      j1| o |l        | o |              o| o |         | o |o                C
8528 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8529 C      \i/   \         /   \ /             /   \         /   \                 C
8530 C       o     k1            o                                                  C
8531 C         (I)          (II)                (III)          (IV)                 C
8532 C                                                                              C
8533 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8534 C                                                                              C
8535 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8536 C                                                                              C
8537 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8538 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8539 cd        eello5=0.0d0
8540 cd        return
8541 cd      endif
8542 cd      write (iout,*)
8543 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8544 cd     &   ' and',k,l
8545       itk=itortyp(itype(k))
8546       itl=itortyp(itype(l))
8547       itj=itortyp(itype(j))
8548       eello5_1=0.0d0
8549       eello5_2=0.0d0
8550       eello5_3=0.0d0
8551       eello5_4=0.0d0
8552 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8553 cd     &   eel5_3_num,eel5_4_num)
8554       do iii=1,2
8555         do kkk=1,5
8556           do lll=1,3
8557             derx(lll,kkk,iii)=0.0d0
8558           enddo
8559         enddo
8560       enddo
8561 cd      eij=facont_hb(jj,i)
8562 cd      ekl=facont_hb(kk,k)
8563 cd      ekont=eij*ekl
8564 cd      write (iout,*)'Contacts have occurred for peptide groups',
8565 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8566 cd      goto 1111
8567 C Contribution from the graph I.
8568 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8569 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8570       call transpose2(EUg(1,1,k),auxmat(1,1))
8571       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(1,2)+pizda(2,1)
8574       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8575      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8576 C Explicit gradient in virtual-dihedral angles.
8577       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8578      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8579      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8580       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8581       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8582       vv(1)=pizda(1,1)-pizda(2,2)
8583       vv(2)=pizda(1,2)+pizda(2,1)
8584       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8585      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8586      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8587       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8588       vv(1)=pizda(1,1)-pizda(2,2)
8589       vv(2)=pizda(1,2)+pizda(2,1)
8590       if (l.eq.j+1) then
8591         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8592      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8593      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8594       else
8595         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8596      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8597      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8598       endif
8599 C Cartesian gradient
8600       do iii=1,2
8601         do kkk=1,5
8602           do lll=1,3
8603             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8604      &        pizda(1,1))
8605             vv(1)=pizda(1,1)-pizda(2,2)
8606             vv(2)=pizda(1,2)+pizda(2,1)
8607             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8608      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8609      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8610           enddo
8611         enddo
8612       enddo
8613 c      goto 1112
8614 c1111  continue
8615 C Contribution from graph II
8616       call transpose2(EE(1,1,itk),auxmat(1,1))
8617       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8618       vv(1)=pizda(1,1)+pizda(2,2)
8619       vv(2)=pizda(2,1)-pizda(1,2)
8620       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8621      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8622 C Explicit gradient in virtual-dihedral angles.
8623       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8624      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8625       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8626       vv(1)=pizda(1,1)+pizda(2,2)
8627       vv(2)=pizda(2,1)-pizda(1,2)
8628       if (l.eq.j+1) then
8629         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8630      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8631      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8632       else
8633         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8634      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8635      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8636       endif
8637 C Cartesian gradient
8638       do iii=1,2
8639         do kkk=1,5
8640           do lll=1,3
8641             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8642      &        pizda(1,1))
8643             vv(1)=pizda(1,1)+pizda(2,2)
8644             vv(2)=pizda(2,1)-pizda(1,2)
8645             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8646      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8647      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8648           enddo
8649         enddo
8650       enddo
8651 cd      goto 1112
8652 cd1111  continue
8653       if (l.eq.j+1) then
8654 cd        goto 1110
8655 C Parallel orientation
8656 C Contribution from graph III
8657         call transpose2(EUg(1,1,l),auxmat(1,1))
8658         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8659         vv(1)=pizda(1,1)-pizda(2,2)
8660         vv(2)=pizda(1,2)+pizda(2,1)
8661         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8663 C Explicit gradient in virtual-dihedral angles.
8664         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8665      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8666      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8667         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8668         vv(1)=pizda(1,1)-pizda(2,2)
8669         vv(2)=pizda(1,2)+pizda(2,1)
8670         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8671      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8672      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8673         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8674         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8675         vv(1)=pizda(1,1)-pizda(2,2)
8676         vv(2)=pizda(1,2)+pizda(2,1)
8677         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8678      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8679      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8680 C Cartesian gradient
8681         do iii=1,2
8682           do kkk=1,5
8683             do lll=1,3
8684               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8685      &          pizda(1,1))
8686               vv(1)=pizda(1,1)-pizda(2,2)
8687               vv(2)=pizda(1,2)+pizda(2,1)
8688               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8689      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8690      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8691             enddo
8692           enddo
8693         enddo
8694 cd        goto 1112
8695 C Contribution from graph IV
8696 cd1110    continue
8697         call transpose2(EE(1,1,itl),auxmat(1,1))
8698         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8699         vv(1)=pizda(1,1)+pizda(2,2)
8700         vv(2)=pizda(2,1)-pizda(1,2)
8701         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8702      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8703 C Explicit gradient in virtual-dihedral angles.
8704         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8705      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8706         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8707         vv(1)=pizda(1,1)+pizda(2,2)
8708         vv(2)=pizda(2,1)-pizda(1,2)
8709         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8710      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8711      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8712 C Cartesian gradient
8713         do iii=1,2
8714           do kkk=1,5
8715             do lll=1,3
8716               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8717      &          pizda(1,1))
8718               vv(1)=pizda(1,1)+pizda(2,2)
8719               vv(2)=pizda(2,1)-pizda(1,2)
8720               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8721      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8722      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8723             enddo
8724           enddo
8725         enddo
8726       else
8727 C Antiparallel orientation
8728 C Contribution from graph III
8729 c        goto 1110
8730         call transpose2(EUg(1,1,j),auxmat(1,1))
8731         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8732         vv(1)=pizda(1,1)-pizda(2,2)
8733         vv(2)=pizda(1,2)+pizda(2,1)
8734         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8735      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8736 C Explicit gradient in virtual-dihedral angles.
8737         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8738      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8739      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8740         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8741         vv(1)=pizda(1,1)-pizda(2,2)
8742         vv(2)=pizda(1,2)+pizda(2,1)
8743         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8744      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8745      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8746         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8747         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8748         vv(1)=pizda(1,1)-pizda(2,2)
8749         vv(2)=pizda(1,2)+pizda(2,1)
8750         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8751      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8752      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8753 C Cartesian gradient
8754         do iii=1,2
8755           do kkk=1,5
8756             do lll=1,3
8757               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8758      &          pizda(1,1))
8759               vv(1)=pizda(1,1)-pizda(2,2)
8760               vv(2)=pizda(1,2)+pizda(2,1)
8761               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8762      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8763      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8764             enddo
8765           enddo
8766         enddo
8767 cd        goto 1112
8768 C Contribution from graph IV
8769 1110    continue
8770         call transpose2(EE(1,1,itj),auxmat(1,1))
8771         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8772         vv(1)=pizda(1,1)+pizda(2,2)
8773         vv(2)=pizda(2,1)-pizda(1,2)
8774         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8775      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8776 C Explicit gradient in virtual-dihedral angles.
8777         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8778      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8779         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8780         vv(1)=pizda(1,1)+pizda(2,2)
8781         vv(2)=pizda(2,1)-pizda(1,2)
8782         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8783      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8784      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8785 C Cartesian gradient
8786         do iii=1,2
8787           do kkk=1,5
8788             do lll=1,3
8789               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8790      &          pizda(1,1))
8791               vv(1)=pizda(1,1)+pizda(2,2)
8792               vv(2)=pizda(2,1)-pizda(1,2)
8793               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8794      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8795      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8796             enddo
8797           enddo
8798         enddo
8799       endif
8800 1112  continue
8801       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8802 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8803 cd        write (2,*) 'ijkl',i,j,k,l
8804 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8805 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8806 cd      endif
8807 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8808 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8809 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8810 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8811       if (j.lt.nres-1) then
8812         j1=j+1
8813         j2=j-1
8814       else
8815         j1=j-1
8816         j2=j-2
8817       endif
8818       if (l.lt.nres-1) then
8819         l1=l+1
8820         l2=l-1
8821       else
8822         l1=l-1
8823         l2=l-2
8824       endif
8825 cd      eij=1.0d0
8826 cd      ekl=1.0d0
8827 cd      ekont=1.0d0
8828 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8829 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8830 C        summed up outside the subrouine as for the other subroutines
8831 C        handling long-range interactions. The old code is commented out
8832 C        with "cgrad" to keep track of changes.
8833       do ll=1,3
8834 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8835 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8836         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8837         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8838 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8839 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8840 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8841 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8842 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8843 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8844 c     &   gradcorr5ij,
8845 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8846 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8847 cgrad        ghalf=0.5d0*ggg1(ll)
8848 cd        ghalf=0.0d0
8849         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8850         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8851         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8852         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8853         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8854         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8855 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8856 cgrad        ghalf=0.5d0*ggg2(ll)
8857 cd        ghalf=0.0d0
8858         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8859         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8860         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8861         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8862         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8863         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8864       enddo
8865 cd      goto 1112
8866 cgrad      do m=i+1,j-1
8867 cgrad        do ll=1,3
8868 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8869 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad      do m=k+1,l-1
8873 cgrad        do ll=1,3
8874 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8875 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8876 cgrad        enddo
8877 cgrad      enddo
8878 c1112  continue
8879 cgrad      do m=i+2,j2
8880 cgrad        do ll=1,3
8881 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8882 cgrad        enddo
8883 cgrad      enddo
8884 cgrad      do m=k+2,l2
8885 cgrad        do ll=1,3
8886 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8887 cgrad        enddo
8888 cgrad      enddo
8889 cd      do iii=1,nres-3
8890 cd        write (2,*) iii,g_corr5_loc(iii)
8891 cd      enddo
8892       eello5=ekont*eel5
8893 cd      write (2,*) 'ekont',ekont
8894 cd      write (iout,*) 'eello5',ekont*eel5
8895       return
8896       end
8897 c--------------------------------------------------------------------------
8898       double precision function eello6(i,j,k,l,jj,kk)
8899       implicit real*8 (a-h,o-z)
8900       include 'DIMENSIONS'
8901       include 'COMMON.IOUNITS'
8902       include 'COMMON.CHAIN'
8903       include 'COMMON.DERIV'
8904       include 'COMMON.INTERACT'
8905       include 'COMMON.CONTACTS'
8906       include 'COMMON.TORSION'
8907       include 'COMMON.VAR'
8908       include 'COMMON.GEO'
8909       include 'COMMON.FFIELD'
8910       double precision ggg1(3),ggg2(3)
8911 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8912 cd        eello6=0.0d0
8913 cd        return
8914 cd      endif
8915 cd      write (iout,*)
8916 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8917 cd     &   ' and',k,l
8918       eello6_1=0.0d0
8919       eello6_2=0.0d0
8920       eello6_3=0.0d0
8921       eello6_4=0.0d0
8922       eello6_5=0.0d0
8923       eello6_6=0.0d0
8924 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8925 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8926       do iii=1,2
8927         do kkk=1,5
8928           do lll=1,3
8929             derx(lll,kkk,iii)=0.0d0
8930           enddo
8931         enddo
8932       enddo
8933 cd      eij=facont_hb(jj,i)
8934 cd      ekl=facont_hb(kk,k)
8935 cd      ekont=eij*ekl
8936 cd      eij=1.0d0
8937 cd      ekl=1.0d0
8938 cd      ekont=1.0d0
8939       if (l.eq.j+1) then
8940         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8941         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8942         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8943         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8944         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8945         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8946       else
8947         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8948         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8949         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8950         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8951         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8952           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8953         else
8954           eello6_5=0.0d0
8955         endif
8956         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8957       endif
8958 C If turn contributions are considered, they will be handled separately.
8959       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8960 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8961 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8962 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8963 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8964 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8965 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8966 cd      goto 1112
8967       if (j.lt.nres-1) then
8968         j1=j+1
8969         j2=j-1
8970       else
8971         j1=j-1
8972         j2=j-2
8973       endif
8974       if (l.lt.nres-1) then
8975         l1=l+1
8976         l2=l-1
8977       else
8978         l1=l-1
8979         l2=l-2
8980       endif
8981       do ll=1,3
8982 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8983 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8984 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8985 cgrad        ghalf=0.5d0*ggg1(ll)
8986 cd        ghalf=0.0d0
8987         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8988         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8989         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8990         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8991         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8992         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8993         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8994         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8995 cgrad        ghalf=0.5d0*ggg2(ll)
8996 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8997 cd        ghalf=0.0d0
8998         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8999         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9000         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9001         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9002         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9003         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9004       enddo
9005 cd      goto 1112
9006 cgrad      do m=i+1,j-1
9007 cgrad        do ll=1,3
9008 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9009 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9010 cgrad        enddo
9011 cgrad      enddo
9012 cgrad      do m=k+1,l-1
9013 cgrad        do ll=1,3
9014 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9015 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9016 cgrad        enddo
9017 cgrad      enddo
9018 cgrad1112  continue
9019 cgrad      do m=i+2,j2
9020 cgrad        do ll=1,3
9021 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9022 cgrad        enddo
9023 cgrad      enddo
9024 cgrad      do m=k+2,l2
9025 cgrad        do ll=1,3
9026 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9027 cgrad        enddo
9028 cgrad      enddo
9029 cd      do iii=1,nres-3
9030 cd        write (2,*) iii,g_corr6_loc(iii)
9031 cd      enddo
9032       eello6=ekont*eel6
9033 cd      write (2,*) 'ekont',ekont
9034 cd      write (iout,*) 'eello6',ekont*eel6
9035       return
9036       end
9037 c--------------------------------------------------------------------------
9038       double precision function eello6_graph1(i,j,k,l,imat,swap)
9039       implicit real*8 (a-h,o-z)
9040       include 'DIMENSIONS'
9041       include 'COMMON.IOUNITS'
9042       include 'COMMON.CHAIN'
9043       include 'COMMON.DERIV'
9044       include 'COMMON.INTERACT'
9045       include 'COMMON.CONTACTS'
9046       include 'COMMON.TORSION'
9047       include 'COMMON.VAR'
9048       include 'COMMON.GEO'
9049       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9050       logical swap
9051       logical lprn
9052       common /kutas/ lprn
9053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9054 C                                                                              C
9055 C      Parallel       Antiparallel                                             C
9056 C                                                                              C
9057 C          o             o                                                     C
9058 C         /l\           /j\                                                    C
9059 C        /   \         /   \                                                   C
9060 C       /| o |         | o |\                                                  C
9061 C     \ j|/k\|  /   \  |/k\|l /                                                C
9062 C      \ /   \ /     \ /   \ /                                                 C
9063 C       o     o       o     o                                                  C
9064 C       i             i                                                        C
9065 C                                                                              C
9066 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9067       itk=itortyp(itype(k))
9068       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9069       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9070       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9071       call transpose2(EUgC(1,1,k),auxmat(1,1))
9072       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9073       vv1(1)=pizda1(1,1)-pizda1(2,2)
9074       vv1(2)=pizda1(1,2)+pizda1(2,1)
9075       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9076       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9077       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9078       s5=scalar2(vv(1),Dtobr2(1,i))
9079 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9080       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9081       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9082      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9083      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9084      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9085      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9086      & +scalar2(vv(1),Dtobr2der(1,i)))
9087       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9088       vv1(1)=pizda1(1,1)-pizda1(2,2)
9089       vv1(2)=pizda1(1,2)+pizda1(2,1)
9090       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9091       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9092       if (l.eq.j+1) then
9093         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9094      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9095      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9096      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9097      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9098       else
9099         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9100      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9101      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9102      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9103      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9104       endif
9105       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9106       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9107       vv1(1)=pizda1(1,1)-pizda1(2,2)
9108       vv1(2)=pizda1(1,2)+pizda1(2,1)
9109       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9110      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9111      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9112      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9113       do iii=1,2
9114         if (swap) then
9115           ind=3-iii
9116         else
9117           ind=iii
9118         endif
9119         do kkk=1,5
9120           do lll=1,3
9121             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9122             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9123             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9124             call transpose2(EUgC(1,1,k),auxmat(1,1))
9125             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9126      &        pizda1(1,1))
9127             vv1(1)=pizda1(1,1)-pizda1(2,2)
9128             vv1(2)=pizda1(1,2)+pizda1(2,1)
9129             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9130             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9131      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9132             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9133      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9134             s5=scalar2(vv(1),Dtobr2(1,i))
9135             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9136           enddo
9137         enddo
9138       enddo
9139       return
9140       end
9141 c----------------------------------------------------------------------------
9142       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9143       implicit real*8 (a-h,o-z)
9144       include 'DIMENSIONS'
9145       include 'COMMON.IOUNITS'
9146       include 'COMMON.CHAIN'
9147       include 'COMMON.DERIV'
9148       include 'COMMON.INTERACT'
9149       include 'COMMON.CONTACTS'
9150       include 'COMMON.TORSION'
9151       include 'COMMON.VAR'
9152       include 'COMMON.GEO'
9153       logical swap
9154       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9155      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9156       logical lprn
9157       common /kutas/ lprn
9158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9159 C                                                                              C
9160 C      Parallel       Antiparallel                                             C
9161 C                                                                              C
9162 C          o             o                                                     C
9163 C     \   /l\           /j\   /                                                C
9164 C      \ /   \         /   \ /                                                 C
9165 C       o| o |         | o |o                                                  C
9166 C     \ j|/k\|      \  |/k\|l                                                  C
9167 C      \ /   \       \ /   \                                                   C
9168 C       o             o                                                        C
9169 C       i             i                                                        C
9170 C                                                                              C
9171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9172 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9173 C AL 7/4/01 s1 would occur in the sixth-order moment,
9174 C           but not in a cluster cumulant
9175 #ifdef MOMENT
9176       s1=dip(1,jj,i)*dip(1,kk,k)
9177 #endif
9178       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9179       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9180       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9181       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9182       call transpose2(EUg(1,1,k),auxmat(1,1))
9183       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9184       vv(1)=pizda(1,1)-pizda(2,2)
9185       vv(2)=pizda(1,2)+pizda(2,1)
9186       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9187 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9188 #ifdef MOMENT
9189       eello6_graph2=-(s1+s2+s3+s4)
9190 #else
9191       eello6_graph2=-(s2+s3+s4)
9192 #endif
9193 c      eello6_graph2=-s3
9194 C Derivatives in gamma(i-1)
9195       if (i.gt.1) then
9196 #ifdef MOMENT
9197         s1=dipderg(1,jj,i)*dip(1,kk,k)
9198 #endif
9199         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9200         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9201         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9202         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9203 #ifdef MOMENT
9204         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9205 #else
9206         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9207 #endif
9208 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9209       endif
9210 C Derivatives in gamma(k-1)
9211 #ifdef MOMENT
9212       s1=dip(1,jj,i)*dipderg(1,kk,k)
9213 #endif
9214       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9215       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9216       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9217       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9218       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9219       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9220       vv(1)=pizda(1,1)-pizda(2,2)
9221       vv(2)=pizda(1,2)+pizda(2,1)
9222       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9223 #ifdef MOMENT
9224       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9225 #else
9226       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9227 #endif
9228 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9229 C Derivatives in gamma(j-1) or gamma(l-1)
9230       if (j.gt.1) then
9231 #ifdef MOMENT
9232         s1=dipderg(3,jj,i)*dip(1,kk,k)
9233 #endif
9234         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9235         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9236         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9237         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9238         vv(1)=pizda(1,1)-pizda(2,2)
9239         vv(2)=pizda(1,2)+pizda(2,1)
9240         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9241 #ifdef MOMENT
9242         if (swap) then
9243           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9244         else
9245           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9246         endif
9247 #endif
9248         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9249 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9250       endif
9251 C Derivatives in gamma(l-1) or gamma(j-1)
9252       if (l.gt.1) then
9253 #ifdef MOMENT
9254         s1=dip(1,jj,i)*dipderg(3,kk,k)
9255 #endif
9256         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9257         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9258         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9259         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9260         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9261         vv(1)=pizda(1,1)-pizda(2,2)
9262         vv(2)=pizda(1,2)+pizda(2,1)
9263         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9264 #ifdef MOMENT
9265         if (swap) then
9266           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9267         else
9268           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9269         endif
9270 #endif
9271         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9272 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9273       endif
9274 C Cartesian derivatives.
9275       if (lprn) then
9276         write (2,*) 'In eello6_graph2'
9277         do iii=1,2
9278           write (2,*) 'iii=',iii
9279           do kkk=1,5
9280             write (2,*) 'kkk=',kkk
9281             do jjj=1,2
9282               write (2,'(3(2f10.5),5x)')
9283      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9284             enddo
9285           enddo
9286         enddo
9287       endif
9288       do iii=1,2
9289         do kkk=1,5
9290           do lll=1,3
9291 #ifdef MOMENT
9292             if (iii.eq.1) then
9293               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9294             else
9295               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9296             endif
9297 #endif
9298             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9299      &        auxvec(1))
9300             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9301             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9302      &        auxvec(1))
9303             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9304             call transpose2(EUg(1,1,k),auxmat(1,1))
9305             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9306      &        pizda(1,1))
9307             vv(1)=pizda(1,1)-pizda(2,2)
9308             vv(2)=pizda(1,2)+pizda(2,1)
9309             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9310 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9311 #ifdef MOMENT
9312             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9313 #else
9314             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9315 #endif
9316             if (swap) then
9317               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9318             else
9319               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9320             endif
9321           enddo
9322         enddo
9323       enddo
9324       return
9325       end
9326 c----------------------------------------------------------------------------
9327       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9328       implicit real*8 (a-h,o-z)
9329       include 'DIMENSIONS'
9330       include 'COMMON.IOUNITS'
9331       include 'COMMON.CHAIN'
9332       include 'COMMON.DERIV'
9333       include 'COMMON.INTERACT'
9334       include 'COMMON.CONTACTS'
9335       include 'COMMON.TORSION'
9336       include 'COMMON.VAR'
9337       include 'COMMON.GEO'
9338       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9339       logical swap
9340 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9341 C                                                                              C
9342 C      Parallel       Antiparallel                                             C
9343 C                                                                              C
9344 C          o             o                                                     C
9345 C         /l\   /   \   /j\                                                    C
9346 C        /   \ /     \ /   \                                                   C
9347 C       /| o |o       o| o |\                                                  C
9348 C       j|/k\|  /      |/k\|l /                                                C
9349 C        /   \ /       /   \ /                                                 C
9350 C       /     o       /     o                                                  C
9351 C       i             i                                                        C
9352 C                                                                              C
9353 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9354 C
9355 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9356 C           energy moment and not to the cluster cumulant.
9357       iti=itortyp(itype(i))
9358       if (j.lt.nres-1) then
9359         itj1=itortyp(itype(j+1))
9360       else
9361         itj1=ntortyp
9362       endif
9363       itk=itortyp(itype(k))
9364       itk1=itortyp(itype(k+1))
9365       if (l.lt.nres-1) then
9366         itl1=itortyp(itype(l+1))
9367       else
9368         itl1=ntortyp
9369       endif
9370 #ifdef MOMENT
9371       s1=dip(4,jj,i)*dip(4,kk,k)
9372 #endif
9373       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9374       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9375       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9376       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9377       call transpose2(EE(1,1,itk),auxmat(1,1))
9378       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9379       vv(1)=pizda(1,1)+pizda(2,2)
9380       vv(2)=pizda(2,1)-pizda(1,2)
9381       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9382 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9383 cd     & "sum",-(s2+s3+s4)
9384 #ifdef MOMENT
9385       eello6_graph3=-(s1+s2+s3+s4)
9386 #else
9387       eello6_graph3=-(s2+s3+s4)
9388 #endif
9389 c      eello6_graph3=-s4
9390 C Derivatives in gamma(k-1)
9391       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9392       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9393       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9394       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9395 C Derivatives in gamma(l-1)
9396       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9397       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9398       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9399       vv(1)=pizda(1,1)+pizda(2,2)
9400       vv(2)=pizda(2,1)-pizda(1,2)
9401       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9402       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9403 C Cartesian derivatives.
9404       do iii=1,2
9405         do kkk=1,5
9406           do lll=1,3
9407 #ifdef MOMENT
9408             if (iii.eq.1) then
9409               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9410             else
9411               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9412             endif
9413 #endif
9414             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9415      &        auxvec(1))
9416             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9417             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9418      &        auxvec(1))
9419             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9420             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9421      &        pizda(1,1))
9422             vv(1)=pizda(1,1)+pizda(2,2)
9423             vv(2)=pizda(2,1)-pizda(1,2)
9424             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9425 #ifdef MOMENT
9426             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9427 #else
9428             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9429 #endif
9430             if (swap) then
9431               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9432             else
9433               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9434             endif
9435 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9436           enddo
9437         enddo
9438       enddo
9439       return
9440       end
9441 c----------------------------------------------------------------------------
9442       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9443       implicit real*8 (a-h,o-z)
9444       include 'DIMENSIONS'
9445       include 'COMMON.IOUNITS'
9446       include 'COMMON.CHAIN'
9447       include 'COMMON.DERIV'
9448       include 'COMMON.INTERACT'
9449       include 'COMMON.CONTACTS'
9450       include 'COMMON.TORSION'
9451       include 'COMMON.VAR'
9452       include 'COMMON.GEO'
9453       include 'COMMON.FFIELD'
9454       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9455      & auxvec1(2),auxmat1(2,2)
9456       logical swap
9457 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9458 C                                                                              C
9459 C      Parallel       Antiparallel                                             C
9460 C                                                                              C
9461 C          o             o                                                     C
9462 C         /l\   /   \   /j\                                                    C
9463 C        /   \ /     \ /   \                                                   C
9464 C       /| o |o       o| o |\                                                  C
9465 C     \ j|/k\|      \  |/k\|l                                                  C
9466 C      \ /   \       \ /   \                                                   C
9467 C       o     \       o     \                                                  C
9468 C       i             i                                                        C
9469 C                                                                              C
9470 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9471 C
9472 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9473 C           energy moment and not to the cluster cumulant.
9474 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9475       iti=itortyp(itype(i))
9476       itj=itortyp(itype(j))
9477       if (j.lt.nres-1) then
9478         itj1=itortyp(itype(j+1))
9479       else
9480         itj1=ntortyp
9481       endif
9482       itk=itortyp(itype(k))
9483       if (k.lt.nres-1) then
9484         itk1=itortyp(itype(k+1))
9485       else
9486         itk1=ntortyp
9487       endif
9488       itl=itortyp(itype(l))
9489       if (l.lt.nres-1) then
9490         itl1=itortyp(itype(l+1))
9491       else
9492         itl1=ntortyp
9493       endif
9494 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9495 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9496 cd     & ' itl',itl,' itl1',itl1
9497 #ifdef MOMENT
9498       if (imat.eq.1) then
9499         s1=dip(3,jj,i)*dip(3,kk,k)
9500       else
9501         s1=dip(2,jj,j)*dip(2,kk,l)
9502       endif
9503 #endif
9504       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9505       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9506       if (j.eq.l+1) then
9507         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9508         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9509       else
9510         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9511         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9512       endif
9513       call transpose2(EUg(1,1,k),auxmat(1,1))
9514       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9515       vv(1)=pizda(1,1)-pizda(2,2)
9516       vv(2)=pizda(2,1)+pizda(1,2)
9517       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9518 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9519 #ifdef MOMENT
9520       eello6_graph4=-(s1+s2+s3+s4)
9521 #else
9522       eello6_graph4=-(s2+s3+s4)
9523 #endif
9524 C Derivatives in gamma(i-1)
9525       if (i.gt.1) then
9526 #ifdef MOMENT
9527         if (imat.eq.1) then
9528           s1=dipderg(2,jj,i)*dip(3,kk,k)
9529         else
9530           s1=dipderg(4,jj,j)*dip(2,kk,l)
9531         endif
9532 #endif
9533         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9534         if (j.eq.l+1) then
9535           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9536           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9537         else
9538           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9539           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9540         endif
9541         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9542         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9543 cd          write (2,*) 'turn6 derivatives'
9544 #ifdef MOMENT
9545           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9546 #else
9547           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9548 #endif
9549         else
9550 #ifdef MOMENT
9551           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9552 #else
9553           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9554 #endif
9555         endif
9556       endif
9557 C Derivatives in gamma(k-1)
9558 #ifdef MOMENT
9559       if (imat.eq.1) then
9560         s1=dip(3,jj,i)*dipderg(2,kk,k)
9561       else
9562         s1=dip(2,jj,j)*dipderg(4,kk,l)
9563       endif
9564 #endif
9565       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9566       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9567       if (j.eq.l+1) then
9568         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9569         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9570       else
9571         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9572         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9573       endif
9574       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9575       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9576       vv(1)=pizda(1,1)-pizda(2,2)
9577       vv(2)=pizda(2,1)+pizda(1,2)
9578       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9579       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9580 #ifdef MOMENT
9581         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9582 #else
9583         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9584 #endif
9585       else
9586 #ifdef MOMENT
9587         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9588 #else
9589         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9590 #endif
9591       endif
9592 C Derivatives in gamma(j-1) or gamma(l-1)
9593       if (l.eq.j+1 .and. l.gt.1) then
9594         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9595         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9596         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9597         vv(1)=pizda(1,1)-pizda(2,2)
9598         vv(2)=pizda(2,1)+pizda(1,2)
9599         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9600         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9601       else if (j.gt.1) then
9602         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9603         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9604         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9605         vv(1)=pizda(1,1)-pizda(2,2)
9606         vv(2)=pizda(2,1)+pizda(1,2)
9607         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9608         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9609           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9610         else
9611           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9612         endif
9613       endif
9614 C Cartesian derivatives.
9615       do iii=1,2
9616         do kkk=1,5
9617           do lll=1,3
9618 #ifdef MOMENT
9619             if (iii.eq.1) then
9620               if (imat.eq.1) then
9621                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9622               else
9623                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9624               endif
9625             else
9626               if (imat.eq.1) then
9627                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9628               else
9629                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9630               endif
9631             endif
9632 #endif
9633             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9634      &        auxvec(1))
9635             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9636             if (j.eq.l+1) then
9637               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9638      &          b1(1,j+1),auxvec(1))
9639               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9640             else
9641               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9642      &          b1(1,l+1),auxvec(1))
9643               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9644             endif
9645             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9646      &        pizda(1,1))
9647             vv(1)=pizda(1,1)-pizda(2,2)
9648             vv(2)=pizda(2,1)+pizda(1,2)
9649             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9650             if (swap) then
9651               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9652 #ifdef MOMENT
9653                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9654      &             -(s1+s2+s4)
9655 #else
9656                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9657      &             -(s2+s4)
9658 #endif
9659                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9660               else
9661 #ifdef MOMENT
9662                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9663 #else
9664                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9665 #endif
9666                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9667               endif
9668             else
9669 #ifdef MOMENT
9670               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9671 #else
9672               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9673 #endif
9674               if (l.eq.j+1) then
9675                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9676               else
9677                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9678               endif
9679             endif
9680           enddo
9681         enddo
9682       enddo
9683       return
9684       end
9685 c----------------------------------------------------------------------------
9686       double precision function eello_turn6(i,jj,kk)
9687       implicit real*8 (a-h,o-z)
9688       include 'DIMENSIONS'
9689       include 'COMMON.IOUNITS'
9690       include 'COMMON.CHAIN'
9691       include 'COMMON.DERIV'
9692       include 'COMMON.INTERACT'
9693       include 'COMMON.CONTACTS'
9694       include 'COMMON.TORSION'
9695       include 'COMMON.VAR'
9696       include 'COMMON.GEO'
9697       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9698      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9699      &  ggg1(3),ggg2(3)
9700       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9701      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9702 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9703 C           the respective energy moment and not to the cluster cumulant.
9704       s1=0.0d0
9705       s8=0.0d0
9706       s13=0.0d0
9707 c
9708       eello_turn6=0.0d0
9709       j=i+4
9710       k=i+1
9711       l=i+3
9712       iti=itortyp(itype(i))
9713       itk=itortyp(itype(k))
9714       itk1=itortyp(itype(k+1))
9715       itl=itortyp(itype(l))
9716       itj=itortyp(itype(j))
9717 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9718 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9719 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9720 cd        eello6=0.0d0
9721 cd        return
9722 cd      endif
9723 cd      write (iout,*)
9724 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9725 cd     &   ' and',k,l
9726 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9727       do iii=1,2
9728         do kkk=1,5
9729           do lll=1,3
9730             derx_turn(lll,kkk,iii)=0.0d0
9731           enddo
9732         enddo
9733       enddo
9734 cd      eij=1.0d0
9735 cd      ekl=1.0d0
9736 cd      ekont=1.0d0
9737       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9738 cd      eello6_5=0.0d0
9739 cd      write (2,*) 'eello6_5',eello6_5
9740 #ifdef MOMENT
9741       call transpose2(AEA(1,1,1),auxmat(1,1))
9742       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9743       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9744       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9745 #endif
9746       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9747       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9748       s2 = scalar2(b1(1,k),vtemp1(1))
9749 #ifdef MOMENT
9750       call transpose2(AEA(1,1,2),atemp(1,1))
9751       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9752       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9753       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9754 #endif
9755       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9756       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9757       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9758 #ifdef MOMENT
9759       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9760       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9761       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9762       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9763       ss13 = scalar2(b1(1,k),vtemp4(1))
9764       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9765 #endif
9766 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9767 c      s1=0.0d0
9768 c      s2=0.0d0
9769 c      s8=0.0d0
9770 c      s12=0.0d0
9771 c      s13=0.0d0
9772       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9773 C Derivatives in gamma(i+2)
9774       s1d =0.0d0
9775       s8d =0.0d0
9776 #ifdef MOMENT
9777       call transpose2(AEA(1,1,1),auxmatd(1,1))
9778       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9779       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9780       call transpose2(AEAderg(1,1,2),atempd(1,1))
9781       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9782       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9783 #endif
9784       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9785       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9786       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9787 c      s1d=0.0d0
9788 c      s2d=0.0d0
9789 c      s8d=0.0d0
9790 c      s12d=0.0d0
9791 c      s13d=0.0d0
9792       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9793 C Derivatives in gamma(i+3)
9794 #ifdef MOMENT
9795       call transpose2(AEA(1,1,1),auxmatd(1,1))
9796       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9797       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9798       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9799 #endif
9800       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9801       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9802       s2d = scalar2(b1(1,k),vtemp1d(1))
9803 #ifdef MOMENT
9804       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9805       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9806 #endif
9807       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9808 #ifdef MOMENT
9809       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9810       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9811       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9812 #endif
9813 c      s1d=0.0d0
9814 c      s2d=0.0d0
9815 c      s8d=0.0d0
9816 c      s12d=0.0d0
9817 c      s13d=0.0d0
9818 #ifdef MOMENT
9819       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9820      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9821 #else
9822       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9823      &               -0.5d0*ekont*(s2d+s12d)
9824 #endif
9825 C Derivatives in gamma(i+4)
9826       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9827       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9828       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9829 #ifdef MOMENT
9830       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9831       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9832       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9833 #endif
9834 c      s1d=0.0d0
9835 c      s2d=0.0d0
9836 c      s8d=0.0d0
9837 C      s12d=0.0d0
9838 c      s13d=0.0d0
9839 #ifdef MOMENT
9840       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9841 #else
9842       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9843 #endif
9844 C Derivatives in gamma(i+5)
9845 #ifdef MOMENT
9846       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9847       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9848       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9849 #endif
9850       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9851       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9852       s2d = scalar2(b1(1,k),vtemp1d(1))
9853 #ifdef MOMENT
9854       call transpose2(AEA(1,1,2),atempd(1,1))
9855       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9856       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9857 #endif
9858       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9859       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9860 #ifdef MOMENT
9861       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9862       ss13d = scalar2(b1(1,k),vtemp4d(1))
9863       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9864 #endif
9865 c      s1d=0.0d0
9866 c      s2d=0.0d0
9867 c      s8d=0.0d0
9868 c      s12d=0.0d0
9869 c      s13d=0.0d0
9870 #ifdef MOMENT
9871       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9872      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9873 #else
9874       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9875      &               -0.5d0*ekont*(s2d+s12d)
9876 #endif
9877 C Cartesian derivatives
9878       do iii=1,2
9879         do kkk=1,5
9880           do lll=1,3
9881 #ifdef MOMENT
9882             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9883             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9884             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9885 #endif
9886             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9887             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9888      &          vtemp1d(1))
9889             s2d = scalar2(b1(1,k),vtemp1d(1))
9890 #ifdef MOMENT
9891             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9892             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9893             s8d = -(atempd(1,1)+atempd(2,2))*
9894      &           scalar2(cc(1,1,itl),vtemp2(1))
9895 #endif
9896             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9897      &           auxmatd(1,1))
9898             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9899             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9900 c      s1d=0.0d0
9901 c      s2d=0.0d0
9902 c      s8d=0.0d0
9903 c      s12d=0.0d0
9904 c      s13d=0.0d0
9905 #ifdef MOMENT
9906             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9907      &        - 0.5d0*(s1d+s2d)
9908 #else
9909             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9910      &        - 0.5d0*s2d
9911 #endif
9912 #ifdef MOMENT
9913             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9914      &        - 0.5d0*(s8d+s12d)
9915 #else
9916             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9917      &        - 0.5d0*s12d
9918 #endif
9919           enddo
9920         enddo
9921       enddo
9922 #ifdef MOMENT
9923       do kkk=1,5
9924         do lll=1,3
9925           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9926      &      achuj_tempd(1,1))
9927           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9928           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9929           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9930           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9931           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9932      &      vtemp4d(1))
9933           ss13d = scalar2(b1(1,k),vtemp4d(1))
9934           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9935           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9936         enddo
9937       enddo
9938 #endif
9939 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9940 cd     &  16*eel_turn6_num
9941 cd      goto 1112
9942       if (j.lt.nres-1) then
9943         j1=j+1
9944         j2=j-1
9945       else
9946         j1=j-1
9947         j2=j-2
9948       endif
9949       if (l.lt.nres-1) then
9950         l1=l+1
9951         l2=l-1
9952       else
9953         l1=l-1
9954         l2=l-2
9955       endif
9956       do ll=1,3
9957 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9958 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9959 cgrad        ghalf=0.5d0*ggg1(ll)
9960 cd        ghalf=0.0d0
9961         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9962         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9963         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9964      &    +ekont*derx_turn(ll,2,1)
9965         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9966         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9967      &    +ekont*derx_turn(ll,4,1)
9968         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9969         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9970         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9971 cgrad        ghalf=0.5d0*ggg2(ll)
9972 cd        ghalf=0.0d0
9973         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9974      &    +ekont*derx_turn(ll,2,2)
9975         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9976         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9977      &    +ekont*derx_turn(ll,4,2)
9978         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9979         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9980         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9981       enddo
9982 cd      goto 1112
9983 cgrad      do m=i+1,j-1
9984 cgrad        do ll=1,3
9985 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9986 cgrad        enddo
9987 cgrad      enddo
9988 cgrad      do m=k+1,l-1
9989 cgrad        do ll=1,3
9990 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9991 cgrad        enddo
9992 cgrad      enddo
9993 cgrad1112  continue
9994 cgrad      do m=i+2,j2
9995 cgrad        do ll=1,3
9996 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9997 cgrad        enddo
9998 cgrad      enddo
9999 cgrad      do m=k+2,l2
10000 cgrad        do ll=1,3
10001 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10002 cgrad        enddo
10003 cgrad      enddo
10004 cd      do iii=1,nres-3
10005 cd        write (2,*) iii,g_corr6_loc(iii)
10006 cd      enddo
10007       eello_turn6=ekont*eel_turn6
10008 cd      write (2,*) 'ekont',ekont
10009 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10010       return
10011       end
10012
10013 C-----------------------------------------------------------------------------
10014       double precision function scalar(u,v)
10015 !DIR$ INLINEALWAYS scalar
10016 #ifndef OSF
10017 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10018 #endif
10019       implicit none
10020       double precision u(3),v(3)
10021 cd      double precision sc
10022 cd      integer i
10023 cd      sc=0.0d0
10024 cd      do i=1,3
10025 cd        sc=sc+u(i)*v(i)
10026 cd      enddo
10027 cd      scalar=sc
10028
10029       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10030       return
10031       end
10032 crc-------------------------------------------------
10033       SUBROUTINE MATVEC2(A1,V1,V2)
10034 !DIR$ INLINEALWAYS MATVEC2
10035 #ifndef OSF
10036 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10037 #endif
10038       implicit real*8 (a-h,o-z)
10039       include 'DIMENSIONS'
10040       DIMENSION A1(2,2),V1(2),V2(2)
10041 c      DO 1 I=1,2
10042 c        VI=0.0
10043 c        DO 3 K=1,2
10044 c    3     VI=VI+A1(I,K)*V1(K)
10045 c        Vaux(I)=VI
10046 c    1 CONTINUE
10047
10048       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10049       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10050
10051       v2(1)=vaux1
10052       v2(2)=vaux2
10053       END
10054 C---------------------------------------
10055       SUBROUTINE MATMAT2(A1,A2,A3)
10056 #ifndef OSF
10057 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10058 #endif
10059       implicit real*8 (a-h,o-z)
10060       include 'DIMENSIONS'
10061       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10062 c      DIMENSION AI3(2,2)
10063 c        DO  J=1,2
10064 c          A3IJ=0.0
10065 c          DO K=1,2
10066 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10067 c          enddo
10068 c          A3(I,J)=A3IJ
10069 c       enddo
10070 c      enddo
10071
10072       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10073       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10074       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10075       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10076
10077       A3(1,1)=AI3_11
10078       A3(2,1)=AI3_21
10079       A3(1,2)=AI3_12
10080       A3(2,2)=AI3_22
10081       END
10082
10083 c-------------------------------------------------------------------------
10084       double precision function scalar2(u,v)
10085 !DIR$ INLINEALWAYS scalar2
10086       implicit none
10087       double precision u(2),v(2)
10088       double precision sc
10089       integer i
10090       scalar2=u(1)*v(1)+u(2)*v(2)
10091       return
10092       end
10093
10094 C-----------------------------------------------------------------------------
10095
10096       subroutine transpose2(a,at)
10097 !DIR$ INLINEALWAYS transpose2
10098 #ifndef OSF
10099 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10100 #endif
10101       implicit none
10102       double precision a(2,2),at(2,2)
10103       at(1,1)=a(1,1)
10104       at(1,2)=a(2,1)
10105       at(2,1)=a(1,2)
10106       at(2,2)=a(2,2)
10107       return
10108       end
10109 c--------------------------------------------------------------------------
10110       subroutine transpose(n,a,at)
10111       implicit none
10112       integer n,i,j
10113       double precision a(n,n),at(n,n)
10114       do i=1,n
10115         do j=1,n
10116           at(j,i)=a(i,j)
10117         enddo
10118       enddo
10119       return
10120       end
10121 C---------------------------------------------------------------------------
10122       subroutine prodmat3(a1,a2,kk,transp,prod)
10123 !DIR$ INLINEALWAYS prodmat3
10124 #ifndef OSF
10125 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10126 #endif
10127       implicit none
10128       integer i,j
10129       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10130       logical transp
10131 crc      double precision auxmat(2,2),prod_(2,2)
10132
10133       if (transp) then
10134 crc        call transpose2(kk(1,1),auxmat(1,1))
10135 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10136 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10137
10138            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10139      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10140            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10141      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10142            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10143      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10144            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10145      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10146
10147       else
10148 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10149 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10150
10151            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10152      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10153            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10154      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10155            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10156      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10157            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10158      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10159
10160       endif
10161 c      call transpose2(a2(1,1),a2t(1,1))
10162
10163 crc      print *,transp
10164 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10165 crc      print *,((prod(i,j),i=1,2),j=1,2)
10166
10167       return
10168       end
10169 CCC----------------------------------------------
10170       subroutine Eliptransfer(eliptran)
10171       implicit real*8 (a-h,o-z)
10172       include 'DIMENSIONS'
10173       include 'COMMON.GEO'
10174       include 'COMMON.VAR'
10175       include 'COMMON.LOCAL'
10176       include 'COMMON.CHAIN'
10177       include 'COMMON.DERIV'
10178       include 'COMMON.NAMES'
10179       include 'COMMON.INTERACT'
10180       include 'COMMON.IOUNITS'
10181       include 'COMMON.CALC'
10182       include 'COMMON.CONTROL'
10183       include 'COMMON.SPLITELE'
10184       include 'COMMON.SBRIDGE'
10185 C this is done by Adasko
10186 C      print *,"wchodze"
10187 C structure of box:
10188 C      water
10189 C--bordliptop-- buffore starts
10190 C--bufliptop--- here true lipid starts
10191 C      lipid
10192 C--buflipbot--- lipid ends buffore starts
10193 C--bordlipbot--buffore ends
10194       eliptran=0.0
10195       do i=ilip_start,ilip_end
10196 C       do i=1,1
10197         if (itype(i).eq.ntyp1) cycle
10198
10199         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10200         if (positi.le.0) positi=positi+boxzsize
10201 C        print *,i
10202 C first for peptide groups
10203 c for each residue check if it is in lipid or lipid water border area
10204        if ((positi.gt.bordlipbot)
10205      &.and.(positi.lt.bordliptop)) then
10206 C the energy transfer exist
10207         if (positi.lt.buflipbot) then
10208 C what fraction I am in
10209          fracinbuf=1.0d0-
10210      &        ((positi-bordlipbot)/lipbufthick)
10211 C lipbufthick is thickenes of lipid buffore
10212          sslip=sscalelip(fracinbuf)
10213          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10214          eliptran=eliptran+sslip*pepliptran
10215          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10216          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10217 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10218
10219 C        print *,"doing sccale for lower part"
10220 C         print *,i,sslip,fracinbuf,ssgradlip
10221         elseif (positi.gt.bufliptop) then
10222          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10223          sslip=sscalelip(fracinbuf)
10224          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10225          eliptran=eliptran+sslip*pepliptran
10226          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10227          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10228 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10229 C          print *, "doing sscalefor top part"
10230 C         print *,i,sslip,fracinbuf,ssgradlip
10231         else
10232          eliptran=eliptran+pepliptran
10233 C         print *,"I am in true lipid"
10234         endif
10235 C       else
10236 C       eliptran=elpitran+0.0 ! I am in water
10237        endif
10238        enddo
10239 C       print *, "nic nie bylo w lipidzie?"
10240 C now multiply all by the peptide group transfer factor
10241 C       eliptran=eliptran*pepliptran
10242 C now the same for side chains
10243 CV       do i=1,1
10244        do i=ilip_start,ilip_end
10245         if (itype(i).eq.ntyp1) cycle
10246         positi=(mod(c(3,i+nres),boxzsize))
10247         if (positi.le.0) positi=positi+boxzsize
10248 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10249 c for each residue check if it is in lipid or lipid water border area
10250 C       respos=mod(c(3,i+nres),boxzsize)
10251 C       print *,positi,bordlipbot,buflipbot
10252        if ((positi.gt.bordlipbot)
10253      & .and.(positi.lt.bordliptop)) then
10254 C the energy transfer exist
10255         if (positi.lt.buflipbot) then
10256          fracinbuf=1.0d0-
10257      &     ((positi-bordlipbot)/lipbufthick)
10258 C lipbufthick is thickenes of lipid buffore
10259          sslip=sscalelip(fracinbuf)
10260          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10261          eliptran=eliptran+sslip*liptranene(itype(i))
10262          gliptranx(3,i)=gliptranx(3,i)
10263      &+ssgradlip*liptranene(itype(i))
10264          gliptranc(3,i-1)= gliptranc(3,i-1)
10265      &+ssgradlip*liptranene(itype(i))
10266 C         print *,"doing sccale for lower part"
10267         elseif (positi.gt.bufliptop) then
10268          fracinbuf=1.0d0-
10269      &((bordliptop-positi)/lipbufthick)
10270          sslip=sscalelip(fracinbuf)
10271          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10272          eliptran=eliptran+sslip*liptranene(itype(i))
10273          gliptranx(3,i)=gliptranx(3,i)
10274      &+ssgradlip*liptranene(itype(i))
10275          gliptranc(3,i-1)= gliptranc(3,i-1)
10276      &+ssgradlip*liptranene(itype(i))
10277 C          print *, "doing sscalefor top part",sslip,fracinbuf
10278         else
10279          eliptran=eliptran+liptranene(itype(i))
10280 C         print *,"I am in true lipid"
10281         endif
10282         endif ! if in lipid or buffor
10283 C       else
10284 C       eliptran=elpitran+0.0 ! I am in water
10285        enddo
10286        return
10287        end
10288 C---------------------------------------------------------
10289 C AFM soubroutine for constant force
10290        subroutine AFMforce(Eafmforce)
10291        implicit real*8 (a-h,o-z)
10292       include 'DIMENSIONS'
10293       include 'COMMON.GEO'
10294       include 'COMMON.VAR'
10295       include 'COMMON.LOCAL'
10296       include 'COMMON.CHAIN'
10297       include 'COMMON.DERIV'
10298       include 'COMMON.NAMES'
10299       include 'COMMON.INTERACT'
10300       include 'COMMON.IOUNITS'
10301       include 'COMMON.CALC'
10302       include 'COMMON.CONTROL'
10303       include 'COMMON.SPLITELE'
10304       include 'COMMON.SBRIDGE'
10305       real*8 diffafm(3)
10306       dist=0.0d0
10307       Eafmforce=0.0d0
10308       do i=1,3
10309       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10310       dist=dist+diffafm(i)**2
10311       enddo
10312       dist=dsqrt(dist)
10313       Eafmforce=-forceAFMconst*(dist-distafminit)
10314       do i=1,3
10315       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10316       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10317       enddo
10318 C      print *,'AFM',Eafmforce
10319       return
10320       end
10321 C---------------------------------------------------------
10322 C AFM subroutine with pseudoconstant velocity
10323        subroutine AFMvel(Eafmforce)
10324        implicit real*8 (a-h,o-z)
10325       include 'DIMENSIONS'
10326       include 'COMMON.GEO'
10327       include 'COMMON.VAR'
10328       include 'COMMON.LOCAL'
10329       include 'COMMON.CHAIN'
10330       include 'COMMON.DERIV'
10331       include 'COMMON.NAMES'
10332       include 'COMMON.INTERACT'
10333       include 'COMMON.IOUNITS'
10334       include 'COMMON.CALC'
10335       include 'COMMON.CONTROL'
10336       include 'COMMON.SPLITELE'
10337       include 'COMMON.SBRIDGE'
10338       real*8 diffafm(3)
10339 C Only for check grad COMMENT if not used for checkgrad
10340 C      totT=3.0d0
10341 C--------------------------------------------------------
10342 C      print *,"wchodze"
10343       dist=0.0d0
10344       Eafmforce=0.0d0
10345       do i=1,3
10346       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10347       dist=dist+diffafm(i)**2
10348       enddo
10349       dist=dsqrt(dist)
10350       Eafmforce=0.5d0*forceAFMconst
10351      & *(distafminit+totTafm*velAFMconst-dist)**2
10352 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10353       do i=1,3
10354       gradafm(i,afmend-1)=-forceAFMconst*
10355      &(distafminit+totTafm*velAFMconst-dist)
10356      &*diffafm(i)/dist
10357       gradafm(i,afmbeg-1)=forceAFMconst*
10358      &(distafminit+totTafm*velAFMconst-dist)
10359      &*diffafm(i)/dist
10360       enddo
10361 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10362       return
10363       end
10364