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 (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5826         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5827         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5828       enddo
5829       return
5830       end
5831 #endif
5832 #ifdef CRYST_SC
5833 c-----------------------------------------------------------------------------
5834       subroutine esc(escloc)
5835 C Calculate the local energy of a side chain and its derivatives in the
5836 C corresponding virtual-bond valence angles THETA and the spherical angles
5837 C ALPHA and OMEGA.
5838       implicit real*8 (a-h,o-z)
5839       include 'DIMENSIONS'
5840       include 'COMMON.GEO'
5841       include 'COMMON.LOCAL'
5842       include 'COMMON.VAR'
5843       include 'COMMON.INTERACT'
5844       include 'COMMON.DERIV'
5845       include 'COMMON.CHAIN'
5846       include 'COMMON.IOUNITS'
5847       include 'COMMON.NAMES'
5848       include 'COMMON.FFIELD'
5849       include 'COMMON.CONTROL'
5850       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5851      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5852       common /sccalc/ time11,time12,time112,theti,it,nlobit
5853       delta=0.02d0*pi
5854       escloc=0.0D0
5855 c     write (iout,'(a)') 'ESC'
5856       do i=loc_start,loc_end
5857         it=itype(i)
5858         if (it.eq.ntyp1) cycle
5859         if (it.eq.10) goto 1
5860         nlobit=nlob(iabs(it))
5861 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5862 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5863         theti=theta(i+1)-pipol
5864         x(1)=dtan(theti)
5865         x(2)=alph(i)
5866         x(3)=omeg(i)
5867
5868         if (x(2).gt.pi-delta) then
5869           xtemp(1)=x(1)
5870           xtemp(2)=pi-delta
5871           xtemp(3)=x(3)
5872           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5873           xtemp(2)=pi
5874           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5875           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5876      &        escloci,dersc(2))
5877           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5878      &        ddersc0(1),dersc(1))
5879           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5880      &        ddersc0(3),dersc(3))
5881           xtemp(2)=pi-delta
5882           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5883           xtemp(2)=pi
5884           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5885           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5886      &            dersc0(2),esclocbi,dersc02)
5887           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5888      &            dersc12,dersc01)
5889           call splinthet(x(2),0.5d0*delta,ss,ssd)
5890           dersc0(1)=dersc01
5891           dersc0(2)=dersc02
5892           dersc0(3)=0.0d0
5893           do k=1,3
5894             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5895           enddo
5896           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5897 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5898 c    &             esclocbi,ss,ssd
5899           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5900 c         escloci=esclocbi
5901 c         write (iout,*) escloci
5902         else if (x(2).lt.delta) then
5903           xtemp(1)=x(1)
5904           xtemp(2)=delta
5905           xtemp(3)=x(3)
5906           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5907           xtemp(2)=0.0d0
5908           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5909           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5910      &        escloci,dersc(2))
5911           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5912      &        ddersc0(1),dersc(1))
5913           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5914      &        ddersc0(3),dersc(3))
5915           xtemp(2)=delta
5916           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5917           xtemp(2)=0.0d0
5918           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5919           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5920      &            dersc0(2),esclocbi,dersc02)
5921           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5922      &            dersc12,dersc01)
5923           dersc0(1)=dersc01
5924           dersc0(2)=dersc02
5925           dersc0(3)=0.0d0
5926           call splinthet(x(2),0.5d0*delta,ss,ssd)
5927           do k=1,3
5928             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5929           enddo
5930           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5931 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5932 c    &             esclocbi,ss,ssd
5933           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5934 c         write (iout,*) escloci
5935         else
5936           call enesc(x,escloci,dersc,ddummy,.false.)
5937         endif
5938
5939         escloc=escloc+escloci
5940         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5941      &     'escloc',i,escloci
5942 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5943
5944         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5945      &   wscloc*dersc(1)
5946         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5947         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5948     1   continue
5949       enddo
5950       return
5951       end
5952 C---------------------------------------------------------------------------
5953       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5954       implicit real*8 (a-h,o-z)
5955       include 'DIMENSIONS'
5956       include 'COMMON.GEO'
5957       include 'COMMON.LOCAL'
5958       include 'COMMON.IOUNITS'
5959       common /sccalc/ time11,time12,time112,theti,it,nlobit
5960       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5961       double precision contr(maxlob,-1:1)
5962       logical mixed
5963 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5964         escloc_i=0.0D0
5965         do j=1,3
5966           dersc(j)=0.0D0
5967           if (mixed) ddersc(j)=0.0d0
5968         enddo
5969         x3=x(3)
5970
5971 C Because of periodicity of the dependence of the SC energy in omega we have
5972 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5973 C To avoid underflows, first compute & store the exponents.
5974
5975         do iii=-1,1
5976
5977           x(3)=x3+iii*dwapi
5978
5979           do j=1,nlobit
5980             do k=1,3
5981               z(k)=x(k)-censc(k,j,it)
5982             enddo
5983             do k=1,3
5984               Axk=0.0D0
5985               do l=1,3
5986                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5987               enddo
5988               Ax(k,j,iii)=Axk
5989             enddo
5990             expfac=0.0D0
5991             do k=1,3
5992               expfac=expfac+Ax(k,j,iii)*z(k)
5993             enddo
5994             contr(j,iii)=expfac
5995           enddo ! j
5996
5997         enddo ! iii
5998
5999         x(3)=x3
6000 C As in the case of ebend, we want to avoid underflows in exponentiation and
6001 C subsequent NaNs and INFs in energy calculation.
6002 C Find the largest exponent
6003         emin=contr(1,-1)
6004         do iii=-1,1
6005           do j=1,nlobit
6006             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6007           enddo
6008         enddo
6009         emin=0.5D0*emin
6010 cd      print *,'it=',it,' emin=',emin
6011
6012 C Compute the contribution to SC energy and derivatives
6013         do iii=-1,1
6014
6015           do j=1,nlobit
6016 #ifdef OSF
6017             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6018             if(adexp.ne.adexp) adexp=1.0
6019             expfac=dexp(adexp)
6020 #else
6021             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6022 #endif
6023 cd          print *,'j=',j,' expfac=',expfac
6024             escloc_i=escloc_i+expfac
6025             do k=1,3
6026               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6027             enddo
6028             if (mixed) then
6029               do k=1,3,2
6030                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6031      &            +gaussc(k,2,j,it))*expfac
6032               enddo
6033             endif
6034           enddo
6035
6036         enddo ! iii
6037
6038         dersc(1)=dersc(1)/cos(theti)**2
6039         ddersc(1)=ddersc(1)/cos(theti)**2
6040         ddersc(3)=ddersc(3)
6041
6042         escloci=-(dlog(escloc_i)-emin)
6043         do j=1,3
6044           dersc(j)=dersc(j)/escloc_i
6045         enddo
6046         if (mixed) then
6047           do j=1,3,2
6048             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6049           enddo
6050         endif
6051       return
6052       end
6053 C------------------------------------------------------------------------------
6054       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6055       implicit real*8 (a-h,o-z)
6056       include 'DIMENSIONS'
6057       include 'COMMON.GEO'
6058       include 'COMMON.LOCAL'
6059       include 'COMMON.IOUNITS'
6060       common /sccalc/ time11,time12,time112,theti,it,nlobit
6061       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6062       double precision contr(maxlob)
6063       logical mixed
6064
6065       escloc_i=0.0D0
6066
6067       do j=1,3
6068         dersc(j)=0.0D0
6069       enddo
6070
6071       do j=1,nlobit
6072         do k=1,2
6073           z(k)=x(k)-censc(k,j,it)
6074         enddo
6075         z(3)=dwapi
6076         do k=1,3
6077           Axk=0.0D0
6078           do l=1,3
6079             Axk=Axk+gaussc(l,k,j,it)*z(l)
6080           enddo
6081           Ax(k,j)=Axk
6082         enddo
6083         expfac=0.0D0
6084         do k=1,3
6085           expfac=expfac+Ax(k,j)*z(k)
6086         enddo
6087         contr(j)=expfac
6088       enddo ! j
6089
6090 C As in the case of ebend, we want to avoid underflows in exponentiation and
6091 C subsequent NaNs and INFs in energy calculation.
6092 C Find the largest exponent
6093       emin=contr(1)
6094       do j=1,nlobit
6095         if (emin.gt.contr(j)) emin=contr(j)
6096       enddo
6097       emin=0.5D0*emin
6098
6099 C Compute the contribution to SC energy and derivatives
6100
6101       dersc12=0.0d0
6102       do j=1,nlobit
6103         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6104         escloc_i=escloc_i+expfac
6105         do k=1,2
6106           dersc(k)=dersc(k)+Ax(k,j)*expfac
6107         enddo
6108         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6109      &            +gaussc(1,2,j,it))*expfac
6110         dersc(3)=0.0d0
6111       enddo
6112
6113       dersc(1)=dersc(1)/cos(theti)**2
6114       dersc12=dersc12/cos(theti)**2
6115       escloci=-(dlog(escloc_i)-emin)
6116       do j=1,2
6117         dersc(j)=dersc(j)/escloc_i
6118       enddo
6119       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6120       return
6121       end
6122 #else
6123 c----------------------------------------------------------------------------------
6124       subroutine esc(escloc)
6125 C Calculate the local energy of a side chain and its derivatives in the
6126 C corresponding virtual-bond valence angles THETA and the spherical angles
6127 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6128 C added by Urszula Kozlowska. 07/11/2007
6129 C
6130       implicit real*8 (a-h,o-z)
6131       include 'DIMENSIONS'
6132       include 'COMMON.GEO'
6133       include 'COMMON.LOCAL'
6134       include 'COMMON.VAR'
6135       include 'COMMON.SCROT'
6136       include 'COMMON.INTERACT'
6137       include 'COMMON.DERIV'
6138       include 'COMMON.CHAIN'
6139       include 'COMMON.IOUNITS'
6140       include 'COMMON.NAMES'
6141       include 'COMMON.FFIELD'
6142       include 'COMMON.CONTROL'
6143       include 'COMMON.VECTORS'
6144       double precision x_prime(3),y_prime(3),z_prime(3)
6145      &    , sumene,dsc_i,dp2_i,x(65),
6146      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6147      &    de_dxx,de_dyy,de_dzz,de_dt
6148       double precision s1_t,s1_6_t,s2_t,s2_6_t
6149       double precision
6150      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6151      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6152      & dt_dCi(3),dt_dCi1(3)
6153       common /sccalc/ time11,time12,time112,theti,it,nlobit
6154       delta=0.02d0*pi
6155       escloc=0.0D0
6156       do i=loc_start,loc_end
6157         if (itype(i).eq.ntyp1) cycle
6158         costtab(i+1) =dcos(theta(i+1))
6159         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6160         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6161         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6162         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6163         cosfac=dsqrt(cosfac2)
6164         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6165         sinfac=dsqrt(sinfac2)
6166         it=iabs(itype(i))
6167         if (it.eq.10) goto 1
6168 c
6169 C  Compute the axes of tghe local cartesian coordinates system; store in
6170 c   x_prime, y_prime and z_prime
6171 c
6172         do j=1,3
6173           x_prime(j) = 0.00
6174           y_prime(j) = 0.00
6175           z_prime(j) = 0.00
6176         enddo
6177 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6178 C     &   dc_norm(3,i+nres)
6179         do j = 1,3
6180           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6181           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6182         enddo
6183         do j = 1,3
6184           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6185         enddo
6186 c       write (2,*) "i",i
6187 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6188 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6189 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6190 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6191 c      & " xy",scalar(x_prime(1),y_prime(1)),
6192 c      & " xz",scalar(x_prime(1),z_prime(1)),
6193 c      & " yy",scalar(y_prime(1),y_prime(1)),
6194 c      & " yz",scalar(y_prime(1),z_prime(1)),
6195 c      & " zz",scalar(z_prime(1),z_prime(1))
6196 c
6197 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6198 C to local coordinate system. Store in xx, yy, zz.
6199 c
6200         xx=0.0d0
6201         yy=0.0d0
6202         zz=0.0d0
6203         do j = 1,3
6204           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6205           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6206           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6207         enddo
6208
6209         xxtab(i)=xx
6210         yytab(i)=yy
6211         zztab(i)=zz
6212 C
6213 C Compute the energy of the ith side cbain
6214 C
6215 c        write (2,*) "xx",xx," yy",yy," zz",zz
6216         it=iabs(itype(i))
6217         do j = 1,65
6218           x(j) = sc_parmin(j,it)
6219         enddo
6220 #ifdef CHECK_COORD
6221 Cc diagnostics - remove later
6222         xx1 = dcos(alph(2))
6223         yy1 = dsin(alph(2))*dcos(omeg(2))
6224         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6225         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6226      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6227      &    xx1,yy1,zz1
6228 C,"  --- ", xx_w,yy_w,zz_w
6229 c end diagnostics
6230 #endif
6231         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6232      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6233      &   + x(10)*yy*zz
6234         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6235      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6236      & + x(20)*yy*zz
6237         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6238      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6239      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6240      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6241      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6242      &  +x(40)*xx*yy*zz
6243         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6244      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6245      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6246      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6247      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6248      &  +x(60)*xx*yy*zz
6249         dsc_i   = 0.743d0+x(61)
6250         dp2_i   = 1.9d0+x(62)
6251         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6252      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6253         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6254      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6255         s1=(1+x(63))/(0.1d0 + dscp1)
6256         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6257         s2=(1+x(65))/(0.1d0 + dscp2)
6258         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6259         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6260      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6261 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6262 c     &   sumene4,
6263 c     &   dscp1,dscp2,sumene
6264 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6265         escloc = escloc + sumene
6266 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6267 c     & ,zz,xx,yy
6268 c#define DEBUG
6269 #ifdef DEBUG
6270 C
6271 C This section to check the numerical derivatives of the energy of ith side
6272 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6273 C #define DEBUG in the code to turn it on.
6274 C
6275         write (2,*) "sumene               =",sumene
6276         aincr=1.0d-7
6277         xxsave=xx
6278         xx=xx+aincr
6279         write (2,*) xx,yy,zz
6280         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6281         de_dxx_num=(sumenep-sumene)/aincr
6282         xx=xxsave
6283         write (2,*) "xx+ sumene from enesc=",sumenep
6284         yysave=yy
6285         yy=yy+aincr
6286         write (2,*) xx,yy,zz
6287         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6288         de_dyy_num=(sumenep-sumene)/aincr
6289         yy=yysave
6290         write (2,*) "yy+ sumene from enesc=",sumenep
6291         zzsave=zz
6292         zz=zz+aincr
6293         write (2,*) xx,yy,zz
6294         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6295         de_dzz_num=(sumenep-sumene)/aincr
6296         zz=zzsave
6297         write (2,*) "zz+ sumene from enesc=",sumenep
6298         costsave=cost2tab(i+1)
6299         sintsave=sint2tab(i+1)
6300         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6301         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6302         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6303         de_dt_num=(sumenep-sumene)/aincr
6304         write (2,*) " t+ sumene from enesc=",sumenep
6305         cost2tab(i+1)=costsave
6306         sint2tab(i+1)=sintsave
6307 C End of diagnostics section.
6308 #endif
6309 C
6310 C Compute the gradient of esc
6311 C
6312 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6313         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6314         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6315         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6316         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6317         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6318         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6319         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6320         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6321         pom1=(sumene3*sint2tab(i+1)+sumene1)
6322      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6323         pom2=(sumene4*cost2tab(i+1)+sumene2)
6324      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6325         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6326         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6327      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6328      &  +x(40)*yy*zz
6329         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6330         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6331      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6332      &  +x(60)*yy*zz
6333         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6334      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6335      &        +(pom1+pom2)*pom_dx
6336 #ifdef DEBUG
6337         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6338 #endif
6339 C
6340         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6341         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6342      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6343      &  +x(40)*xx*zz
6344         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6345         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6346      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6347      &  +x(59)*zz**2 +x(60)*xx*zz
6348         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6349      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6350      &        +(pom1-pom2)*pom_dy
6351 #ifdef DEBUG
6352         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6353 #endif
6354 C
6355         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6356      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6357      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6358      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6359      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6360      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6361      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6362      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6363 #ifdef DEBUG
6364         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6365 #endif
6366 C
6367         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6368      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6369      &  +pom1*pom_dt1+pom2*pom_dt2
6370 #ifdef DEBUG
6371         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6372 #endif
6373 c#undef DEBUG
6374 c
6375 C
6376        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6377        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6378        cosfac2xx=cosfac2*xx
6379        sinfac2yy=sinfac2*yy
6380        do k = 1,3
6381          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6382      &      vbld_inv(i+1)
6383          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6384      &      vbld_inv(i)
6385          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6386          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6387 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6388 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6389 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6390 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6391          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6392          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6393          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6394          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6395          dZZ_Ci1(k)=0.0d0
6396          dZZ_Ci(k)=0.0d0
6397          do j=1,3
6398            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6399      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6400            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6401      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6402          enddo
6403
6404          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6405          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6406          dZZ_XYZ(k)=vbld_inv(i+nres)*
6407      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6408 c
6409          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6410          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6411        enddo
6412
6413        do k=1,3
6414          dXX_Ctab(k,i)=dXX_Ci(k)
6415          dXX_C1tab(k,i)=dXX_Ci1(k)
6416          dYY_Ctab(k,i)=dYY_Ci(k)
6417          dYY_C1tab(k,i)=dYY_Ci1(k)
6418          dZZ_Ctab(k,i)=dZZ_Ci(k)
6419          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6420          dXX_XYZtab(k,i)=dXX_XYZ(k)
6421          dYY_XYZtab(k,i)=dYY_XYZ(k)
6422          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6423        enddo
6424
6425        do k = 1,3
6426 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6427 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6428 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6429 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6430 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6431 c     &    dt_dci(k)
6432 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6433 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6434          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6435      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6436          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6437      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6438          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6439      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6440        enddo
6441 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6442 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6443
6444 C to check gradient call subroutine check_grad
6445
6446     1 continue
6447       enddo
6448       return
6449       end
6450 c------------------------------------------------------------------------------
6451       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6452       implicit none
6453       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6454      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6455       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6456      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6457      &   + x(10)*yy*zz
6458       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6459      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6460      & + x(20)*yy*zz
6461       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6462      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6463      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6464      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6465      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6466      &  +x(40)*xx*yy*zz
6467       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6468      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6469      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6470      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6471      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6472      &  +x(60)*xx*yy*zz
6473       dsc_i   = 0.743d0+x(61)
6474       dp2_i   = 1.9d0+x(62)
6475       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6476      &          *(xx*cost2+yy*sint2))
6477       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6478      &          *(xx*cost2-yy*sint2))
6479       s1=(1+x(63))/(0.1d0 + dscp1)
6480       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6481       s2=(1+x(65))/(0.1d0 + dscp2)
6482       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6483       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6484      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6485       enesc=sumene
6486       return
6487       end
6488 #endif
6489 c------------------------------------------------------------------------------
6490       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6491 C
6492 C This procedure calculates two-body contact function g(rij) and its derivative:
6493 C
6494 C           eps0ij                                     !       x < -1
6495 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6496 C            0                                         !       x > 1
6497 C
6498 C where x=(rij-r0ij)/delta
6499 C
6500 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6501 C
6502       implicit none
6503       double precision rij,r0ij,eps0ij,fcont,fprimcont
6504       double precision x,x2,x4,delta
6505 c     delta=0.02D0*r0ij
6506 c      delta=0.2D0*r0ij
6507       x=(rij-r0ij)/delta
6508       if (x.lt.-1.0D0) then
6509         fcont=eps0ij
6510         fprimcont=0.0D0
6511       else if (x.le.1.0D0) then
6512         x2=x*x
6513         x4=x2*x2
6514         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6515         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6516       else
6517         fcont=0.0D0
6518         fprimcont=0.0D0
6519       endif
6520       return
6521       end
6522 c------------------------------------------------------------------------------
6523       subroutine splinthet(theti,delta,ss,ssder)
6524       implicit real*8 (a-h,o-z)
6525       include 'DIMENSIONS'
6526       include 'COMMON.VAR'
6527       include 'COMMON.GEO'
6528       thetup=pi-delta
6529       thetlow=delta
6530       if (theti.gt.pipol) then
6531         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6532       else
6533         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6534         ssder=-ssder
6535       endif
6536       return
6537       end
6538 c------------------------------------------------------------------------------
6539       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6540       implicit none
6541       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6542       double precision ksi,ksi2,ksi3,a1,a2,a3
6543       a1=fprim0*delta/(f1-f0)
6544       a2=3.0d0-2.0d0*a1
6545       a3=a1-2.0d0
6546       ksi=(x-x0)/delta
6547       ksi2=ksi*ksi
6548       ksi3=ksi2*ksi
6549       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6550       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6551       return
6552       end
6553 c------------------------------------------------------------------------------
6554       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6555       implicit none
6556       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6557       double precision ksi,ksi2,ksi3,a1,a2,a3
6558       ksi=(x-x0)/delta
6559       ksi2=ksi*ksi
6560       ksi3=ksi2*ksi
6561       a1=fprim0x*delta
6562       a2=3*(f1x-f0x)-2*fprim0x*delta
6563       a3=fprim0x*delta-2*(f1x-f0x)
6564       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6565       return
6566       end
6567 C-----------------------------------------------------------------------------
6568 #ifdef CRYST_TOR
6569 C-----------------------------------------------------------------------------
6570       subroutine etor(etors,edihcnstr)
6571       implicit real*8 (a-h,o-z)
6572       include 'DIMENSIONS'
6573       include 'COMMON.VAR'
6574       include 'COMMON.GEO'
6575       include 'COMMON.LOCAL'
6576       include 'COMMON.TORSION'
6577       include 'COMMON.INTERACT'
6578       include 'COMMON.DERIV'
6579       include 'COMMON.CHAIN'
6580       include 'COMMON.NAMES'
6581       include 'COMMON.IOUNITS'
6582       include 'COMMON.FFIELD'
6583       include 'COMMON.TORCNSTR'
6584       include 'COMMON.CONTROL'
6585       logical lprn
6586 C Set lprn=.true. for debugging
6587       lprn=.false.
6588 c      lprn=.true.
6589       etors=0.0D0
6590       do i=iphi_start,iphi_end
6591       etors_ii=0.0D0
6592         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6593      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6594         itori=itortyp(itype(i-2))
6595         itori1=itortyp(itype(i-1))
6596         phii=phi(i)
6597         gloci=0.0D0
6598 C Proline-Proline pair is a special case...
6599         if (itori.eq.3 .and. itori1.eq.3) then
6600           if (phii.gt.-dwapi3) then
6601             cosphi=dcos(3*phii)
6602             fac=1.0D0/(1.0D0-cosphi)
6603             etorsi=v1(1,3,3)*fac
6604             etorsi=etorsi+etorsi
6605             etors=etors+etorsi-v1(1,3,3)
6606             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6607             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6608           endif
6609           do j=1,3
6610             v1ij=v1(j+1,itori,itori1)
6611             v2ij=v2(j+1,itori,itori1)
6612             cosphi=dcos(j*phii)
6613             sinphi=dsin(j*phii)
6614             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6615             if (energy_dec) etors_ii=etors_ii+
6616      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6617             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6618           enddo
6619         else
6620           do j=1,nterm_old
6621             v1ij=v1(j,itori,itori1)
6622             v2ij=v2(j,itori,itori1)
6623             cosphi=dcos(j*phii)
6624             sinphi=dsin(j*phii)
6625             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6626             if (energy_dec) etors_ii=etors_ii+
6627      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6628             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6629           enddo
6630         endif
6631         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6632              'etor',i,etors_ii
6633         if (lprn)
6634      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6635      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6636      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6637         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6638 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6639       enddo
6640 ! 6/20/98 - dihedral angle constraints
6641       edihcnstr=0.0d0
6642       do i=1,ndih_constr
6643         itori=idih_constr(i)
6644         phii=phi(itori)
6645         difi=phii-phi0(i)
6646         if (difi.gt.drange(i)) then
6647           difi=difi-drange(i)
6648           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6649           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6650         else if (difi.lt.-drange(i)) then
6651           difi=difi+drange(i)
6652           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6653           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6654         endif
6655 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6656 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6657       enddo
6658 !      write (iout,*) 'edihcnstr',edihcnstr
6659       return
6660       end
6661 c------------------------------------------------------------------------------
6662       subroutine etor_d(etors_d)
6663       etors_d=0.0d0
6664       return
6665       end
6666 c----------------------------------------------------------------------------
6667 #else
6668       subroutine etor(etors,edihcnstr)
6669       implicit real*8 (a-h,o-z)
6670       include 'DIMENSIONS'
6671       include 'COMMON.VAR'
6672       include 'COMMON.GEO'
6673       include 'COMMON.LOCAL'
6674       include 'COMMON.TORSION'
6675       include 'COMMON.INTERACT'
6676       include 'COMMON.DERIV'
6677       include 'COMMON.CHAIN'
6678       include 'COMMON.NAMES'
6679       include 'COMMON.IOUNITS'
6680       include 'COMMON.FFIELD'
6681       include 'COMMON.TORCNSTR'
6682       include 'COMMON.CONTROL'
6683       logical lprn
6684 C Set lprn=.true. for debugging
6685       lprn=.false.
6686 c     lprn=.true.
6687       etors=0.0D0
6688       do i=iphi_start,iphi_end
6689 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6690 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6691 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6692 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6693         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6694      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6695 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6696 C For introducing the NH3+ and COO- group please check the etor_d for reference
6697 C and guidance
6698         etors_ii=0.0D0
6699          if (iabs(itype(i)).eq.20) then
6700          iblock=2
6701          else
6702          iblock=1
6703          endif
6704         itori=itortyp(itype(i-2))
6705         itori1=itortyp(itype(i-1))
6706         phii=phi(i)
6707         gloci=0.0D0
6708 C Regular cosine and sine terms
6709         do j=1,nterm(itori,itori1,iblock)
6710           v1ij=v1(j,itori,itori1,iblock)
6711           v2ij=v2(j,itori,itori1,iblock)
6712           cosphi=dcos(j*phii)
6713           sinphi=dsin(j*phii)
6714           etors=etors+v1ij*cosphi+v2ij*sinphi
6715           if (energy_dec) etors_ii=etors_ii+
6716      &                v1ij*cosphi+v2ij*sinphi
6717           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6718         enddo
6719 C Lorentz terms
6720 C                         v1
6721 C  E = SUM ----------------------------------- - v1
6722 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6723 C
6724         cosphi=dcos(0.5d0*phii)
6725         sinphi=dsin(0.5d0*phii)
6726         do j=1,nlor(itori,itori1,iblock)
6727           vl1ij=vlor1(j,itori,itori1)
6728           vl2ij=vlor2(j,itori,itori1)
6729           vl3ij=vlor3(j,itori,itori1)
6730           pom=vl2ij*cosphi+vl3ij*sinphi
6731           pom1=1.0d0/(pom*pom+1.0d0)
6732           etors=etors+vl1ij*pom1
6733           if (energy_dec) etors_ii=etors_ii+
6734      &                vl1ij*pom1
6735           pom=-pom*pom1*pom1
6736           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6737         enddo
6738 C Subtract the constant term
6739         etors=etors-v0(itori,itori1,iblock)
6740           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6741      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6742         if (lprn)
6743      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6744      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6745      &  (v1(j,itori,itori1,iblock),j=1,6),
6746      &  (v2(j,itori,itori1,iblock),j=1,6)
6747         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6748 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6749       enddo
6750 ! 6/20/98 - dihedral angle constraints
6751       edihcnstr=0.0d0
6752 c      do i=1,ndih_constr
6753       do i=idihconstr_start,idihconstr_end
6754         itori=idih_constr(i)
6755         phii=phi(itori)
6756         difi=pinorm(phii-phi0(i))
6757         if (difi.gt.drange(i)) then
6758           difi=difi-drange(i)
6759           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6760           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6761         else if (difi.lt.-drange(i)) then
6762           difi=difi+drange(i)
6763           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6764           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6765         else
6766           difi=0.0
6767         endif
6768 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6769 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6770 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6771       enddo
6772 cd       write (iout,*) 'edihcnstr',edihcnstr
6773       return
6774       end
6775 c----------------------------------------------------------------------------
6776       subroutine etor_d(etors_d)
6777 C 6/23/01 Compute double torsional energy
6778       implicit real*8 (a-h,o-z)
6779       include 'DIMENSIONS'
6780       include 'COMMON.VAR'
6781       include 'COMMON.GEO'
6782       include 'COMMON.LOCAL'
6783       include 'COMMON.TORSION'
6784       include 'COMMON.INTERACT'
6785       include 'COMMON.DERIV'
6786       include 'COMMON.CHAIN'
6787       include 'COMMON.NAMES'
6788       include 'COMMON.IOUNITS'
6789       include 'COMMON.FFIELD'
6790       include 'COMMON.TORCNSTR'
6791       include 'COMMON.CONTROL'
6792       logical lprn
6793 C Set lprn=.true. for debugging
6794       lprn=.false.
6795 c     lprn=.true.
6796       etors_d=0.0D0
6797 c      write(iout,*) "a tu??"
6798       do i=iphid_start,iphid_end
6799 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6800 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6801 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6802 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6803 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6804          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6805      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6806      &  (itype(i+1).eq.ntyp1)) cycle
6807 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6808         etors_d_ii=0.0D0
6809         itori=itortyp(itype(i-2))
6810         itori1=itortyp(itype(i-1))
6811         itori2=itortyp(itype(i))
6812         phii=phi(i)
6813         phii1=phi(i+1)
6814         gloci1=0.0D0
6815         gloci2=0.0D0
6816         iblock=1
6817         if (iabs(itype(i+1)).eq.20) iblock=2
6818 C Iblock=2 Proline type
6819 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6820 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6821 C        if (itype(i+1).eq.ntyp1) iblock=3
6822 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6823 C IS or IS NOT need for this
6824 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6825 C        is (itype(i-3).eq.ntyp1) ntblock=2
6826 C        ntblock is N-terminal blocking group
6827
6828 C Regular cosine and sine terms
6829         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6830 C Example of changes for NH3+ blocking group
6831 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6832 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6833           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6834           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6835           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6836           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6837           cosphi1=dcos(j*phii)
6838           sinphi1=dsin(j*phii)
6839           cosphi2=dcos(j*phii1)
6840           sinphi2=dsin(j*phii1)
6841           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6842      &     v2cij*cosphi2+v2sij*sinphi2
6843           if (energy_dec) etors_d_ii=etors_d_ii+
6844      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6845           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6846           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6847         enddo
6848         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6849           do l=1,k-1
6850             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6851             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6852             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6853             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6854             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6855             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6856             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6857             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6858             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6859      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6860             if (energy_dec) etors_d_ii=etors_d_ii+
6861      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6862      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6863             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6864      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6865             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6866      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6867           enddo
6868         enddo
6869           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6870      &         'etor_d',i,etors_d_ii
6871         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6872         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6873       enddo
6874       return
6875       end
6876 #endif
6877 c------------------------------------------------------------------------------
6878       subroutine eback_sc_corr(esccor)
6879 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6880 c        conformational states; temporarily implemented as differences
6881 c        between UNRES torsional potentials (dependent on three types of
6882 c        residues) and the torsional potentials dependent on all 20 types
6883 c        of residues computed from AM1  energy surfaces of terminally-blocked
6884 c        amino-acid residues.
6885       implicit real*8 (a-h,o-z)
6886       include 'DIMENSIONS'
6887       include 'COMMON.VAR'
6888       include 'COMMON.GEO'
6889       include 'COMMON.LOCAL'
6890       include 'COMMON.TORSION'
6891       include 'COMMON.SCCOR'
6892       include 'COMMON.INTERACT'
6893       include 'COMMON.DERIV'
6894       include 'COMMON.CHAIN'
6895       include 'COMMON.NAMES'
6896       include 'COMMON.IOUNITS'
6897       include 'COMMON.FFIELD'
6898       include 'COMMON.CONTROL'
6899       logical lprn
6900 C Set lprn=.true. for debugging
6901       lprn=.false.
6902 c      lprn=.true.
6903 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6904       esccor=0.0D0
6905       do i=itau_start,itau_end
6906         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6907         esccor_ii=0.0D0
6908         isccori=isccortyp(itype(i-2))
6909         isccori1=isccortyp(itype(i-1))
6910 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6911         phii=phi(i)
6912         do intertyp=1,3 !intertyp
6913 cc Added 09 May 2012 (Adasko)
6914 cc  Intertyp means interaction type of backbone mainchain correlation:
6915 c   1 = SC...Ca...Ca...Ca
6916 c   2 = Ca...Ca...Ca...SC
6917 c   3 = SC...Ca...Ca...SCi
6918         gloci=0.0D0
6919         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6920      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6921      &      (itype(i-1).eq.ntyp1)))
6922      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6923      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6924      &     .or.(itype(i).eq.ntyp1)))
6925      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6926      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6927      &      (itype(i-3).eq.ntyp1)))) cycle
6928         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6929         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6930      & cycle
6931        do j=1,nterm_sccor(isccori,isccori1)
6932           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6933           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6934           cosphi=dcos(j*tauangle(intertyp,i))
6935           sinphi=dsin(j*tauangle(intertyp,i))
6936           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6937           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6938         enddo
6939 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6940         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6941         if (lprn)
6942      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6943      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6944      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6945      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6946         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6947        enddo !intertyp
6948       enddo
6949
6950       return
6951       end
6952 c----------------------------------------------------------------------------
6953       subroutine multibody(ecorr)
6954 C This subroutine calculates multi-body contributions to energy following
6955 C the idea of Skolnick et al. If side chains I and J make a contact and
6956 C at the same time side chains I+1 and J+1 make a contact, an extra
6957 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6958       implicit real*8 (a-h,o-z)
6959       include 'DIMENSIONS'
6960       include 'COMMON.IOUNITS'
6961       include 'COMMON.DERIV'
6962       include 'COMMON.INTERACT'
6963       include 'COMMON.CONTACTS'
6964       double precision gx(3),gx1(3)
6965       logical lprn
6966
6967 C Set lprn=.true. for debugging
6968       lprn=.false.
6969
6970       if (lprn) then
6971         write (iout,'(a)') 'Contact function values:'
6972         do i=nnt,nct-2
6973           write (iout,'(i2,20(1x,i2,f10.5))')
6974      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6975         enddo
6976       endif
6977       ecorr=0.0D0
6978       do i=nnt,nct
6979         do j=1,3
6980           gradcorr(j,i)=0.0D0
6981           gradxorr(j,i)=0.0D0
6982         enddo
6983       enddo
6984       do i=nnt,nct-2
6985
6986         DO ISHIFT = 3,4
6987
6988         i1=i+ishift
6989         num_conti=num_cont(i)
6990         num_conti1=num_cont(i1)
6991         do jj=1,num_conti
6992           j=jcont(jj,i)
6993           do kk=1,num_conti1
6994             j1=jcont(kk,i1)
6995             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6996 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6997 cd   &                   ' ishift=',ishift
6998 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6999 C The system gains extra energy.
7000               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7001             endif   ! j1==j+-ishift
7002           enddo     ! kk
7003         enddo       ! jj
7004
7005         ENDDO ! ISHIFT
7006
7007       enddo         ! i
7008       return
7009       end
7010 c------------------------------------------------------------------------------
7011       double precision function esccorr(i,j,k,l,jj,kk)
7012       implicit real*8 (a-h,o-z)
7013       include 'DIMENSIONS'
7014       include 'COMMON.IOUNITS'
7015       include 'COMMON.DERIV'
7016       include 'COMMON.INTERACT'
7017       include 'COMMON.CONTACTS'
7018       double precision gx(3),gx1(3)
7019       logical lprn
7020       lprn=.false.
7021       eij=facont(jj,i)
7022       ekl=facont(kk,k)
7023 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7024 C Calculate the multi-body contribution to energy.
7025 C Calculate multi-body contributions to the gradient.
7026 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7027 cd   & k,l,(gacont(m,kk,k),m=1,3)
7028       do m=1,3
7029         gx(m) =ekl*gacont(m,jj,i)
7030         gx1(m)=eij*gacont(m,kk,k)
7031         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7032         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7033         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7034         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7035       enddo
7036       do m=i,j-1
7037         do ll=1,3
7038           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7039         enddo
7040       enddo
7041       do m=k,l-1
7042         do ll=1,3
7043           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7044         enddo
7045       enddo
7046       esccorr=-eij*ekl
7047       return
7048       end
7049 c------------------------------------------------------------------------------
7050       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7051 C This subroutine calculates multi-body contributions to hydrogen-bonding
7052       implicit real*8 (a-h,o-z)
7053       include 'DIMENSIONS'
7054       include 'COMMON.IOUNITS'
7055 #ifdef MPI
7056       include "mpif.h"
7057       parameter (max_cont=maxconts)
7058       parameter (max_dim=26)
7059       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7060       double precision zapas(max_dim,maxconts,max_fg_procs),
7061      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7062       common /przechowalnia/ zapas
7063       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7064      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7065 #endif
7066       include 'COMMON.SETUP'
7067       include 'COMMON.FFIELD'
7068       include 'COMMON.DERIV'
7069       include 'COMMON.INTERACT'
7070       include 'COMMON.CONTACTS'
7071       include 'COMMON.CONTROL'
7072       include 'COMMON.LOCAL'
7073       double precision gx(3),gx1(3),time00
7074       logical lprn,ldone
7075
7076 C Set lprn=.true. for debugging
7077       lprn=.false.
7078 #ifdef MPI
7079       n_corr=0
7080       n_corr1=0
7081       if (nfgtasks.le.1) goto 30
7082       if (lprn) then
7083         write (iout,'(a)') 'Contact function values before RECEIVE:'
7084         do i=nnt,nct-2
7085           write (iout,'(2i3,50(1x,i2,f5.2))')
7086      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7087      &    j=1,num_cont_hb(i))
7088         enddo
7089       endif
7090       call flush(iout)
7091       do i=1,ntask_cont_from
7092         ncont_recv(i)=0
7093       enddo
7094       do i=1,ntask_cont_to
7095         ncont_sent(i)=0
7096       enddo
7097 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7098 c     & ntask_cont_to
7099 C Make the list of contacts to send to send to other procesors
7100 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7101 c      call flush(iout)
7102       do i=iturn3_start,iturn3_end
7103 c        write (iout,*) "make contact list turn3",i," num_cont",
7104 c     &    num_cont_hb(i)
7105         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7106       enddo
7107       do i=iturn4_start,iturn4_end
7108 c        write (iout,*) "make contact list turn4",i," num_cont",
7109 c     &   num_cont_hb(i)
7110         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7111       enddo
7112       do ii=1,nat_sent
7113         i=iat_sent(ii)
7114 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7115 c     &    num_cont_hb(i)
7116         do j=1,num_cont_hb(i)
7117         do k=1,4
7118           jjc=jcont_hb(j,i)
7119           iproc=iint_sent_local(k,jjc,ii)
7120 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7121           if (iproc.gt.0) then
7122             ncont_sent(iproc)=ncont_sent(iproc)+1
7123             nn=ncont_sent(iproc)
7124             zapas(1,nn,iproc)=i
7125             zapas(2,nn,iproc)=jjc
7126             zapas(3,nn,iproc)=facont_hb(j,i)
7127             zapas(4,nn,iproc)=ees0p(j,i)
7128             zapas(5,nn,iproc)=ees0m(j,i)
7129             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7130             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7131             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7132             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7133             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7134             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7135             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7136             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7137             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7138             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7139             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7140             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7141             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7142             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7143             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7144             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7145             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7146             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7147             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7148             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7149             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7150           endif
7151         enddo
7152         enddo
7153       enddo
7154       if (lprn) then
7155       write (iout,*)
7156      &  "Numbers of contacts to be sent to other processors",
7157      &  (ncont_sent(i),i=1,ntask_cont_to)
7158       write (iout,*) "Contacts sent"
7159       do ii=1,ntask_cont_to
7160         nn=ncont_sent(ii)
7161         iproc=itask_cont_to(ii)
7162         write (iout,*) nn," contacts to processor",iproc,
7163      &   " of CONT_TO_COMM group"
7164         do i=1,nn
7165           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7166         enddo
7167       enddo
7168       call flush(iout)
7169       endif
7170       CorrelType=477
7171       CorrelID=fg_rank+1
7172       CorrelType1=478
7173       CorrelID1=nfgtasks+fg_rank+1
7174       ireq=0
7175 C Receive the numbers of needed contacts from other processors
7176       do ii=1,ntask_cont_from
7177         iproc=itask_cont_from(ii)
7178         ireq=ireq+1
7179         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7180      &    FG_COMM,req(ireq),IERR)
7181       enddo
7182 c      write (iout,*) "IRECV ended"
7183 c      call flush(iout)
7184 C Send the number of contacts needed by other processors
7185       do ii=1,ntask_cont_to
7186         iproc=itask_cont_to(ii)
7187         ireq=ireq+1
7188         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7189      &    FG_COMM,req(ireq),IERR)
7190       enddo
7191 c      write (iout,*) "ISEND ended"
7192 c      write (iout,*) "number of requests (nn)",ireq
7193       call flush(iout)
7194       if (ireq.gt.0)
7195      &  call MPI_Waitall(ireq,req,status_array,ierr)
7196 c      write (iout,*)
7197 c     &  "Numbers of contacts to be received from other processors",
7198 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7199 c      call flush(iout)
7200 C Receive contacts
7201       ireq=0
7202       do ii=1,ntask_cont_from
7203         iproc=itask_cont_from(ii)
7204         nn=ncont_recv(ii)
7205 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7206 c     &   " of CONT_TO_COMM group"
7207         call flush(iout)
7208         if (nn.gt.0) then
7209           ireq=ireq+1
7210           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7211      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7212 c          write (iout,*) "ireq,req",ireq,req(ireq)
7213         endif
7214       enddo
7215 C Send the contacts to processors that need them
7216       do ii=1,ntask_cont_to
7217         iproc=itask_cont_to(ii)
7218         nn=ncont_sent(ii)
7219 c        write (iout,*) nn," contacts to processor",iproc,
7220 c     &   " of CONT_TO_COMM group"
7221         if (nn.gt.0) then
7222           ireq=ireq+1
7223           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7224      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7225 c          write (iout,*) "ireq,req",ireq,req(ireq)
7226 c          do i=1,nn
7227 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7228 c          enddo
7229         endif
7230       enddo
7231 c      write (iout,*) "number of requests (contacts)",ireq
7232 c      write (iout,*) "req",(req(i),i=1,4)
7233 c      call flush(iout)
7234       if (ireq.gt.0)
7235      & call MPI_Waitall(ireq,req,status_array,ierr)
7236       do iii=1,ntask_cont_from
7237         iproc=itask_cont_from(iii)
7238         nn=ncont_recv(iii)
7239         if (lprn) then
7240         write (iout,*) "Received",nn," contacts from processor",iproc,
7241      &   " of CONT_FROM_COMM group"
7242         call flush(iout)
7243         do i=1,nn
7244           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7245         enddo
7246         call flush(iout)
7247         endif
7248         do i=1,nn
7249           ii=zapas_recv(1,i,iii)
7250 c Flag the received contacts to prevent double-counting
7251           jj=-zapas_recv(2,i,iii)
7252 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7253 c          call flush(iout)
7254           nnn=num_cont_hb(ii)+1
7255           num_cont_hb(ii)=nnn
7256           jcont_hb(nnn,ii)=jj
7257           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7258           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7259           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7260           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7261           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7262           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7263           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7264           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7265           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7266           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7267           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7268           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7269           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7270           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7271           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7272           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7273           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7274           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7275           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7276           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7277           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7278           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7279           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7280           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7281         enddo
7282       enddo
7283       call flush(iout)
7284       if (lprn) then
7285         write (iout,'(a)') 'Contact function values after receive:'
7286         do i=nnt,nct-2
7287           write (iout,'(2i3,50(1x,i3,f5.2))')
7288      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7289      &    j=1,num_cont_hb(i))
7290         enddo
7291         call flush(iout)
7292       endif
7293    30 continue
7294 #endif
7295       if (lprn) then
7296         write (iout,'(a)') 'Contact function values:'
7297         do i=nnt,nct-2
7298           write (iout,'(2i3,50(1x,i3,f5.2))')
7299      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7300      &    j=1,num_cont_hb(i))
7301         enddo
7302       endif
7303       ecorr=0.0D0
7304 C Remove the loop below after debugging !!!
7305       do i=nnt,nct
7306         do j=1,3
7307           gradcorr(j,i)=0.0D0
7308           gradxorr(j,i)=0.0D0
7309         enddo
7310       enddo
7311 C Calculate the local-electrostatic correlation terms
7312       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7313         i1=i+1
7314         num_conti=num_cont_hb(i)
7315         num_conti1=num_cont_hb(i+1)
7316         do jj=1,num_conti
7317           j=jcont_hb(jj,i)
7318           jp=iabs(j)
7319           do kk=1,num_conti1
7320             j1=jcont_hb(kk,i1)
7321             jp1=iabs(j1)
7322 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7323 c     &         ' jj=',jj,' kk=',kk
7324             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7325      &          .or. j.lt.0 .and. j1.gt.0) .and.
7326      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7327 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7328 C The system gains extra energy.
7329               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7330               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7331      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7332               n_corr=n_corr+1
7333             else if (j1.eq.j) then
7334 C Contacts I-J and I-(J+1) occur simultaneously.
7335 C The system loses extra energy.
7336 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7337             endif
7338           enddo ! kk
7339           do kk=1,num_conti
7340             j1=jcont_hb(kk,i)
7341 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7342 c    &         ' jj=',jj,' kk=',kk
7343             if (j1.eq.j+1) then
7344 C Contacts I-J and (I+1)-J occur simultaneously.
7345 C The system loses extra energy.
7346 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7347             endif ! j1==j+1
7348           enddo ! kk
7349         enddo ! jj
7350       enddo ! i
7351       return
7352       end
7353 c------------------------------------------------------------------------------
7354       subroutine add_hb_contact(ii,jj,itask)
7355       implicit real*8 (a-h,o-z)
7356       include "DIMENSIONS"
7357       include "COMMON.IOUNITS"
7358       integer max_cont
7359       integer max_dim
7360       parameter (max_cont=maxconts)
7361       parameter (max_dim=26)
7362       include "COMMON.CONTACTS"
7363       double precision zapas(max_dim,maxconts,max_fg_procs),
7364      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7365       common /przechowalnia/ zapas
7366       integer i,j,ii,jj,iproc,itask(4),nn
7367 c      write (iout,*) "itask",itask
7368       do i=1,2
7369         iproc=itask(i)
7370         if (iproc.gt.0) then
7371           do j=1,num_cont_hb(ii)
7372             jjc=jcont_hb(j,ii)
7373 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7374             if (jjc.eq.jj) then
7375               ncont_sent(iproc)=ncont_sent(iproc)+1
7376               nn=ncont_sent(iproc)
7377               zapas(1,nn,iproc)=ii
7378               zapas(2,nn,iproc)=jjc
7379               zapas(3,nn,iproc)=facont_hb(j,ii)
7380               zapas(4,nn,iproc)=ees0p(j,ii)
7381               zapas(5,nn,iproc)=ees0m(j,ii)
7382               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7383               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7384               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7385               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7386               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7387               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7388               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7389               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7390               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7391               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7392               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7393               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7394               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7395               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7396               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7397               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7398               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7399               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7400               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7401               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7402               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7403               exit
7404             endif
7405           enddo
7406         endif
7407       enddo
7408       return
7409       end
7410 c------------------------------------------------------------------------------
7411       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7412      &  n_corr1)
7413 C This subroutine calculates multi-body contributions to hydrogen-bonding
7414       implicit real*8 (a-h,o-z)
7415       include 'DIMENSIONS'
7416       include 'COMMON.IOUNITS'
7417 #ifdef MPI
7418       include "mpif.h"
7419       parameter (max_cont=maxconts)
7420       parameter (max_dim=70)
7421       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7422       double precision zapas(max_dim,maxconts,max_fg_procs),
7423      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7424       common /przechowalnia/ zapas
7425       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7426      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7427 #endif
7428       include 'COMMON.SETUP'
7429       include 'COMMON.FFIELD'
7430       include 'COMMON.DERIV'
7431       include 'COMMON.LOCAL'
7432       include 'COMMON.INTERACT'
7433       include 'COMMON.CONTACTS'
7434       include 'COMMON.CHAIN'
7435       include 'COMMON.CONTROL'
7436       double precision gx(3),gx1(3)
7437       integer num_cont_hb_old(maxres)
7438       logical lprn,ldone
7439       double precision eello4,eello5,eelo6,eello_turn6
7440       external eello4,eello5,eello6,eello_turn6
7441 C Set lprn=.true. for debugging
7442       lprn=.false.
7443       eturn6=0.0d0
7444 #ifdef MPI
7445       do i=1,nres
7446         num_cont_hb_old(i)=num_cont_hb(i)
7447       enddo
7448       n_corr=0
7449       n_corr1=0
7450       if (nfgtasks.le.1) goto 30
7451       if (lprn) then
7452         write (iout,'(a)') 'Contact function values before RECEIVE:'
7453         do i=nnt,nct-2
7454           write (iout,'(2i3,50(1x,i2,f5.2))')
7455      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7456      &    j=1,num_cont_hb(i))
7457         enddo
7458       endif
7459       call flush(iout)
7460       do i=1,ntask_cont_from
7461         ncont_recv(i)=0
7462       enddo
7463       do i=1,ntask_cont_to
7464         ncont_sent(i)=0
7465       enddo
7466 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7467 c     & ntask_cont_to
7468 C Make the list of contacts to send to send to other procesors
7469       do i=iturn3_start,iturn3_end
7470 c        write (iout,*) "make contact list turn3",i," num_cont",
7471 c     &    num_cont_hb(i)
7472         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7473       enddo
7474       do i=iturn4_start,iturn4_end
7475 c        write (iout,*) "make contact list turn4",i," num_cont",
7476 c     &   num_cont_hb(i)
7477         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7478       enddo
7479       do ii=1,nat_sent
7480         i=iat_sent(ii)
7481 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7482 c     &    num_cont_hb(i)
7483         do j=1,num_cont_hb(i)
7484         do k=1,4
7485           jjc=jcont_hb(j,i)
7486           iproc=iint_sent_local(k,jjc,ii)
7487 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7488           if (iproc.ne.0) then
7489             ncont_sent(iproc)=ncont_sent(iproc)+1
7490             nn=ncont_sent(iproc)
7491             zapas(1,nn,iproc)=i
7492             zapas(2,nn,iproc)=jjc
7493             zapas(3,nn,iproc)=d_cont(j,i)
7494             ind=3
7495             do kk=1,3
7496               ind=ind+1
7497               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7498             enddo
7499             do kk=1,2
7500               do ll=1,2
7501                 ind=ind+1
7502                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7503               enddo
7504             enddo
7505             do jj=1,5
7506               do kk=1,3
7507                 do ll=1,2
7508                   do mm=1,2
7509                     ind=ind+1
7510                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7511                   enddo
7512                 enddo
7513               enddo
7514             enddo
7515           endif
7516         enddo
7517         enddo
7518       enddo
7519       if (lprn) then
7520       write (iout,*)
7521      &  "Numbers of contacts to be sent to other processors",
7522      &  (ncont_sent(i),i=1,ntask_cont_to)
7523       write (iout,*) "Contacts sent"
7524       do ii=1,ntask_cont_to
7525         nn=ncont_sent(ii)
7526         iproc=itask_cont_to(ii)
7527         write (iout,*) nn," contacts to processor",iproc,
7528      &   " of CONT_TO_COMM group"
7529         do i=1,nn
7530           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7531         enddo
7532       enddo
7533       call flush(iout)
7534       endif
7535       CorrelType=477
7536       CorrelID=fg_rank+1
7537       CorrelType1=478
7538       CorrelID1=nfgtasks+fg_rank+1
7539       ireq=0
7540 C Receive the numbers of needed contacts from other processors
7541       do ii=1,ntask_cont_from
7542         iproc=itask_cont_from(ii)
7543         ireq=ireq+1
7544         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7545      &    FG_COMM,req(ireq),IERR)
7546       enddo
7547 c      write (iout,*) "IRECV ended"
7548 c      call flush(iout)
7549 C Send the number of contacts needed by other processors
7550       do ii=1,ntask_cont_to
7551         iproc=itask_cont_to(ii)
7552         ireq=ireq+1
7553         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7554      &    FG_COMM,req(ireq),IERR)
7555       enddo
7556 c      write (iout,*) "ISEND ended"
7557 c      write (iout,*) "number of requests (nn)",ireq
7558       call flush(iout)
7559       if (ireq.gt.0)
7560      &  call MPI_Waitall(ireq,req,status_array,ierr)
7561 c      write (iout,*)
7562 c     &  "Numbers of contacts to be received from other processors",
7563 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7564 c      call flush(iout)
7565 C Receive contacts
7566       ireq=0
7567       do ii=1,ntask_cont_from
7568         iproc=itask_cont_from(ii)
7569         nn=ncont_recv(ii)
7570 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7571 c     &   " of CONT_TO_COMM group"
7572         call flush(iout)
7573         if (nn.gt.0) then
7574           ireq=ireq+1
7575           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7576      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7577 c          write (iout,*) "ireq,req",ireq,req(ireq)
7578         endif
7579       enddo
7580 C Send the contacts to processors that need them
7581       do ii=1,ntask_cont_to
7582         iproc=itask_cont_to(ii)
7583         nn=ncont_sent(ii)
7584 c        write (iout,*) nn," contacts to processor",iproc,
7585 c     &   " of CONT_TO_COMM group"
7586         if (nn.gt.0) then
7587           ireq=ireq+1
7588           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7589      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7590 c          write (iout,*) "ireq,req",ireq,req(ireq)
7591 c          do i=1,nn
7592 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7593 c          enddo
7594         endif
7595       enddo
7596 c      write (iout,*) "number of requests (contacts)",ireq
7597 c      write (iout,*) "req",(req(i),i=1,4)
7598 c      call flush(iout)
7599       if (ireq.gt.0)
7600      & call MPI_Waitall(ireq,req,status_array,ierr)
7601       do iii=1,ntask_cont_from
7602         iproc=itask_cont_from(iii)
7603         nn=ncont_recv(iii)
7604         if (lprn) then
7605         write (iout,*) "Received",nn," contacts from processor",iproc,
7606      &   " of CONT_FROM_COMM group"
7607         call flush(iout)
7608         do i=1,nn
7609           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7610         enddo
7611         call flush(iout)
7612         endif
7613         do i=1,nn
7614           ii=zapas_recv(1,i,iii)
7615 c Flag the received contacts to prevent double-counting
7616           jj=-zapas_recv(2,i,iii)
7617 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7618 c          call flush(iout)
7619           nnn=num_cont_hb(ii)+1
7620           num_cont_hb(ii)=nnn
7621           jcont_hb(nnn,ii)=jj
7622           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7623           ind=3
7624           do kk=1,3
7625             ind=ind+1
7626             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7627           enddo
7628           do kk=1,2
7629             do ll=1,2
7630               ind=ind+1
7631               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7632             enddo
7633           enddo
7634           do jj=1,5
7635             do kk=1,3
7636               do ll=1,2
7637                 do mm=1,2
7638                   ind=ind+1
7639                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7640                 enddo
7641               enddo
7642             enddo
7643           enddo
7644         enddo
7645       enddo
7646       call flush(iout)
7647       if (lprn) then
7648         write (iout,'(a)') 'Contact function values after receive:'
7649         do i=nnt,nct-2
7650           write (iout,'(2i3,50(1x,i3,5f6.3))')
7651      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7652      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7653         enddo
7654         call flush(iout)
7655       endif
7656    30 continue
7657 #endif
7658       if (lprn) then
7659         write (iout,'(a)') 'Contact function values:'
7660         do i=nnt,nct-2
7661           write (iout,'(2i3,50(1x,i2,5f6.3))')
7662      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7663      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7664         enddo
7665       endif
7666       ecorr=0.0D0
7667       ecorr5=0.0d0
7668       ecorr6=0.0d0
7669 C Remove the loop below after debugging !!!
7670       do i=nnt,nct
7671         do j=1,3
7672           gradcorr(j,i)=0.0D0
7673           gradxorr(j,i)=0.0D0
7674         enddo
7675       enddo
7676 C Calculate the dipole-dipole interaction energies
7677       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7678       do i=iatel_s,iatel_e+1
7679         num_conti=num_cont_hb(i)
7680         do jj=1,num_conti
7681           j=jcont_hb(jj,i)
7682 #ifdef MOMENT
7683           call dipole(i,j,jj)
7684 #endif
7685         enddo
7686       enddo
7687       endif
7688 C Calculate the local-electrostatic correlation terms
7689 c                write (iout,*) "gradcorr5 in eello5 before loop"
7690 c                do iii=1,nres
7691 c                  write (iout,'(i5,3f10.5)')
7692 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7693 c                enddo
7694       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7695 c        write (iout,*) "corr loop i",i
7696         i1=i+1
7697         num_conti=num_cont_hb(i)
7698         num_conti1=num_cont_hb(i+1)
7699         do jj=1,num_conti
7700           j=jcont_hb(jj,i)
7701           jp=iabs(j)
7702           do kk=1,num_conti1
7703             j1=jcont_hb(kk,i1)
7704             jp1=iabs(j1)
7705 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7706 c     &         ' jj=',jj,' kk=',kk
7707 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7708             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7709      &          .or. j.lt.0 .and. j1.gt.0) .and.
7710      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7711 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7712 C The system gains extra energy.
7713               n_corr=n_corr+1
7714               sqd1=dsqrt(d_cont(jj,i))
7715               sqd2=dsqrt(d_cont(kk,i1))
7716               sred_geom = sqd1*sqd2
7717               IF (sred_geom.lt.cutoff_corr) THEN
7718                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7719      &            ekont,fprimcont)
7720 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7721 cd     &         ' jj=',jj,' kk=',kk
7722                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7723                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7724                 do l=1,3
7725                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7726                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7727                 enddo
7728                 n_corr1=n_corr1+1
7729 cd               write (iout,*) 'sred_geom=',sred_geom,
7730 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7731 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7732 cd               write (iout,*) "g_contij",g_contij
7733 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7734 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7735                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7736                 if (wcorr4.gt.0.0d0)
7737      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7738                   if (energy_dec.and.wcorr4.gt.0.0d0)
7739      1                 write (iout,'(a6,4i5,0pf7.3)')
7740      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7741 c                write (iout,*) "gradcorr5 before eello5"
7742 c                do iii=1,nres
7743 c                  write (iout,'(i5,3f10.5)')
7744 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7745 c                enddo
7746                 if (wcorr5.gt.0.0d0)
7747      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7748 c                write (iout,*) "gradcorr5 after eello5"
7749 c                do iii=1,nres
7750 c                  write (iout,'(i5,3f10.5)')
7751 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7752 c                enddo
7753                   if (energy_dec.and.wcorr5.gt.0.0d0)
7754      1                 write (iout,'(a6,4i5,0pf7.3)')
7755      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7756 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7757 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7758                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7759      &               .or. wturn6.eq.0.0d0))then
7760 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7761                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7762                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7763      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7764 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7765 cd     &            'ecorr6=',ecorr6
7766 cd                write (iout,'(4e15.5)') sred_geom,
7767 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7768 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7769 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7770                 else if (wturn6.gt.0.0d0
7771      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7772 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7773                   eturn6=eturn6+eello_turn6(i,jj,kk)
7774                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7775      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7776 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7777                 endif
7778               ENDIF
7779 1111          continue
7780             endif
7781           enddo ! kk
7782         enddo ! jj
7783       enddo ! i
7784       do i=1,nres
7785         num_cont_hb(i)=num_cont_hb_old(i)
7786       enddo
7787 c                write (iout,*) "gradcorr5 in eello5"
7788 c                do iii=1,nres
7789 c                  write (iout,'(i5,3f10.5)')
7790 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7791 c                enddo
7792       return
7793       end
7794 c------------------------------------------------------------------------------
7795       subroutine add_hb_contact_eello(ii,jj,itask)
7796       implicit real*8 (a-h,o-z)
7797       include "DIMENSIONS"
7798       include "COMMON.IOUNITS"
7799       integer max_cont
7800       integer max_dim
7801       parameter (max_cont=maxconts)
7802       parameter (max_dim=70)
7803       include "COMMON.CONTACTS"
7804       double precision zapas(max_dim,maxconts,max_fg_procs),
7805      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7806       common /przechowalnia/ zapas
7807       integer i,j,ii,jj,iproc,itask(4),nn
7808 c      write (iout,*) "itask",itask
7809       do i=1,2
7810         iproc=itask(i)
7811         if (iproc.gt.0) then
7812           do j=1,num_cont_hb(ii)
7813             jjc=jcont_hb(j,ii)
7814 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7815             if (jjc.eq.jj) then
7816               ncont_sent(iproc)=ncont_sent(iproc)+1
7817               nn=ncont_sent(iproc)
7818               zapas(1,nn,iproc)=ii
7819               zapas(2,nn,iproc)=jjc
7820               zapas(3,nn,iproc)=d_cont(j,ii)
7821               ind=3
7822               do kk=1,3
7823                 ind=ind+1
7824                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7825               enddo
7826               do kk=1,2
7827                 do ll=1,2
7828                   ind=ind+1
7829                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7830                 enddo
7831               enddo
7832               do jj=1,5
7833                 do kk=1,3
7834                   do ll=1,2
7835                     do mm=1,2
7836                       ind=ind+1
7837                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7838                     enddo
7839                   enddo
7840                 enddo
7841               enddo
7842               exit
7843             endif
7844           enddo
7845         endif
7846       enddo
7847       return
7848       end
7849 c------------------------------------------------------------------------------
7850       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7851       implicit real*8 (a-h,o-z)
7852       include 'DIMENSIONS'
7853       include 'COMMON.IOUNITS'
7854       include 'COMMON.DERIV'
7855       include 'COMMON.INTERACT'
7856       include 'COMMON.CONTACTS'
7857       double precision gx(3),gx1(3)
7858       logical lprn
7859       lprn=.false.
7860       eij=facont_hb(jj,i)
7861       ekl=facont_hb(kk,k)
7862       ees0pij=ees0p(jj,i)
7863       ees0pkl=ees0p(kk,k)
7864       ees0mij=ees0m(jj,i)
7865       ees0mkl=ees0m(kk,k)
7866       ekont=eij*ekl
7867       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7868 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7869 C Following 4 lines for diagnostics.
7870 cd    ees0pkl=0.0D0
7871 cd    ees0pij=1.0D0
7872 cd    ees0mkl=0.0D0
7873 cd    ees0mij=1.0D0
7874 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7875 c     & 'Contacts ',i,j,
7876 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7877 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7878 c     & 'gradcorr_long'
7879 C Calculate the multi-body contribution to energy.
7880 c      ecorr=ecorr+ekont*ees
7881 C Calculate multi-body contributions to the gradient.
7882       coeffpees0pij=coeffp*ees0pij
7883       coeffmees0mij=coeffm*ees0mij
7884       coeffpees0pkl=coeffp*ees0pkl
7885       coeffmees0mkl=coeffm*ees0mkl
7886       do ll=1,3
7887 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7888         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7889      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7890      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7891         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7892      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7893      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7894 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7895         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7896      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7897      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7898         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7899      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7900      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7901         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7902      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7903      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7904         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7905         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7906         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7907      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7908      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7909         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7910         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7911 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7912       enddo
7913 c      write (iout,*)
7914 cgrad      do m=i+1,j-1
7915 cgrad        do ll=1,3
7916 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7917 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7918 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7919 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7920 cgrad        enddo
7921 cgrad      enddo
7922 cgrad      do m=k+1,l-1
7923 cgrad        do ll=1,3
7924 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7925 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7926 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7927 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7928 cgrad        enddo
7929 cgrad      enddo
7930 c      write (iout,*) "ehbcorr",ekont*ees
7931       ehbcorr=ekont*ees
7932       return
7933       end
7934 #ifdef MOMENT
7935 C---------------------------------------------------------------------------
7936       subroutine dipole(i,j,jj)
7937       implicit real*8 (a-h,o-z)
7938       include 'DIMENSIONS'
7939       include 'COMMON.IOUNITS'
7940       include 'COMMON.CHAIN'
7941       include 'COMMON.FFIELD'
7942       include 'COMMON.DERIV'
7943       include 'COMMON.INTERACT'
7944       include 'COMMON.CONTACTS'
7945       include 'COMMON.TORSION'
7946       include 'COMMON.VAR'
7947       include 'COMMON.GEO'
7948       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7949      &  auxmat(2,2)
7950       iti1 = itortyp(itype(i+1))
7951       if (j.lt.nres-1) then
7952         itj1 = itortyp(itype(j+1))
7953       else
7954         itj1=ntortyp
7955       endif
7956       do iii=1,2
7957         dipi(iii,1)=Ub2(iii,i)
7958         dipderi(iii)=Ub2der(iii,i)
7959         dipi(iii,2)=b1(iii,i+1)
7960         dipj(iii,1)=Ub2(iii,j)
7961         dipderj(iii)=Ub2der(iii,j)
7962         dipj(iii,2)=b1(iii,j+1)
7963       enddo
7964       kkk=0
7965       do iii=1,2
7966         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7967         do jjj=1,2
7968           kkk=kkk+1
7969           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7970         enddo
7971       enddo
7972       do kkk=1,5
7973         do lll=1,3
7974           mmm=0
7975           do iii=1,2
7976             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7977      &        auxvec(1))
7978             do jjj=1,2
7979               mmm=mmm+1
7980               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7981             enddo
7982           enddo
7983         enddo
7984       enddo
7985       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7986       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7987       do iii=1,2
7988         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7989       enddo
7990       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7991       do iii=1,2
7992         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7993       enddo
7994       return
7995       end
7996 #endif
7997 C---------------------------------------------------------------------------
7998       subroutine calc_eello(i,j,k,l,jj,kk)
7999 C
8000 C This subroutine computes matrices and vectors needed to calculate
8001 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8002 C
8003       implicit real*8 (a-h,o-z)
8004       include 'DIMENSIONS'
8005       include 'COMMON.IOUNITS'
8006       include 'COMMON.CHAIN'
8007       include 'COMMON.DERIV'
8008       include 'COMMON.INTERACT'
8009       include 'COMMON.CONTACTS'
8010       include 'COMMON.TORSION'
8011       include 'COMMON.VAR'
8012       include 'COMMON.GEO'
8013       include 'COMMON.FFIELD'
8014       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8015      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8016       logical lprn
8017       common /kutas/ lprn
8018 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8019 cd     & ' jj=',jj,' kk=',kk
8020 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8021 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8022 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8023       do iii=1,2
8024         do jjj=1,2
8025           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8026           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8027         enddo
8028       enddo
8029       call transpose2(aa1(1,1),aa1t(1,1))
8030       call transpose2(aa2(1,1),aa2t(1,1))
8031       do kkk=1,5
8032         do lll=1,3
8033           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8034      &      aa1tder(1,1,lll,kkk))
8035           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8036      &      aa2tder(1,1,lll,kkk))
8037         enddo
8038       enddo
8039       if (l.eq.j+1) then
8040 C parallel orientation of the two CA-CA-CA frames.
8041         if (i.gt.1) then
8042           iti=itortyp(itype(i))
8043         else
8044           iti=ntortyp
8045         endif
8046         itk1=itortyp(itype(k+1))
8047         itj=itortyp(itype(j))
8048         if (l.lt.nres-1) then
8049           itl1=itortyp(itype(l+1))
8050         else
8051           itl1=ntortyp
8052         endif
8053 C A1 kernel(j+1) A2T
8054 cd        do iii=1,2
8055 cd          write (iout,'(3f10.5,5x,3f10.5)')
8056 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8057 cd        enddo
8058         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8059      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8060      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8061 C Following matrices are needed only for 6-th order cumulants
8062         IF (wcorr6.gt.0.0d0) THEN
8063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8064      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8065      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8067      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8068      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8069      &   ADtEAderx(1,1,1,1,1,1))
8070         lprn=.false.
8071         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8072      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8073      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8074      &   ADtEA1derx(1,1,1,1,1,1))
8075         ENDIF
8076 C End 6-th order cumulants
8077 cd        lprn=.false.
8078 cd        if (lprn) then
8079 cd        write (2,*) 'In calc_eello6'
8080 cd        do iii=1,2
8081 cd          write (2,*) 'iii=',iii
8082 cd          do kkk=1,5
8083 cd            write (2,*) 'kkk=',kkk
8084 cd            do jjj=1,2
8085 cd              write (2,'(3(2f10.5),5x)')
8086 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8087 cd            enddo
8088 cd          enddo
8089 cd        enddo
8090 cd        endif
8091         call transpose2(EUgder(1,1,k),auxmat(1,1))
8092         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8093         call transpose2(EUg(1,1,k),auxmat(1,1))
8094         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8095         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8096         do iii=1,2
8097           do kkk=1,5
8098             do lll=1,3
8099               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8100      &          EAEAderx(1,1,lll,kkk,iii,1))
8101             enddo
8102           enddo
8103         enddo
8104 C A1T kernel(i+1) A2
8105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8106      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8107      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8108 C Following matrices are needed only for 6-th order cumulants
8109         IF (wcorr6.gt.0.0d0) THEN
8110         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8111      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8112      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8113         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8114      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8115      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8116      &   ADtEAderx(1,1,1,1,1,2))
8117         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8118      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8119      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8120      &   ADtEA1derx(1,1,1,1,1,2))
8121         ENDIF
8122 C End 6-th order cumulants
8123         call transpose2(EUgder(1,1,l),auxmat(1,1))
8124         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8125         call transpose2(EUg(1,1,l),auxmat(1,1))
8126         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8127         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8128         do iii=1,2
8129           do kkk=1,5
8130             do lll=1,3
8131               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8132      &          EAEAderx(1,1,lll,kkk,iii,2))
8133             enddo
8134           enddo
8135         enddo
8136 C AEAb1 and AEAb2
8137 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8138 C They are needed only when the fifth- or the sixth-order cumulants are
8139 C indluded.
8140         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8141         call transpose2(AEA(1,1,1),auxmat(1,1))
8142         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8144         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8145         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8146         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8147         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8148         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8149         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8150         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8151         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8152         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8153         call transpose2(AEA(1,1,2),auxmat(1,1))
8154         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8155         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8156         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8157         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8158         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8159         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8160         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8161         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8162         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8163         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8164         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8165 C Calculate the Cartesian derivatives of the vectors.
8166         do iii=1,2
8167           do kkk=1,5
8168             do lll=1,3
8169               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8170               call matvec2(auxmat(1,1),b1(1,i),
8171      &          AEAb1derx(1,lll,kkk,iii,1,1))
8172               call matvec2(auxmat(1,1),Ub2(1,i),
8173      &          AEAb2derx(1,lll,kkk,iii,1,1))
8174               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8175      &          AEAb1derx(1,lll,kkk,iii,2,1))
8176               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8177      &          AEAb2derx(1,lll,kkk,iii,2,1))
8178               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8179               call matvec2(auxmat(1,1),b1(1,j),
8180      &          AEAb1derx(1,lll,kkk,iii,1,2))
8181               call matvec2(auxmat(1,1),Ub2(1,j),
8182      &          AEAb2derx(1,lll,kkk,iii,1,2))
8183               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8184      &          AEAb1derx(1,lll,kkk,iii,2,2))
8185               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8186      &          AEAb2derx(1,lll,kkk,iii,2,2))
8187             enddo
8188           enddo
8189         enddo
8190         ENDIF
8191 C End vectors
8192       else
8193 C Antiparallel orientation of the two CA-CA-CA frames.
8194         if (i.gt.1) then
8195           iti=itortyp(itype(i))
8196         else
8197           iti=ntortyp
8198         endif
8199         itk1=itortyp(itype(k+1))
8200         itl=itortyp(itype(l))
8201         itj=itortyp(itype(j))
8202         if (j.lt.nres-1) then
8203           itj1=itortyp(itype(j+1))
8204         else
8205           itj1=ntortyp
8206         endif
8207 C A2 kernel(j-1)T A1T
8208         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8209      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8210      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8211 C Following matrices are needed only for 6-th order cumulants
8212         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8213      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8214         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8215      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8216      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8217         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8218      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8219      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8220      &   ADtEAderx(1,1,1,1,1,1))
8221         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8222      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8223      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8224      &   ADtEA1derx(1,1,1,1,1,1))
8225         ENDIF
8226 C End 6-th order cumulants
8227         call transpose2(EUgder(1,1,k),auxmat(1,1))
8228         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8229         call transpose2(EUg(1,1,k),auxmat(1,1))
8230         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8231         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8232         do iii=1,2
8233           do kkk=1,5
8234             do lll=1,3
8235               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8236      &          EAEAderx(1,1,lll,kkk,iii,1))
8237             enddo
8238           enddo
8239         enddo
8240 C A2T kernel(i+1)T A1
8241         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8242      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8243      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8244 C Following matrices are needed only for 6-th order cumulants
8245         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8246      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8247         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8248      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8249      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8250         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8251      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8252      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8253      &   ADtEAderx(1,1,1,1,1,2))
8254         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8255      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8256      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8257      &   ADtEA1derx(1,1,1,1,1,2))
8258         ENDIF
8259 C End 6-th order cumulants
8260         call transpose2(EUgder(1,1,j),auxmat(1,1))
8261         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8262         call transpose2(EUg(1,1,j),auxmat(1,1))
8263         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8264         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8265         do iii=1,2
8266           do kkk=1,5
8267             do lll=1,3
8268               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8269      &          EAEAderx(1,1,lll,kkk,iii,2))
8270             enddo
8271           enddo
8272         enddo
8273 C AEAb1 and AEAb2
8274 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8275 C They are needed only when the fifth- or the sixth-order cumulants are
8276 C indluded.
8277         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8278      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8279         call transpose2(AEA(1,1,1),auxmat(1,1))
8280         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8281         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8282         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8283         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8284         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8285         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8286         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8287         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8288         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8289         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8290         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8291         call transpose2(AEA(1,1,2),auxmat(1,1))
8292         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8293         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8294         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8295         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8296         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8297         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8298         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8299         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8300         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8301         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8302         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8303 C Calculate the Cartesian derivatives of the vectors.
8304         do iii=1,2
8305           do kkk=1,5
8306             do lll=1,3
8307               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8308               call matvec2(auxmat(1,1),b1(1,i),
8309      &          AEAb1derx(1,lll,kkk,iii,1,1))
8310               call matvec2(auxmat(1,1),Ub2(1,i),
8311      &          AEAb2derx(1,lll,kkk,iii,1,1))
8312               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8313      &          AEAb1derx(1,lll,kkk,iii,2,1))
8314               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8315      &          AEAb2derx(1,lll,kkk,iii,2,1))
8316               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8317               call matvec2(auxmat(1,1),b1(1,l),
8318      &          AEAb1derx(1,lll,kkk,iii,1,2))
8319               call matvec2(auxmat(1,1),Ub2(1,l),
8320      &          AEAb2derx(1,lll,kkk,iii,1,2))
8321               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8322      &          AEAb1derx(1,lll,kkk,iii,2,2))
8323               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8324      &          AEAb2derx(1,lll,kkk,iii,2,2))
8325             enddo
8326           enddo
8327         enddo
8328         ENDIF
8329 C End vectors
8330       endif
8331       return
8332       end
8333 C---------------------------------------------------------------------------
8334       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8335      &  KK,KKderg,AKA,AKAderg,AKAderx)
8336       implicit none
8337       integer nderg
8338       logical transp
8339       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8340      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8341      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8342       integer iii,kkk,lll
8343       integer jjj,mmm
8344       logical lprn
8345       common /kutas/ lprn
8346       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8347       do iii=1,nderg
8348         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8349      &    AKAderg(1,1,iii))
8350       enddo
8351 cd      if (lprn) write (2,*) 'In kernel'
8352       do kkk=1,5
8353 cd        if (lprn) write (2,*) 'kkk=',kkk
8354         do lll=1,3
8355           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8356      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8357 cd          if (lprn) then
8358 cd            write (2,*) 'lll=',lll
8359 cd            write (2,*) 'iii=1'
8360 cd            do jjj=1,2
8361 cd              write (2,'(3(2f10.5),5x)')
8362 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8363 cd            enddo
8364 cd          endif
8365           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8366      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8367 cd          if (lprn) then
8368 cd            write (2,*) 'lll=',lll
8369 cd            write (2,*) 'iii=2'
8370 cd            do jjj=1,2
8371 cd              write (2,'(3(2f10.5),5x)')
8372 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8373 cd            enddo
8374 cd          endif
8375         enddo
8376       enddo
8377       return
8378       end
8379 C---------------------------------------------------------------------------
8380       double precision function eello4(i,j,k,l,jj,kk)
8381       implicit real*8 (a-h,o-z)
8382       include 'DIMENSIONS'
8383       include 'COMMON.IOUNITS'
8384       include 'COMMON.CHAIN'
8385       include 'COMMON.DERIV'
8386       include 'COMMON.INTERACT'
8387       include 'COMMON.CONTACTS'
8388       include 'COMMON.TORSION'
8389       include 'COMMON.VAR'
8390       include 'COMMON.GEO'
8391       double precision pizda(2,2),ggg1(3),ggg2(3)
8392 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8393 cd        eello4=0.0d0
8394 cd        return
8395 cd      endif
8396 cd      print *,'eello4:',i,j,k,l,jj,kk
8397 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8398 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8399 cold      eij=facont_hb(jj,i)
8400 cold      ekl=facont_hb(kk,k)
8401 cold      ekont=eij*ekl
8402       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8403 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8404       gcorr_loc(k-1)=gcorr_loc(k-1)
8405      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8406       if (l.eq.j+1) then
8407         gcorr_loc(l-1)=gcorr_loc(l-1)
8408      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8409       else
8410         gcorr_loc(j-1)=gcorr_loc(j-1)
8411      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8412       endif
8413       do iii=1,2
8414         do kkk=1,5
8415           do lll=1,3
8416             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8417      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8418 cd            derx(lll,kkk,iii)=0.0d0
8419           enddo
8420         enddo
8421       enddo
8422 cd      gcorr_loc(l-1)=0.0d0
8423 cd      gcorr_loc(j-1)=0.0d0
8424 cd      gcorr_loc(k-1)=0.0d0
8425 cd      eel4=1.0d0
8426 cd      write (iout,*)'Contacts have occurred for peptide groups',
8427 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8428 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8429       if (j.lt.nres-1) then
8430         j1=j+1
8431         j2=j-1
8432       else
8433         j1=j-1
8434         j2=j-2
8435       endif
8436       if (l.lt.nres-1) then
8437         l1=l+1
8438         l2=l-1
8439       else
8440         l1=l-1
8441         l2=l-2
8442       endif
8443       do ll=1,3
8444 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8445 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8446         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8447         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8448 cgrad        ghalf=0.5d0*ggg1(ll)
8449         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8450         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8451         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8452         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8453         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8454         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8455 cgrad        ghalf=0.5d0*ggg2(ll)
8456         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8457         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8458         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8459         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8460         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8461         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8462       enddo
8463 cgrad      do m=i+1,j-1
8464 cgrad        do ll=1,3
8465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8466 cgrad        enddo
8467 cgrad      enddo
8468 cgrad      do m=k+1,l-1
8469 cgrad        do ll=1,3
8470 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8471 cgrad        enddo
8472 cgrad      enddo
8473 cgrad      do m=i+2,j2
8474 cgrad        do ll=1,3
8475 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8476 cgrad        enddo
8477 cgrad      enddo
8478 cgrad      do m=k+2,l2
8479 cgrad        do ll=1,3
8480 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8481 cgrad        enddo
8482 cgrad      enddo
8483 cd      do iii=1,nres-3
8484 cd        write (2,*) iii,gcorr_loc(iii)
8485 cd      enddo
8486       eello4=ekont*eel4
8487 cd      write (2,*) 'ekont',ekont
8488 cd      write (iout,*) 'eello4',ekont*eel4
8489       return
8490       end
8491 C---------------------------------------------------------------------------
8492       double precision function eello5(i,j,k,l,jj,kk)
8493       implicit real*8 (a-h,o-z)
8494       include 'DIMENSIONS'
8495       include 'COMMON.IOUNITS'
8496       include 'COMMON.CHAIN'
8497       include 'COMMON.DERIV'
8498       include 'COMMON.INTERACT'
8499       include 'COMMON.CONTACTS'
8500       include 'COMMON.TORSION'
8501       include 'COMMON.VAR'
8502       include 'COMMON.GEO'
8503       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8504       double precision ggg1(3),ggg2(3)
8505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8506 C                                                                              C
8507 C                            Parallel chains                                   C
8508 C                                                                              C
8509 C          o             o                   o             o                   C
8510 C         /l\           / \             \   / \           / \   /              C
8511 C        /   \         /   \             \ /   \         /   \ /               C
8512 C       j| o |l1       | o |              o| o |         | o |o                C
8513 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8514 C      \i/   \         /   \ /             /   \         /   \                 C
8515 C       o    k1             o                                                  C
8516 C         (I)          (II)                (III)          (IV)                 C
8517 C                                                                              C
8518 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8519 C                                                                              C
8520 C                            Antiparallel chains                               C
8521 C                                                                              C
8522 C          o             o                   o             o                   C
8523 C         /j\           / \             \   / \           / \   /              C
8524 C        /   \         /   \             \ /   \         /   \ /               C
8525 C      j1| o |l        | o |              o| o |         | o |o                C
8526 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8527 C      \i/   \         /   \ /             /   \         /   \                 C
8528 C       o     k1            o                                                  C
8529 C         (I)          (II)                (III)          (IV)                 C
8530 C                                                                              C
8531 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8532 C                                                                              C
8533 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8534 C                                                                              C
8535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8536 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8537 cd        eello5=0.0d0
8538 cd        return
8539 cd      endif
8540 cd      write (iout,*)
8541 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8542 cd     &   ' and',k,l
8543       itk=itortyp(itype(k))
8544       itl=itortyp(itype(l))
8545       itj=itortyp(itype(j))
8546       eello5_1=0.0d0
8547       eello5_2=0.0d0
8548       eello5_3=0.0d0
8549       eello5_4=0.0d0
8550 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8551 cd     &   eel5_3_num,eel5_4_num)
8552       do iii=1,2
8553         do kkk=1,5
8554           do lll=1,3
8555             derx(lll,kkk,iii)=0.0d0
8556           enddo
8557         enddo
8558       enddo
8559 cd      eij=facont_hb(jj,i)
8560 cd      ekl=facont_hb(kk,k)
8561 cd      ekont=eij*ekl
8562 cd      write (iout,*)'Contacts have occurred for peptide groups',
8563 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8564 cd      goto 1111
8565 C Contribution from the graph I.
8566 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8567 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8568       call transpose2(EUg(1,1,k),auxmat(1,1))
8569       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8570       vv(1)=pizda(1,1)-pizda(2,2)
8571       vv(2)=pizda(1,2)+pizda(2,1)
8572       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8573      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8574 C Explicit gradient in virtual-dihedral angles.
8575       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8576      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8577      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8578       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8579       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8580       vv(1)=pizda(1,1)-pizda(2,2)
8581       vv(2)=pizda(1,2)+pizda(2,1)
8582       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8583      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8584      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8585       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8586       vv(1)=pizda(1,1)-pizda(2,2)
8587       vv(2)=pizda(1,2)+pizda(2,1)
8588       if (l.eq.j+1) then
8589         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8590      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8592       else
8593         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8594      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8595      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8596       endif
8597 C Cartesian gradient
8598       do iii=1,2
8599         do kkk=1,5
8600           do lll=1,3
8601             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8602      &        pizda(1,1))
8603             vv(1)=pizda(1,1)-pizda(2,2)
8604             vv(2)=pizda(1,2)+pizda(2,1)
8605             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8606      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8607      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8608           enddo
8609         enddo
8610       enddo
8611 c      goto 1112
8612 c1111  continue
8613 C Contribution from graph II
8614       call transpose2(EE(1,1,itk),auxmat(1,1))
8615       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8616       vv(1)=pizda(1,1)+pizda(2,2)
8617       vv(2)=pizda(2,1)-pizda(1,2)
8618       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8619      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8620 C Explicit gradient in virtual-dihedral angles.
8621       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8622      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8623       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8624       vv(1)=pizda(1,1)+pizda(2,2)
8625       vv(2)=pizda(2,1)-pizda(1,2)
8626       if (l.eq.j+1) then
8627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8628      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8629      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8630       else
8631         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8632      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8633      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8634       endif
8635 C Cartesian gradient
8636       do iii=1,2
8637         do kkk=1,5
8638           do lll=1,3
8639             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8640      &        pizda(1,1))
8641             vv(1)=pizda(1,1)+pizda(2,2)
8642             vv(2)=pizda(2,1)-pizda(1,2)
8643             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8644      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8645      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8646           enddo
8647         enddo
8648       enddo
8649 cd      goto 1112
8650 cd1111  continue
8651       if (l.eq.j+1) then
8652 cd        goto 1110
8653 C Parallel orientation
8654 C Contribution from graph III
8655         call transpose2(EUg(1,1,l),auxmat(1,1))
8656         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8657         vv(1)=pizda(1,1)-pizda(2,2)
8658         vv(2)=pizda(1,2)+pizda(2,1)
8659         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8661 C Explicit gradient in virtual-dihedral angles.
8662         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8663      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8664      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8665         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8666         vv(1)=pizda(1,1)-pizda(2,2)
8667         vv(2)=pizda(1,2)+pizda(2,1)
8668         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8669      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8670      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8671         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8672         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8673         vv(1)=pizda(1,1)-pizda(2,2)
8674         vv(2)=pizda(1,2)+pizda(2,1)
8675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8676      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8677      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8678 C Cartesian gradient
8679         do iii=1,2
8680           do kkk=1,5
8681             do lll=1,3
8682               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8683      &          pizda(1,1))
8684               vv(1)=pizda(1,1)-pizda(2,2)
8685               vv(2)=pizda(1,2)+pizda(2,1)
8686               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8687      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8688      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8689             enddo
8690           enddo
8691         enddo
8692 cd        goto 1112
8693 C Contribution from graph IV
8694 cd1110    continue
8695         call transpose2(EE(1,1,itl),auxmat(1,1))
8696         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8697         vv(1)=pizda(1,1)+pizda(2,2)
8698         vv(2)=pizda(2,1)-pizda(1,2)
8699         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8700      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8701 C Explicit gradient in virtual-dihedral angles.
8702         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8703      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8704         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8705         vv(1)=pizda(1,1)+pizda(2,2)
8706         vv(2)=pizda(2,1)-pizda(1,2)
8707         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8708      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8709      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8710 C Cartesian gradient
8711         do iii=1,2
8712           do kkk=1,5
8713             do lll=1,3
8714               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8715      &          pizda(1,1))
8716               vv(1)=pizda(1,1)+pizda(2,2)
8717               vv(2)=pizda(2,1)-pizda(1,2)
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8719      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8720      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8721             enddo
8722           enddo
8723         enddo
8724       else
8725 C Antiparallel orientation
8726 C Contribution from graph III
8727 c        goto 1110
8728         call transpose2(EUg(1,1,j),auxmat(1,1))
8729         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8730         vv(1)=pizda(1,1)-pizda(2,2)
8731         vv(2)=pizda(1,2)+pizda(2,1)
8732         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8734 C Explicit gradient in virtual-dihedral angles.
8735         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8736      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8737      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8738         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8739         vv(1)=pizda(1,1)-pizda(2,2)
8740         vv(2)=pizda(1,2)+pizda(2,1)
8741         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8742      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8743      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8744         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8745         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8746         vv(1)=pizda(1,1)-pizda(2,2)
8747         vv(2)=pizda(1,2)+pizda(2,1)
8748         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8749      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8750      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8751 C Cartesian gradient
8752         do iii=1,2
8753           do kkk=1,5
8754             do lll=1,3
8755               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8756      &          pizda(1,1))
8757               vv(1)=pizda(1,1)-pizda(2,2)
8758               vv(2)=pizda(1,2)+pizda(2,1)
8759               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8760      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8761      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8762             enddo
8763           enddo
8764         enddo
8765 cd        goto 1112
8766 C Contribution from graph IV
8767 1110    continue
8768         call transpose2(EE(1,1,itj),auxmat(1,1))
8769         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8770         vv(1)=pizda(1,1)+pizda(2,2)
8771         vv(2)=pizda(2,1)-pizda(1,2)
8772         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8773      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8774 C Explicit gradient in virtual-dihedral angles.
8775         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8776      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8777         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8778         vv(1)=pizda(1,1)+pizda(2,2)
8779         vv(2)=pizda(2,1)-pizda(1,2)
8780         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8781      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8782      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8783 C Cartesian gradient
8784         do iii=1,2
8785           do kkk=1,5
8786             do lll=1,3
8787               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8788      &          pizda(1,1))
8789               vv(1)=pizda(1,1)+pizda(2,2)
8790               vv(2)=pizda(2,1)-pizda(1,2)
8791               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8792      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8793      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8794             enddo
8795           enddo
8796         enddo
8797       endif
8798 1112  continue
8799       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8800 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8801 cd        write (2,*) 'ijkl',i,j,k,l
8802 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8803 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8804 cd      endif
8805 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8806 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8807 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8808 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8809       if (j.lt.nres-1) then
8810         j1=j+1
8811         j2=j-1
8812       else
8813         j1=j-1
8814         j2=j-2
8815       endif
8816       if (l.lt.nres-1) then
8817         l1=l+1
8818         l2=l-1
8819       else
8820         l1=l-1
8821         l2=l-2
8822       endif
8823 cd      eij=1.0d0
8824 cd      ekl=1.0d0
8825 cd      ekont=1.0d0
8826 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8827 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8828 C        summed up outside the subrouine as for the other subroutines
8829 C        handling long-range interactions. The old code is commented out
8830 C        with "cgrad" to keep track of changes.
8831       do ll=1,3
8832 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8833 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8834         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8835         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8836 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8837 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8838 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8839 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8840 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8841 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8842 c     &   gradcorr5ij,
8843 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8844 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8845 cgrad        ghalf=0.5d0*ggg1(ll)
8846 cd        ghalf=0.0d0
8847         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8848         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8849         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8850         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8851         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8852         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8853 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8854 cgrad        ghalf=0.5d0*ggg2(ll)
8855 cd        ghalf=0.0d0
8856         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8857         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8858         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8859         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8860         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8861         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8862       enddo
8863 cd      goto 1112
8864 cgrad      do m=i+1,j-1
8865 cgrad        do ll=1,3
8866 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8867 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8868 cgrad        enddo
8869 cgrad      enddo
8870 cgrad      do m=k+1,l-1
8871 cgrad        do ll=1,3
8872 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8873 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8874 cgrad        enddo
8875 cgrad      enddo
8876 c1112  continue
8877 cgrad      do m=i+2,j2
8878 cgrad        do ll=1,3
8879 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8880 cgrad        enddo
8881 cgrad      enddo
8882 cgrad      do m=k+2,l2
8883 cgrad        do ll=1,3
8884 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8885 cgrad        enddo
8886 cgrad      enddo
8887 cd      do iii=1,nres-3
8888 cd        write (2,*) iii,g_corr5_loc(iii)
8889 cd      enddo
8890       eello5=ekont*eel5
8891 cd      write (2,*) 'ekont',ekont
8892 cd      write (iout,*) 'eello5',ekont*eel5
8893       return
8894       end
8895 c--------------------------------------------------------------------------
8896       double precision function eello6(i,j,k,l,jj,kk)
8897       implicit real*8 (a-h,o-z)
8898       include 'DIMENSIONS'
8899       include 'COMMON.IOUNITS'
8900       include 'COMMON.CHAIN'
8901       include 'COMMON.DERIV'
8902       include 'COMMON.INTERACT'
8903       include 'COMMON.CONTACTS'
8904       include 'COMMON.TORSION'
8905       include 'COMMON.VAR'
8906       include 'COMMON.GEO'
8907       include 'COMMON.FFIELD'
8908       double precision ggg1(3),ggg2(3)
8909 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8910 cd        eello6=0.0d0
8911 cd        return
8912 cd      endif
8913 cd      write (iout,*)
8914 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8915 cd     &   ' and',k,l
8916       eello6_1=0.0d0
8917       eello6_2=0.0d0
8918       eello6_3=0.0d0
8919       eello6_4=0.0d0
8920       eello6_5=0.0d0
8921       eello6_6=0.0d0
8922 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8923 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8924       do iii=1,2
8925         do kkk=1,5
8926           do lll=1,3
8927             derx(lll,kkk,iii)=0.0d0
8928           enddo
8929         enddo
8930       enddo
8931 cd      eij=facont_hb(jj,i)
8932 cd      ekl=facont_hb(kk,k)
8933 cd      ekont=eij*ekl
8934 cd      eij=1.0d0
8935 cd      ekl=1.0d0
8936 cd      ekont=1.0d0
8937       if (l.eq.j+1) then
8938         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8939         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8940         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8941         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8942         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8943         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8944       else
8945         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8946         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8947         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8948         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8949         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8950           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8951         else
8952           eello6_5=0.0d0
8953         endif
8954         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8955       endif
8956 C If turn contributions are considered, they will be handled separately.
8957       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8958 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8959 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8960 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8961 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8962 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8963 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8964 cd      goto 1112
8965       if (j.lt.nres-1) then
8966         j1=j+1
8967         j2=j-1
8968       else
8969         j1=j-1
8970         j2=j-2
8971       endif
8972       if (l.lt.nres-1) then
8973         l1=l+1
8974         l2=l-1
8975       else
8976         l1=l-1
8977         l2=l-2
8978       endif
8979       do ll=1,3
8980 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8981 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8982 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8983 cgrad        ghalf=0.5d0*ggg1(ll)
8984 cd        ghalf=0.0d0
8985         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8986         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8987         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8988         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8989         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8990         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8991         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8992         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8993 cgrad        ghalf=0.5d0*ggg2(ll)
8994 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8995 cd        ghalf=0.0d0
8996         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8997         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8998         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8999         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9000         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9001         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9002       enddo
9003 cd      goto 1112
9004 cgrad      do m=i+1,j-1
9005 cgrad        do ll=1,3
9006 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9007 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9008 cgrad        enddo
9009 cgrad      enddo
9010 cgrad      do m=k+1,l-1
9011 cgrad        do ll=1,3
9012 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9013 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9014 cgrad        enddo
9015 cgrad      enddo
9016 cgrad1112  continue
9017 cgrad      do m=i+2,j2
9018 cgrad        do ll=1,3
9019 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9020 cgrad        enddo
9021 cgrad      enddo
9022 cgrad      do m=k+2,l2
9023 cgrad        do ll=1,3
9024 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9025 cgrad        enddo
9026 cgrad      enddo
9027 cd      do iii=1,nres-3
9028 cd        write (2,*) iii,g_corr6_loc(iii)
9029 cd      enddo
9030       eello6=ekont*eel6
9031 cd      write (2,*) 'ekont',ekont
9032 cd      write (iout,*) 'eello6',ekont*eel6
9033       return
9034       end
9035 c--------------------------------------------------------------------------
9036       double precision function eello6_graph1(i,j,k,l,imat,swap)
9037       implicit real*8 (a-h,o-z)
9038       include 'DIMENSIONS'
9039       include 'COMMON.IOUNITS'
9040       include 'COMMON.CHAIN'
9041       include 'COMMON.DERIV'
9042       include 'COMMON.INTERACT'
9043       include 'COMMON.CONTACTS'
9044       include 'COMMON.TORSION'
9045       include 'COMMON.VAR'
9046       include 'COMMON.GEO'
9047       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9048       logical swap
9049       logical lprn
9050       common /kutas/ lprn
9051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9052 C                                                                              C
9053 C      Parallel       Antiparallel                                             C
9054 C                                                                              C
9055 C          o             o                                                     C
9056 C         /l\           /j\                                                    C
9057 C        /   \         /   \                                                   C
9058 C       /| o |         | o |\                                                  C
9059 C     \ j|/k\|  /   \  |/k\|l /                                                C
9060 C      \ /   \ /     \ /   \ /                                                 C
9061 C       o     o       o     o                                                  C
9062 C       i             i                                                        C
9063 C                                                                              C
9064 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9065       itk=itortyp(itype(k))
9066       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9067       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9068       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9069       call transpose2(EUgC(1,1,k),auxmat(1,1))
9070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9071       vv1(1)=pizda1(1,1)-pizda1(2,2)
9072       vv1(2)=pizda1(1,2)+pizda1(2,1)
9073       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9074       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9075       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9076       s5=scalar2(vv(1),Dtobr2(1,i))
9077 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9078       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9079       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9080      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9081      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9082      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9083      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9084      & +scalar2(vv(1),Dtobr2der(1,i)))
9085       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9086       vv1(1)=pizda1(1,1)-pizda1(2,2)
9087       vv1(2)=pizda1(1,2)+pizda1(2,1)
9088       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9089       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9090       if (l.eq.j+1) then
9091         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9092      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9093      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9094      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9095      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9096       else
9097         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9098      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9099      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9100      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9101      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9102       endif
9103       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9104       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9105       vv1(1)=pizda1(1,1)-pizda1(2,2)
9106       vv1(2)=pizda1(1,2)+pizda1(2,1)
9107       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9108      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9109      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9110      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9111       do iii=1,2
9112         if (swap) then
9113           ind=3-iii
9114         else
9115           ind=iii
9116         endif
9117         do kkk=1,5
9118           do lll=1,3
9119             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9120             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9121             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9122             call transpose2(EUgC(1,1,k),auxmat(1,1))
9123             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9124      &        pizda1(1,1))
9125             vv1(1)=pizda1(1,1)-pizda1(2,2)
9126             vv1(2)=pizda1(1,2)+pizda1(2,1)
9127             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9128             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9129      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9130             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9131      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9132             s5=scalar2(vv(1),Dtobr2(1,i))
9133             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9134           enddo
9135         enddo
9136       enddo
9137       return
9138       end
9139 c----------------------------------------------------------------------------
9140       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9141       implicit real*8 (a-h,o-z)
9142       include 'DIMENSIONS'
9143       include 'COMMON.IOUNITS'
9144       include 'COMMON.CHAIN'
9145       include 'COMMON.DERIV'
9146       include 'COMMON.INTERACT'
9147       include 'COMMON.CONTACTS'
9148       include 'COMMON.TORSION'
9149       include 'COMMON.VAR'
9150       include 'COMMON.GEO'
9151       logical swap
9152       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9153      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9154       logical lprn
9155       common /kutas/ lprn
9156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9157 C                                                                              C
9158 C      Parallel       Antiparallel                                             C
9159 C                                                                              C
9160 C          o             o                                                     C
9161 C     \   /l\           /j\   /                                                C
9162 C      \ /   \         /   \ /                                                 C
9163 C       o| o |         | o |o                                                  C
9164 C     \ j|/k\|      \  |/k\|l                                                  C
9165 C      \ /   \       \ /   \                                                   C
9166 C       o             o                                                        C
9167 C       i             i                                                        C
9168 C                                                                              C
9169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9170 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9171 C AL 7/4/01 s1 would occur in the sixth-order moment,
9172 C           but not in a cluster cumulant
9173 #ifdef MOMENT
9174       s1=dip(1,jj,i)*dip(1,kk,k)
9175 #endif
9176       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9177       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9178       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9179       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9180       call transpose2(EUg(1,1,k),auxmat(1,1))
9181       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9182       vv(1)=pizda(1,1)-pizda(2,2)
9183       vv(2)=pizda(1,2)+pizda(2,1)
9184       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9185 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9186 #ifdef MOMENT
9187       eello6_graph2=-(s1+s2+s3+s4)
9188 #else
9189       eello6_graph2=-(s2+s3+s4)
9190 #endif
9191 c      eello6_graph2=-s3
9192 C Derivatives in gamma(i-1)
9193       if (i.gt.1) then
9194 #ifdef MOMENT
9195         s1=dipderg(1,jj,i)*dip(1,kk,k)
9196 #endif
9197         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9198         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9199         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9200         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9201 #ifdef MOMENT
9202         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9203 #else
9204         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9205 #endif
9206 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9207       endif
9208 C Derivatives in gamma(k-1)
9209 #ifdef MOMENT
9210       s1=dip(1,jj,i)*dipderg(1,kk,k)
9211 #endif
9212       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9213       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9214       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9215       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9216       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9217       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9218       vv(1)=pizda(1,1)-pizda(2,2)
9219       vv(2)=pizda(1,2)+pizda(2,1)
9220       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9221 #ifdef MOMENT
9222       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9223 #else
9224       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9225 #endif
9226 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9227 C Derivatives in gamma(j-1) or gamma(l-1)
9228       if (j.gt.1) then
9229 #ifdef MOMENT
9230         s1=dipderg(3,jj,i)*dip(1,kk,k)
9231 #endif
9232         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9233         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9234         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9235         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9236         vv(1)=pizda(1,1)-pizda(2,2)
9237         vv(2)=pizda(1,2)+pizda(2,1)
9238         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9239 #ifdef MOMENT
9240         if (swap) then
9241           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9242         else
9243           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9244         endif
9245 #endif
9246         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9247 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9248       endif
9249 C Derivatives in gamma(l-1) or gamma(j-1)
9250       if (l.gt.1) then
9251 #ifdef MOMENT
9252         s1=dip(1,jj,i)*dipderg(3,kk,k)
9253 #endif
9254         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9255         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9256         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9257         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9258         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9259         vv(1)=pizda(1,1)-pizda(2,2)
9260         vv(2)=pizda(1,2)+pizda(2,1)
9261         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9262 #ifdef MOMENT
9263         if (swap) then
9264           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9265         else
9266           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9267         endif
9268 #endif
9269         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9270 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9271       endif
9272 C Cartesian derivatives.
9273       if (lprn) then
9274         write (2,*) 'In eello6_graph2'
9275         do iii=1,2
9276           write (2,*) 'iii=',iii
9277           do kkk=1,5
9278             write (2,*) 'kkk=',kkk
9279             do jjj=1,2
9280               write (2,'(3(2f10.5),5x)')
9281      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9282             enddo
9283           enddo
9284         enddo
9285       endif
9286       do iii=1,2
9287         do kkk=1,5
9288           do lll=1,3
9289 #ifdef MOMENT
9290             if (iii.eq.1) then
9291               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9292             else
9293               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9294             endif
9295 #endif
9296             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9297      &        auxvec(1))
9298             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9299             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9300      &        auxvec(1))
9301             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9302             call transpose2(EUg(1,1,k),auxmat(1,1))
9303             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9304      &        pizda(1,1))
9305             vv(1)=pizda(1,1)-pizda(2,2)
9306             vv(2)=pizda(1,2)+pizda(2,1)
9307             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9308 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9309 #ifdef MOMENT
9310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9311 #else
9312             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9313 #endif
9314             if (swap) then
9315               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9316             else
9317               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9318             endif
9319           enddo
9320         enddo
9321       enddo
9322       return
9323       end
9324 c----------------------------------------------------------------------------
9325       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9326       implicit real*8 (a-h,o-z)
9327       include 'DIMENSIONS'
9328       include 'COMMON.IOUNITS'
9329       include 'COMMON.CHAIN'
9330       include 'COMMON.DERIV'
9331       include 'COMMON.INTERACT'
9332       include 'COMMON.CONTACTS'
9333       include 'COMMON.TORSION'
9334       include 'COMMON.VAR'
9335       include 'COMMON.GEO'
9336       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9337       logical swap
9338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9339 C                                                                              C
9340 C      Parallel       Antiparallel                                             C
9341 C                                                                              C
9342 C          o             o                                                     C
9343 C         /l\   /   \   /j\                                                    C
9344 C        /   \ /     \ /   \                                                   C
9345 C       /| o |o       o| o |\                                                  C
9346 C       j|/k\|  /      |/k\|l /                                                C
9347 C        /   \ /       /   \ /                                                 C
9348 C       /     o       /     o                                                  C
9349 C       i             i                                                        C
9350 C                                                                              C
9351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9352 C
9353 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9354 C           energy moment and not to the cluster cumulant.
9355       iti=itortyp(itype(i))
9356       if (j.lt.nres-1) then
9357         itj1=itortyp(itype(j+1))
9358       else
9359         itj1=ntortyp
9360       endif
9361       itk=itortyp(itype(k))
9362       itk1=itortyp(itype(k+1))
9363       if (l.lt.nres-1) then
9364         itl1=itortyp(itype(l+1))
9365       else
9366         itl1=ntortyp
9367       endif
9368 #ifdef MOMENT
9369       s1=dip(4,jj,i)*dip(4,kk,k)
9370 #endif
9371       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9372       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9373       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9374       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9375       call transpose2(EE(1,1,itk),auxmat(1,1))
9376       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9377       vv(1)=pizda(1,1)+pizda(2,2)
9378       vv(2)=pizda(2,1)-pizda(1,2)
9379       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9380 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9381 cd     & "sum",-(s2+s3+s4)
9382 #ifdef MOMENT
9383       eello6_graph3=-(s1+s2+s3+s4)
9384 #else
9385       eello6_graph3=-(s2+s3+s4)
9386 #endif
9387 c      eello6_graph3=-s4
9388 C Derivatives in gamma(k-1)
9389       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9390       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9391       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9392       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9393 C Derivatives in gamma(l-1)
9394       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9395       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9396       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9397       vv(1)=pizda(1,1)+pizda(2,2)
9398       vv(2)=pizda(2,1)-pizda(1,2)
9399       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9400       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9401 C Cartesian derivatives.
9402       do iii=1,2
9403         do kkk=1,5
9404           do lll=1,3
9405 #ifdef MOMENT
9406             if (iii.eq.1) then
9407               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9408             else
9409               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9410             endif
9411 #endif
9412             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9413      &        auxvec(1))
9414             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9415             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9416      &        auxvec(1))
9417             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9418             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9419      &        pizda(1,1))
9420             vv(1)=pizda(1,1)+pizda(2,2)
9421             vv(2)=pizda(2,1)-pizda(1,2)
9422             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9423 #ifdef MOMENT
9424             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9425 #else
9426             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9427 #endif
9428             if (swap) then
9429               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9430             else
9431               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9432             endif
9433 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9434           enddo
9435         enddo
9436       enddo
9437       return
9438       end
9439 c----------------------------------------------------------------------------
9440       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9441       implicit real*8 (a-h,o-z)
9442       include 'DIMENSIONS'
9443       include 'COMMON.IOUNITS'
9444       include 'COMMON.CHAIN'
9445       include 'COMMON.DERIV'
9446       include 'COMMON.INTERACT'
9447       include 'COMMON.CONTACTS'
9448       include 'COMMON.TORSION'
9449       include 'COMMON.VAR'
9450       include 'COMMON.GEO'
9451       include 'COMMON.FFIELD'
9452       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9453      & auxvec1(2),auxmat1(2,2)
9454       logical swap
9455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9456 C                                                                              C
9457 C      Parallel       Antiparallel                                             C
9458 C                                                                              C
9459 C          o             o                                                     C
9460 C         /l\   /   \   /j\                                                    C
9461 C        /   \ /     \ /   \                                                   C
9462 C       /| o |o       o| o |\                                                  C
9463 C     \ j|/k\|      \  |/k\|l                                                  C
9464 C      \ /   \       \ /   \                                                   C
9465 C       o     \       o     \                                                  C
9466 C       i             i                                                        C
9467 C                                                                              C
9468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9469 C
9470 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9471 C           energy moment and not to the cluster cumulant.
9472 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9473       iti=itortyp(itype(i))
9474       itj=itortyp(itype(j))
9475       if (j.lt.nres-1) then
9476         itj1=itortyp(itype(j+1))
9477       else
9478         itj1=ntortyp
9479       endif
9480       itk=itortyp(itype(k))
9481       if (k.lt.nres-1) then
9482         itk1=itortyp(itype(k+1))
9483       else
9484         itk1=ntortyp
9485       endif
9486       itl=itortyp(itype(l))
9487       if (l.lt.nres-1) then
9488         itl1=itortyp(itype(l+1))
9489       else
9490         itl1=ntortyp
9491       endif
9492 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9493 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9494 cd     & ' itl',itl,' itl1',itl1
9495 #ifdef MOMENT
9496       if (imat.eq.1) then
9497         s1=dip(3,jj,i)*dip(3,kk,k)
9498       else
9499         s1=dip(2,jj,j)*dip(2,kk,l)
9500       endif
9501 #endif
9502       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9503       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9504       if (j.eq.l+1) then
9505         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9506         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9507       else
9508         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9509         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9510       endif
9511       call transpose2(EUg(1,1,k),auxmat(1,1))
9512       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9513       vv(1)=pizda(1,1)-pizda(2,2)
9514       vv(2)=pizda(2,1)+pizda(1,2)
9515       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9516 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9517 #ifdef MOMENT
9518       eello6_graph4=-(s1+s2+s3+s4)
9519 #else
9520       eello6_graph4=-(s2+s3+s4)
9521 #endif
9522 C Derivatives in gamma(i-1)
9523       if (i.gt.1) then
9524 #ifdef MOMENT
9525         if (imat.eq.1) then
9526           s1=dipderg(2,jj,i)*dip(3,kk,k)
9527         else
9528           s1=dipderg(4,jj,j)*dip(2,kk,l)
9529         endif
9530 #endif
9531         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9532         if (j.eq.l+1) then
9533           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9534           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9535         else
9536           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9537           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9538         endif
9539         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9540         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9541 cd          write (2,*) 'turn6 derivatives'
9542 #ifdef MOMENT
9543           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9544 #else
9545           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9546 #endif
9547         else
9548 #ifdef MOMENT
9549           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9550 #else
9551           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9552 #endif
9553         endif
9554       endif
9555 C Derivatives in gamma(k-1)
9556 #ifdef MOMENT
9557       if (imat.eq.1) then
9558         s1=dip(3,jj,i)*dipderg(2,kk,k)
9559       else
9560         s1=dip(2,jj,j)*dipderg(4,kk,l)
9561       endif
9562 #endif
9563       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9564       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9565       if (j.eq.l+1) then
9566         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9567         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9568       else
9569         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9570         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9571       endif
9572       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9573       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9574       vv(1)=pizda(1,1)-pizda(2,2)
9575       vv(2)=pizda(2,1)+pizda(1,2)
9576       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9577       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9578 #ifdef MOMENT
9579         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9580 #else
9581         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9582 #endif
9583       else
9584 #ifdef MOMENT
9585         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9586 #else
9587         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9588 #endif
9589       endif
9590 C Derivatives in gamma(j-1) or gamma(l-1)
9591       if (l.eq.j+1 .and. l.gt.1) then
9592         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9593         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9594         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9595         vv(1)=pizda(1,1)-pizda(2,2)
9596         vv(2)=pizda(2,1)+pizda(1,2)
9597         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9598         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9599       else if (j.gt.1) then
9600         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9601         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9602         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9603         vv(1)=pizda(1,1)-pizda(2,2)
9604         vv(2)=pizda(2,1)+pizda(1,2)
9605         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9606         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9607           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9608         else
9609           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9610         endif
9611       endif
9612 C Cartesian derivatives.
9613       do iii=1,2
9614         do kkk=1,5
9615           do lll=1,3
9616 #ifdef MOMENT
9617             if (iii.eq.1) then
9618               if (imat.eq.1) then
9619                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9620               else
9621                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9622               endif
9623             else
9624               if (imat.eq.1) then
9625                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9626               else
9627                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9628               endif
9629             endif
9630 #endif
9631             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9632      &        auxvec(1))
9633             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9634             if (j.eq.l+1) then
9635               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9636      &          b1(1,j+1),auxvec(1))
9637               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9638             else
9639               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9640      &          b1(1,l+1),auxvec(1))
9641               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9642             endif
9643             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9644      &        pizda(1,1))
9645             vv(1)=pizda(1,1)-pizda(2,2)
9646             vv(2)=pizda(2,1)+pizda(1,2)
9647             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9648             if (swap) then
9649               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9650 #ifdef MOMENT
9651                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9652      &             -(s1+s2+s4)
9653 #else
9654                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9655      &             -(s2+s4)
9656 #endif
9657                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9658               else
9659 #ifdef MOMENT
9660                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9661 #else
9662                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9663 #endif
9664                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9665               endif
9666             else
9667 #ifdef MOMENT
9668               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9669 #else
9670               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9671 #endif
9672               if (l.eq.j+1) then
9673                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9674               else
9675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9676               endif
9677             endif
9678           enddo
9679         enddo
9680       enddo
9681       return
9682       end
9683 c----------------------------------------------------------------------------
9684       double precision function eello_turn6(i,jj,kk)
9685       implicit real*8 (a-h,o-z)
9686       include 'DIMENSIONS'
9687       include 'COMMON.IOUNITS'
9688       include 'COMMON.CHAIN'
9689       include 'COMMON.DERIV'
9690       include 'COMMON.INTERACT'
9691       include 'COMMON.CONTACTS'
9692       include 'COMMON.TORSION'
9693       include 'COMMON.VAR'
9694       include 'COMMON.GEO'
9695       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9696      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9697      &  ggg1(3),ggg2(3)
9698       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9699      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9700 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9701 C           the respective energy moment and not to the cluster cumulant.
9702       s1=0.0d0
9703       s8=0.0d0
9704       s13=0.0d0
9705 c
9706       eello_turn6=0.0d0
9707       j=i+4
9708       k=i+1
9709       l=i+3
9710       iti=itortyp(itype(i))
9711       itk=itortyp(itype(k))
9712       itk1=itortyp(itype(k+1))
9713       itl=itortyp(itype(l))
9714       itj=itortyp(itype(j))
9715 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9716 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9717 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9718 cd        eello6=0.0d0
9719 cd        return
9720 cd      endif
9721 cd      write (iout,*)
9722 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9723 cd     &   ' and',k,l
9724 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9725       do iii=1,2
9726         do kkk=1,5
9727           do lll=1,3
9728             derx_turn(lll,kkk,iii)=0.0d0
9729           enddo
9730         enddo
9731       enddo
9732 cd      eij=1.0d0
9733 cd      ekl=1.0d0
9734 cd      ekont=1.0d0
9735       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9736 cd      eello6_5=0.0d0
9737 cd      write (2,*) 'eello6_5',eello6_5
9738 #ifdef MOMENT
9739       call transpose2(AEA(1,1,1),auxmat(1,1))
9740       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9741       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9742       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9743 #endif
9744       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9745       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9746       s2 = scalar2(b1(1,k),vtemp1(1))
9747 #ifdef MOMENT
9748       call transpose2(AEA(1,1,2),atemp(1,1))
9749       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9750       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9751       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9752 #endif
9753       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9754       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9755       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9756 #ifdef MOMENT
9757       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9758       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9759       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9760       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9761       ss13 = scalar2(b1(1,k),vtemp4(1))
9762       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9763 #endif
9764 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9765 c      s1=0.0d0
9766 c      s2=0.0d0
9767 c      s8=0.0d0
9768 c      s12=0.0d0
9769 c      s13=0.0d0
9770       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9771 C Derivatives in gamma(i+2)
9772       s1d =0.0d0
9773       s8d =0.0d0
9774 #ifdef MOMENT
9775       call transpose2(AEA(1,1,1),auxmatd(1,1))
9776       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9777       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9778       call transpose2(AEAderg(1,1,2),atempd(1,1))
9779       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9780       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9781 #endif
9782       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9783       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9784       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9785 c      s1d=0.0d0
9786 c      s2d=0.0d0
9787 c      s8d=0.0d0
9788 c      s12d=0.0d0
9789 c      s13d=0.0d0
9790       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9791 C Derivatives in gamma(i+3)
9792 #ifdef MOMENT
9793       call transpose2(AEA(1,1,1),auxmatd(1,1))
9794       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9795       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9796       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9797 #endif
9798       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9799       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9800       s2d = scalar2(b1(1,k),vtemp1d(1))
9801 #ifdef MOMENT
9802       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9803       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9804 #endif
9805       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9806 #ifdef MOMENT
9807       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9808       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9809       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9810 #endif
9811 c      s1d=0.0d0
9812 c      s2d=0.0d0
9813 c      s8d=0.0d0
9814 c      s12d=0.0d0
9815 c      s13d=0.0d0
9816 #ifdef MOMENT
9817       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9818      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9819 #else
9820       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9821      &               -0.5d0*ekont*(s2d+s12d)
9822 #endif
9823 C Derivatives in gamma(i+4)
9824       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9825       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9826       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9827 #ifdef MOMENT
9828       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9829       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9830       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9831 #endif
9832 c      s1d=0.0d0
9833 c      s2d=0.0d0
9834 c      s8d=0.0d0
9835 C      s12d=0.0d0
9836 c      s13d=0.0d0
9837 #ifdef MOMENT
9838       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9839 #else
9840       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9841 #endif
9842 C Derivatives in gamma(i+5)
9843 #ifdef MOMENT
9844       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9845       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9847 #endif
9848       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9849       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9850       s2d = scalar2(b1(1,k),vtemp1d(1))
9851 #ifdef MOMENT
9852       call transpose2(AEA(1,1,2),atempd(1,1))
9853       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9854       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9855 #endif
9856       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9857       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9858 #ifdef MOMENT
9859       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9860       ss13d = scalar2(b1(1,k),vtemp4d(1))
9861       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9862 #endif
9863 c      s1d=0.0d0
9864 c      s2d=0.0d0
9865 c      s8d=0.0d0
9866 c      s12d=0.0d0
9867 c      s13d=0.0d0
9868 #ifdef MOMENT
9869       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9870      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9871 #else
9872       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9873      &               -0.5d0*ekont*(s2d+s12d)
9874 #endif
9875 C Cartesian derivatives
9876       do iii=1,2
9877         do kkk=1,5
9878           do lll=1,3
9879 #ifdef MOMENT
9880             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9881             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9882             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9883 #endif
9884             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9885             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9886      &          vtemp1d(1))
9887             s2d = scalar2(b1(1,k),vtemp1d(1))
9888 #ifdef MOMENT
9889             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9890             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9891             s8d = -(atempd(1,1)+atempd(2,2))*
9892      &           scalar2(cc(1,1,itl),vtemp2(1))
9893 #endif
9894             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9895      &           auxmatd(1,1))
9896             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9897             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9898 c      s1d=0.0d0
9899 c      s2d=0.0d0
9900 c      s8d=0.0d0
9901 c      s12d=0.0d0
9902 c      s13d=0.0d0
9903 #ifdef MOMENT
9904             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9905      &        - 0.5d0*(s1d+s2d)
9906 #else
9907             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9908      &        - 0.5d0*s2d
9909 #endif
9910 #ifdef MOMENT
9911             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9912      &        - 0.5d0*(s8d+s12d)
9913 #else
9914             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9915      &        - 0.5d0*s12d
9916 #endif
9917           enddo
9918         enddo
9919       enddo
9920 #ifdef MOMENT
9921       do kkk=1,5
9922         do lll=1,3
9923           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9924      &      achuj_tempd(1,1))
9925           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9926           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9927           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9928           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9929           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9930      &      vtemp4d(1))
9931           ss13d = scalar2(b1(1,k),vtemp4d(1))
9932           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9933           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9934         enddo
9935       enddo
9936 #endif
9937 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9938 cd     &  16*eel_turn6_num
9939 cd      goto 1112
9940       if (j.lt.nres-1) then
9941         j1=j+1
9942         j2=j-1
9943       else
9944         j1=j-1
9945         j2=j-2
9946       endif
9947       if (l.lt.nres-1) then
9948         l1=l+1
9949         l2=l-1
9950       else
9951         l1=l-1
9952         l2=l-2
9953       endif
9954       do ll=1,3
9955 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9956 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9957 cgrad        ghalf=0.5d0*ggg1(ll)
9958 cd        ghalf=0.0d0
9959         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9960         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9961         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9962      &    +ekont*derx_turn(ll,2,1)
9963         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9964         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9965      &    +ekont*derx_turn(ll,4,1)
9966         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9967         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9968         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9969 cgrad        ghalf=0.5d0*ggg2(ll)
9970 cd        ghalf=0.0d0
9971         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9972      &    +ekont*derx_turn(ll,2,2)
9973         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9974         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9975      &    +ekont*derx_turn(ll,4,2)
9976         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9977         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9978         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9979       enddo
9980 cd      goto 1112
9981 cgrad      do m=i+1,j-1
9982 cgrad        do ll=1,3
9983 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9984 cgrad        enddo
9985 cgrad      enddo
9986 cgrad      do m=k+1,l-1
9987 cgrad        do ll=1,3
9988 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9989 cgrad        enddo
9990 cgrad      enddo
9991 cgrad1112  continue
9992 cgrad      do m=i+2,j2
9993 cgrad        do ll=1,3
9994 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9995 cgrad        enddo
9996 cgrad      enddo
9997 cgrad      do m=k+2,l2
9998 cgrad        do ll=1,3
9999 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10000 cgrad        enddo
10001 cgrad      enddo
10002 cd      do iii=1,nres-3
10003 cd        write (2,*) iii,g_corr6_loc(iii)
10004 cd      enddo
10005       eello_turn6=ekont*eel_turn6
10006 cd      write (2,*) 'ekont',ekont
10007 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10008       return
10009       end
10010
10011 C-----------------------------------------------------------------------------
10012       double precision function scalar(u,v)
10013 !DIR$ INLINEALWAYS scalar
10014 #ifndef OSF
10015 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10016 #endif
10017       implicit none
10018       double precision u(3),v(3)
10019 cd      double precision sc
10020 cd      integer i
10021 cd      sc=0.0d0
10022 cd      do i=1,3
10023 cd        sc=sc+u(i)*v(i)
10024 cd      enddo
10025 cd      scalar=sc
10026
10027       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10028       return
10029       end
10030 crc-------------------------------------------------
10031       SUBROUTINE MATVEC2(A1,V1,V2)
10032 !DIR$ INLINEALWAYS MATVEC2
10033 #ifndef OSF
10034 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10035 #endif
10036       implicit real*8 (a-h,o-z)
10037       include 'DIMENSIONS'
10038       DIMENSION A1(2,2),V1(2),V2(2)
10039 c      DO 1 I=1,2
10040 c        VI=0.0
10041 c        DO 3 K=1,2
10042 c    3     VI=VI+A1(I,K)*V1(K)
10043 c        Vaux(I)=VI
10044 c    1 CONTINUE
10045
10046       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10047       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10048
10049       v2(1)=vaux1
10050       v2(2)=vaux2
10051       END
10052 C---------------------------------------
10053       SUBROUTINE MATMAT2(A1,A2,A3)
10054 #ifndef OSF
10055 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10056 #endif
10057       implicit real*8 (a-h,o-z)
10058       include 'DIMENSIONS'
10059       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10060 c      DIMENSION AI3(2,2)
10061 c        DO  J=1,2
10062 c          A3IJ=0.0
10063 c          DO K=1,2
10064 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10065 c          enddo
10066 c          A3(I,J)=A3IJ
10067 c       enddo
10068 c      enddo
10069
10070       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10071       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10072       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10073       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10074
10075       A3(1,1)=AI3_11
10076       A3(2,1)=AI3_21
10077       A3(1,2)=AI3_12
10078       A3(2,2)=AI3_22
10079       END
10080
10081 c-------------------------------------------------------------------------
10082       double precision function scalar2(u,v)
10083 !DIR$ INLINEALWAYS scalar2
10084       implicit none
10085       double precision u(2),v(2)
10086       double precision sc
10087       integer i
10088       scalar2=u(1)*v(1)+u(2)*v(2)
10089       return
10090       end
10091
10092 C-----------------------------------------------------------------------------
10093
10094       subroutine transpose2(a,at)
10095 !DIR$ INLINEALWAYS transpose2
10096 #ifndef OSF
10097 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10098 #endif
10099       implicit none
10100       double precision a(2,2),at(2,2)
10101       at(1,1)=a(1,1)
10102       at(1,2)=a(2,1)
10103       at(2,1)=a(1,2)
10104       at(2,2)=a(2,2)
10105       return
10106       end
10107 c--------------------------------------------------------------------------
10108       subroutine transpose(n,a,at)
10109       implicit none
10110       integer n,i,j
10111       double precision a(n,n),at(n,n)
10112       do i=1,n
10113         do j=1,n
10114           at(j,i)=a(i,j)
10115         enddo
10116       enddo
10117       return
10118       end
10119 C---------------------------------------------------------------------------
10120       subroutine prodmat3(a1,a2,kk,transp,prod)
10121 !DIR$ INLINEALWAYS prodmat3
10122 #ifndef OSF
10123 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10124 #endif
10125       implicit none
10126       integer i,j
10127       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10128       logical transp
10129 crc      double precision auxmat(2,2),prod_(2,2)
10130
10131       if (transp) then
10132 crc        call transpose2(kk(1,1),auxmat(1,1))
10133 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10134 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10135
10136            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10137      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10138            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10139      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10140            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10141      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10142            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10143      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10144
10145       else
10146 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10147 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10148
10149            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10150      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10151            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10152      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10153            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10154      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10155            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10156      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10157
10158       endif
10159 c      call transpose2(a2(1,1),a2t(1,1))
10160
10161 crc      print *,transp
10162 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10163 crc      print *,((prod(i,j),i=1,2),j=1,2)
10164
10165       return
10166       end
10167 CCC----------------------------------------------
10168       subroutine Eliptransfer(eliptran)
10169       implicit real*8 (a-h,o-z)
10170       include 'DIMENSIONS'
10171       include 'COMMON.GEO'
10172       include 'COMMON.VAR'
10173       include 'COMMON.LOCAL'
10174       include 'COMMON.CHAIN'
10175       include 'COMMON.DERIV'
10176       include 'COMMON.NAMES'
10177       include 'COMMON.INTERACT'
10178       include 'COMMON.IOUNITS'
10179       include 'COMMON.CALC'
10180       include 'COMMON.CONTROL'
10181       include 'COMMON.SPLITELE'
10182       include 'COMMON.SBRIDGE'
10183 C this is done by Adasko
10184 C      print *,"wchodze"
10185 C structure of box:
10186 C      water
10187 C--bordliptop-- buffore starts
10188 C--bufliptop--- here true lipid starts
10189 C      lipid
10190 C--buflipbot--- lipid ends buffore starts
10191 C--bordlipbot--buffore ends
10192       eliptran=0.0
10193       do i=ilip_start,ilip_end
10194 C       do i=1,1
10195         if (itype(i).eq.ntyp1) cycle
10196
10197         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10198         if (positi.le.0) positi=positi+boxzsize
10199 C        print *,i
10200 C first for peptide groups
10201 c for each residue check if it is in lipid or lipid water border area
10202        if ((positi.gt.bordlipbot)
10203      &.and.(positi.lt.bordliptop)) then
10204 C the energy transfer exist
10205         if (positi.lt.buflipbot) then
10206 C what fraction I am in
10207          fracinbuf=1.0d0-
10208      &        ((positi-bordlipbot)/lipbufthick)
10209 C lipbufthick is thickenes of lipid buffore
10210          sslip=sscalelip(fracinbuf)
10211          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10212          eliptran=eliptran+sslip*pepliptran
10213          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10214          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10215 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10216
10217 C        print *,"doing sccale for lower part"
10218 C         print *,i,sslip,fracinbuf,ssgradlip
10219         elseif (positi.gt.bufliptop) then
10220          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10221          sslip=sscalelip(fracinbuf)
10222          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10223          eliptran=eliptran+sslip*pepliptran
10224          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10225          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10226 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10227 C          print *, "doing sscalefor top part"
10228 C         print *,i,sslip,fracinbuf,ssgradlip
10229         else
10230          eliptran=eliptran+pepliptran
10231 C         print *,"I am in true lipid"
10232         endif
10233 C       else
10234 C       eliptran=elpitran+0.0 ! I am in water
10235        endif
10236        enddo
10237 C       print *, "nic nie bylo w lipidzie?"
10238 C now multiply all by the peptide group transfer factor
10239 C       eliptran=eliptran*pepliptran
10240 C now the same for side chains
10241 CV       do i=1,1
10242        do i=ilip_start,ilip_end
10243         if (itype(i).eq.ntyp1) cycle
10244         positi=(mod(c(3,i+nres),boxzsize))
10245         if (positi.le.0) positi=positi+boxzsize
10246 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10247 c for each residue check if it is in lipid or lipid water border area
10248 C       respos=mod(c(3,i+nres),boxzsize)
10249 C       print *,positi,bordlipbot,buflipbot
10250        if ((positi.gt.bordlipbot)
10251      & .and.(positi.lt.bordliptop)) then
10252 C the energy transfer exist
10253         if (positi.lt.buflipbot) then
10254          fracinbuf=1.0d0-
10255      &     ((positi-bordlipbot)/lipbufthick)
10256 C lipbufthick is thickenes of lipid buffore
10257          sslip=sscalelip(fracinbuf)
10258          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10259          eliptran=eliptran+sslip*liptranene(itype(i))
10260          gliptranx(3,i)=gliptranx(3,i)
10261      &+ssgradlip*liptranene(itype(i))
10262          gliptranc(3,i-1)= gliptranc(3,i-1)
10263      &+ssgradlip*liptranene(itype(i))
10264 C         print *,"doing sccale for lower part"
10265         elseif (positi.gt.bufliptop) then
10266          fracinbuf=1.0d0-
10267      &((bordliptop-positi)/lipbufthick)
10268          sslip=sscalelip(fracinbuf)
10269          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10270          eliptran=eliptran+sslip*liptranene(itype(i))
10271          gliptranx(3,i)=gliptranx(3,i)
10272      &+ssgradlip*liptranene(itype(i))
10273          gliptranc(3,i-1)= gliptranc(3,i-1)
10274      &+ssgradlip*liptranene(itype(i))
10275 C          print *, "doing sscalefor top part",sslip,fracinbuf
10276         else
10277          eliptran=eliptran+liptranene(itype(i))
10278 C         print *,"I am in true lipid"
10279         endif
10280         endif ! if in lipid or buffor
10281 C       else
10282 C       eliptran=elpitran+0.0 ! I am in water
10283        enddo
10284        return
10285        end
10286 C---------------------------------------------------------
10287 C AFM soubroutine for constant force
10288        subroutine AFMforce(Eafmforce)
10289        implicit real*8 (a-h,o-z)
10290       include 'DIMENSIONS'
10291       include 'COMMON.GEO'
10292       include 'COMMON.VAR'
10293       include 'COMMON.LOCAL'
10294       include 'COMMON.CHAIN'
10295       include 'COMMON.DERIV'
10296       include 'COMMON.NAMES'
10297       include 'COMMON.INTERACT'
10298       include 'COMMON.IOUNITS'
10299       include 'COMMON.CALC'
10300       include 'COMMON.CONTROL'
10301       include 'COMMON.SPLITELE'
10302       include 'COMMON.SBRIDGE'
10303       real*8 diffafm(3)
10304       dist=0.0d0
10305       Eafmforce=0.0d0
10306       do i=1,3
10307       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10308       dist=dist+diffafm(i)**2
10309       enddo
10310       dist=dsqrt(dist)
10311       Eafmforce=-forceAFMconst*(dist-distafminit)
10312       do i=1,3
10313       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10314       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10315       enddo
10316 C      print *,'AFM',Eafmforce
10317       return
10318       end
10319 C---------------------------------------------------------
10320 C AFM subroutine with pseudoconstant velocity
10321        subroutine AFMvel(Eafmforce)
10322        implicit real*8 (a-h,o-z)
10323       include 'DIMENSIONS'
10324       include 'COMMON.GEO'
10325       include 'COMMON.VAR'
10326       include 'COMMON.LOCAL'
10327       include 'COMMON.CHAIN'
10328       include 'COMMON.DERIV'
10329       include 'COMMON.NAMES'
10330       include 'COMMON.INTERACT'
10331       include 'COMMON.IOUNITS'
10332       include 'COMMON.CALC'
10333       include 'COMMON.CONTROL'
10334       include 'COMMON.SPLITELE'
10335       include 'COMMON.SBRIDGE'
10336       real*8 diffafm(3)
10337 C Only for check grad COMMENT if not used for checkgrad
10338 C      totT=3.0d0
10339 C--------------------------------------------------------
10340 C      print *,"wchodze"
10341       dist=0.0d0
10342       Eafmforce=0.0d0
10343       do i=1,3
10344       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10345       dist=dist+diffafm(i)**2
10346       enddo
10347       dist=dsqrt(dist)
10348       Eafmforce=0.5d0*forceAFMconst
10349      & *(distafminit+totTafm*velAFMconst-dist)**2
10350 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10351       do i=1,3
10352       gradafm(i,afmend-1)=-forceAFMconst*
10353      &(distafminit+totTafm*velAFMconst-dist)
10354      &*diffafm(i)/dist
10355       gradafm(i,afmbeg-1)=forceAFMconst*
10356      &(distafminit+totTafm*velAFMconst-dist)
10357      &*diffafm(i)/dist
10358       enddo
10359 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10360       return
10361       end
10362