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 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164 c     &   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         b1(1,i-2)=b(3,iti)
2723         b1(2,i-2)=b(5,iti)
2724         b2(1,i-2)=b(2,iti)
2725         b2(2,i-2)=b(4,iti)
2726        b1tilde(1,i-2)=b1(1,i-2)
2727        b1tilde(2,i-2)=-b1(2,i-2)
2728        b2tilde(1,i-2)=b2(1,i-2)
2729        b2tilde(2,i-2)=-b2(2,i-2)
2730         EE(1,2,i-2)=eeold(1,2,iti)
2731         EE(2,1,i-2)=eeold(2,1,iti)
2732         EE(2,2,i-2)=eeold(2,2,iti)
2733         EE(1,1,i-2)=eeold(1,1,iti)
2734       enddo
2735 #endif
2736 #ifdef PARMAT
2737       do i=ivec_start+2,ivec_end+2
2738 #else
2739       do i=3,nres+1
2740 #endif
2741         if (i .lt. nres+1) then
2742           sin1=dsin(phi(i))
2743           cos1=dcos(phi(i))
2744           sintab(i-2)=sin1
2745           costab(i-2)=cos1
2746           obrot(1,i-2)=cos1
2747           obrot(2,i-2)=sin1
2748           sin2=dsin(2*phi(i))
2749           cos2=dcos(2*phi(i))
2750           sintab2(i-2)=sin2
2751           costab2(i-2)=cos2
2752           obrot2(1,i-2)=cos2
2753           obrot2(2,i-2)=sin2
2754           Ug(1,1,i-2)=-cos1
2755           Ug(1,2,i-2)=-sin1
2756           Ug(2,1,i-2)=-sin1
2757           Ug(2,2,i-2)= cos1
2758           Ug2(1,1,i-2)=-cos2
2759           Ug2(1,2,i-2)=-sin2
2760           Ug2(2,1,i-2)=-sin2
2761           Ug2(2,2,i-2)= cos2
2762         else
2763           costab(i-2)=1.0d0
2764           sintab(i-2)=0.0d0
2765           obrot(1,i-2)=1.0d0
2766           obrot(2,i-2)=0.0d0
2767           obrot2(1,i-2)=0.0d0
2768           obrot2(2,i-2)=0.0d0
2769           Ug(1,1,i-2)=1.0d0
2770           Ug(1,2,i-2)=0.0d0
2771           Ug(2,1,i-2)=0.0d0
2772           Ug(2,2,i-2)=1.0d0
2773           Ug2(1,1,i-2)=0.0d0
2774           Ug2(1,2,i-2)=0.0d0
2775           Ug2(2,1,i-2)=0.0d0
2776           Ug2(2,2,i-2)=0.0d0
2777         endif
2778         if (i .gt. 3 .and. i .lt. nres+1) then
2779           obrot_der(1,i-2)=-sin1
2780           obrot_der(2,i-2)= cos1
2781           Ugder(1,1,i-2)= sin1
2782           Ugder(1,2,i-2)=-cos1
2783           Ugder(2,1,i-2)=-cos1
2784           Ugder(2,2,i-2)=-sin1
2785           dwacos2=cos2+cos2
2786           dwasin2=sin2+sin2
2787           obrot2_der(1,i-2)=-dwasin2
2788           obrot2_der(2,i-2)= dwacos2
2789           Ug2der(1,1,i-2)= dwasin2
2790           Ug2der(1,2,i-2)=-dwacos2
2791           Ug2der(2,1,i-2)=-dwacos2
2792           Ug2der(2,2,i-2)=-dwasin2
2793         else
2794           obrot_der(1,i-2)=0.0d0
2795           obrot_der(2,i-2)=0.0d0
2796           Ugder(1,1,i-2)=0.0d0
2797           Ugder(1,2,i-2)=0.0d0
2798           Ugder(2,1,i-2)=0.0d0
2799           Ugder(2,2,i-2)=0.0d0
2800           obrot2_der(1,i-2)=0.0d0
2801           obrot2_der(2,i-2)=0.0d0
2802           Ug2der(1,1,i-2)=0.0d0
2803           Ug2der(1,2,i-2)=0.0d0
2804           Ug2der(2,1,i-2)=0.0d0
2805           Ug2der(2,2,i-2)=0.0d0
2806         endif
2807 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2808         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2809           iti = itortyp(itype(i-2))
2810         else
2811           iti=ntortyp
2812         endif
2813 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2814         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2815           iti1 = itortyp(itype(i-1))
2816         else
2817           iti1=ntortyp
2818         endif
2819 cd        write (iout,*) '*******i',i,' iti1',iti
2820 cd        write (iout,*) 'b1',b1(:,iti)
2821 cd        write (iout,*) 'b2',b2(:,iti)
2822 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2823 c        if (i .gt. iatel_s+2) then
2824         if (i .gt. nnt+2) then
2825           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2826 #ifdef NEWCORR
2827           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2828 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2829 #endif
2830 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2831 c     &    EE(1,2,iti),EE(2,2,iti)
2832           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2833           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2834 c          write(iout,*) "Macierz EUG",
2835 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2836 c     &    eug(2,2,i-2)
2837           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2838      &    then
2839           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2840           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2841           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2842           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2843           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2844           endif
2845         else
2846           do k=1,2
2847             Ub2(k,i-2)=0.0d0
2848             Ctobr(k,i-2)=0.0d0
2849             Dtobr2(k,i-2)=0.0d0
2850             do l=1,2
2851               EUg(l,k,i-2)=0.0d0
2852               CUg(l,k,i-2)=0.0d0
2853               DUg(l,k,i-2)=0.0d0
2854               DtUg2(l,k,i-2)=0.0d0
2855             enddo
2856           enddo
2857         endif
2858         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2859         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2860         do k=1,2
2861           muder(k,i-2)=Ub2der(k,i-2)
2862         enddo
2863 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2864         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2865           if (itype(i-1).le.ntyp) then
2866             iti1 = itortyp(itype(i-1))
2867           else
2868             iti1=ntortyp
2869           endif
2870         else
2871           iti1=ntortyp
2872         endif
2873         do k=1,2
2874           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2875         enddo
2876 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2877 cd        write (iout,*) 'mu1',mu1(:,i-2)
2878 cd        write (iout,*) 'mu2',mu2(:,i-2)
2879         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2880      &  then
2881         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2882         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2883         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2884         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2885         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2886 C Vectors and matrices dependent on a single virtual-bond dihedral.
2887         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2888         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2889         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2890         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2891         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2892         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2893         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2894         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2895         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2896         endif
2897       enddo
2898 C Matrices dependent on two consecutive virtual-bond dihedrals.
2899 C The order of matrices is from left to right.
2900       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2901      &then
2902 c      do i=max0(ivec_start,2),ivec_end
2903       do i=2,nres-1
2904         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2905         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2906         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2907         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2908         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2909         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2910         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2911         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2912       enddo
2913       endif
2914 #if defined(MPI) && defined(PARMAT)
2915 #ifdef DEBUG
2916 c      if (fg_rank.eq.0) then
2917         write (iout,*) "Arrays UG and UGDER before GATHER"
2918         do i=1,nres-1
2919           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2920      &     ((ug(l,k,i),l=1,2),k=1,2),
2921      &     ((ugder(l,k,i),l=1,2),k=1,2)
2922         enddo
2923         write (iout,*) "Arrays UG2 and UG2DER"
2924         do i=1,nres-1
2925           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2926      &     ((ug2(l,k,i),l=1,2),k=1,2),
2927      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2928         enddo
2929         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2933      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     costab(i),sintab(i),costab2(i),sintab2(i)
2939         enddo
2940         write (iout,*) "Array MUDER"
2941         do i=1,nres-1
2942           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2943         enddo
2944 c      endif
2945 #endif
2946       if (nfgtasks.gt.1) then
2947         time00=MPI_Wtime()
2948 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2949 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2950 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2951 #ifdef MATGATHER
2952         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2953      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2954      &   FG_COMM1,IERR)
2955         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2956      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2957      &   FG_COMM1,IERR)
2958         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2959      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2960      &   FG_COMM1,IERR)
2961         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2962      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2963      &   FG_COMM1,IERR)
2964         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2965      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2966      &   FG_COMM1,IERR)
2967         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2968      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2969      &   FG_COMM1,IERR)
2970         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2971      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2972      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2973         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2974      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2975      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2976         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2977      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2978      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2979         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2980      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2981      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2982         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2983      &  then
2984         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2985      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2986      &   FG_COMM1,IERR)
2987         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2988      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2989      &   FG_COMM1,IERR)
2990         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2991      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2992      &   FG_COMM1,IERR)
2993        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2994      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2995      &   FG_COMM1,IERR)
2996         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3000      &   ivec_count(fg_rank1),
3001      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3002      &   FG_COMM1,IERR)
3003         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3004      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3005      &   FG_COMM1,IERR)
3006         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3007      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3008      &   FG_COMM1,IERR)
3009         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3010      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3011      &   FG_COMM1,IERR)
3012         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3013      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3014      &   FG_COMM1,IERR)
3015         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3016      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3017      &   FG_COMM1,IERR)
3018         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3019      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3020      &   FG_COMM1,IERR)
3021         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3022      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3023      &   FG_COMM1,IERR)
3024         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3025      &   ivec_count(fg_rank1),
3026      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3030      &   FG_COMM1,IERR)
3031        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3036      &   FG_COMM1,IERR)
3037        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3041      &   ivec_count(fg_rank1),
3042      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3043      &   FG_COMM1,IERR)
3044         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3045      &   ivec_count(fg_rank1),
3046      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3047      &   FG_COMM1,IERR)
3048         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3049      &   ivec_count(fg_rank1),
3050      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3051      &   MPI_MAT2,FG_COMM1,IERR)
3052         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3053      &   ivec_count(fg_rank1),
3054      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3055      &   MPI_MAT2,FG_COMM1,IERR)
3056         endif
3057 #else
3058 c Passes matrix info through the ring
3059       isend=fg_rank1
3060       irecv=fg_rank1-1
3061       if (irecv.lt.0) irecv=nfgtasks1-1
3062       iprev=irecv
3063       inext=fg_rank1+1
3064       if (inext.ge.nfgtasks1) inext=0
3065       do i=1,nfgtasks1-1
3066 c        write (iout,*) "isend",isend," irecv",irecv
3067 c        call flush(iout)
3068         lensend=lentyp(isend)
3069         lenrecv=lentyp(irecv)
3070 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3071 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3072 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3073 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3074 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3075 c        write (iout,*) "Gather ROTAT1"
3076 c        call flush(iout)
3077 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3078 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3079 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3080 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3081 c        write (iout,*) "Gather ROTAT2"
3082 c        call flush(iout)
3083         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3084      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3085      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3086      &   iprev,4400+irecv,FG_COMM,status,IERR)
3087 c        write (iout,*) "Gather ROTAT_OLD"
3088 c        call flush(iout)
3089         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3090      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3091      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3092      &   iprev,5500+irecv,FG_COMM,status,IERR)
3093 c        write (iout,*) "Gather PRECOMP11"
3094 c        call flush(iout)
3095         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3096      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3097      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3098      &   iprev,6600+irecv,FG_COMM,status,IERR)
3099 c        write (iout,*) "Gather PRECOMP12"
3100 c        call flush(iout)
3101         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3102      &  then
3103         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3104      &   MPI_ROTAT2(lensend),inext,7700+isend,
3105      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3106      &   iprev,7700+irecv,FG_COMM,status,IERR)
3107 c        write (iout,*) "Gather PRECOMP21"
3108 c        call flush(iout)
3109         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3110      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3111      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3112      &   iprev,8800+irecv,FG_COMM,status,IERR)
3113 c        write (iout,*) "Gather PRECOMP22"
3114 c        call flush(iout)
3115         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3116      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3117      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3118      &   MPI_PRECOMP23(lenrecv),
3119      &   iprev,9900+irecv,FG_COMM,status,IERR)
3120 c        write (iout,*) "Gather PRECOMP23"
3121 c        call flush(iout)
3122         endif
3123         isend=irecv
3124         irecv=irecv-1
3125         if (irecv.lt.0) irecv=nfgtasks1-1
3126       enddo
3127 #endif
3128         time_gather=time_gather+MPI_Wtime()-time00
3129       endif
3130 #ifdef DEBUG
3131 c      if (fg_rank.eq.0) then
3132         write (iout,*) "Arrays UG and UGDER"
3133         do i=1,nres-1
3134           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3135      &     ((ug(l,k,i),l=1,2),k=1,2),
3136      &     ((ugder(l,k,i),l=1,2),k=1,2)
3137         enddo
3138         write (iout,*) "Arrays UG2 and UG2DER"
3139         do i=1,nres-1
3140           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3141      &     ((ug2(l,k,i),l=1,2),k=1,2),
3142      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3143         enddo
3144         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3145         do i=1,nres-1
3146           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3147      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3148      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3149         enddo
3150         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3151         do i=1,nres-1
3152           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3153      &     costab(i),sintab(i),costab2(i),sintab2(i)
3154         enddo
3155         write (iout,*) "Array MUDER"
3156         do i=1,nres-1
3157           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3158         enddo
3159 c      endif
3160 #endif
3161 #endif
3162 cd      do i=1,nres
3163 cd        iti = itortyp(itype(i))
3164 cd        write (iout,*) i
3165 cd        do j=1,2
3166 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3167 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3168 cd        enddo
3169 cd      enddo
3170       return
3171       end
3172 C--------------------------------------------------------------------------
3173       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3174 C
3175 C This subroutine calculates the average interaction energy and its gradient
3176 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3177 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3178 C The potential depends both on the distance of peptide-group centers and on
3179 C the orientation of the CA-CA virtual bonds.
3180 C
3181       implicit real*8 (a-h,o-z)
3182 #ifdef MPI
3183       include 'mpif.h'
3184 #endif
3185       include 'DIMENSIONS'
3186       include 'COMMON.CONTROL'
3187       include 'COMMON.SETUP'
3188       include 'COMMON.IOUNITS'
3189       include 'COMMON.GEO'
3190       include 'COMMON.VAR'
3191       include 'COMMON.LOCAL'
3192       include 'COMMON.CHAIN'
3193       include 'COMMON.DERIV'
3194       include 'COMMON.INTERACT'
3195       include 'COMMON.CONTACTS'
3196       include 'COMMON.TORSION'
3197       include 'COMMON.VECTORS'
3198       include 'COMMON.FFIELD'
3199       include 'COMMON.TIME1'
3200       include 'COMMON.SPLITELE'
3201       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3202      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3203       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3204      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3205       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3206      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3207      &    num_conti,j1,j2
3208 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3209 #ifdef MOMENT
3210       double precision scal_el /1.0d0/
3211 #else
3212       double precision scal_el /0.5d0/
3213 #endif
3214 C 12/13/98
3215 C 13-go grudnia roku pamietnego...
3216       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3217      &                   0.0d0,1.0d0,0.0d0,
3218      &                   0.0d0,0.0d0,1.0d0/
3219 cd      write(iout,*) 'In EELEC'
3220 cd      do i=1,nloctyp
3221 cd        write(iout,*) 'Type',i
3222 cd        write(iout,*) 'B1',B1(:,i)
3223 cd        write(iout,*) 'B2',B2(:,i)
3224 cd        write(iout,*) 'CC',CC(:,:,i)
3225 cd        write(iout,*) 'DD',DD(:,:,i)
3226 cd        write(iout,*) 'EE',EE(:,:,i)
3227 cd      enddo
3228 cd      call check_vecgrad
3229 cd      stop
3230       if (icheckgrad.eq.1) then
3231         do i=1,nres-1
3232           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3233           do k=1,3
3234             dc_norm(k,i)=dc(k,i)*fac
3235           enddo
3236 c          write (iout,*) 'i',i,' fac',fac
3237         enddo
3238       endif
3239       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3240      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3241      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3242 c        call vec_and_deriv
3243 #ifdef TIMING
3244         time01=MPI_Wtime()
3245 #endif
3246         call set_matrices
3247 #ifdef TIMING
3248         time_mat=time_mat+MPI_Wtime()-time01
3249 #endif
3250       endif
3251 cd      do i=1,nres-1
3252 cd        write (iout,*) 'i=',i
3253 cd        do k=1,3
3254 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3255 cd        enddo
3256 cd        do k=1,3
3257 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3258 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3259 cd        enddo
3260 cd      enddo
3261       t_eelecij=0.0d0
3262       ees=0.0D0
3263       evdw1=0.0D0
3264       eel_loc=0.0d0
3265       eello_turn3=0.0d0
3266       eello_turn4=0.0d0
3267       ind=0
3268       do i=1,nres
3269         num_cont_hb(i)=0
3270       enddo
3271 cd      print '(a)','Enter EELEC'
3272 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3273       do i=1,nres
3274         gel_loc_loc(i)=0.0d0
3275         gcorr_loc(i)=0.0d0
3276       enddo
3277 c
3278 c
3279 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3280 C
3281 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3282 C
3283 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3284       do i=iturn3_start,iturn3_end
3285         if (i.le.1) cycle
3286 C        write(iout,*) "tu jest i",i
3287         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3288 C changes suggested by Ana to avoid out of bounds
3289      & .or.((i+4).gt.nres)
3290      & .or.((i-1).le.0)
3291 C end of changes by Ana
3292      &  .or. itype(i+2).eq.ntyp1
3293      &  .or. itype(i+3).eq.ntyp1) cycle
3294         if(i.gt.1)then
3295           if(itype(i-1).eq.ntyp1)cycle
3296         end if
3297         if(i.LT.nres-3)then
3298           if (itype(i+4).eq.ntyp1) cycle
3299         end if
3300         dxi=dc(1,i)
3301         dyi=dc(2,i)
3302         dzi=dc(3,i)
3303         dx_normi=dc_norm(1,i)
3304         dy_normi=dc_norm(2,i)
3305         dz_normi=dc_norm(3,i)
3306         xmedi=c(1,i)+0.5d0*dxi
3307         ymedi=c(2,i)+0.5d0*dyi
3308         zmedi=c(3,i)+0.5d0*dzi
3309           xmedi=mod(xmedi,boxxsize)
3310           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3311           ymedi=mod(ymedi,boxysize)
3312           if (ymedi.lt.0) ymedi=ymedi+boxysize
3313           zmedi=mod(zmedi,boxzsize)
3314           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3315         num_conti=0
3316         call eelecij(i,i+2,ees,evdw1,eel_loc)
3317         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3318         num_cont_hb(i)=num_conti
3319       enddo
3320       do i=iturn4_start,iturn4_end
3321         if (i.le.1) cycle
3322         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3323 C changes suggested by Ana to avoid out of bounds
3324      & .or.((i+5).gt.nres)
3325      & .or.((i-1).le.0)
3326 C end of changes suggested by Ana
3327      &    .or. itype(i+3).eq.ntyp1
3328      &    .or. itype(i+4).eq.ntyp1
3329      &    .or. itype(i+5).eq.ntyp1
3330      &    .or. itype(i).eq.ntyp1
3331      &    .or. itype(i-1).eq.ntyp1
3332      &                             ) cycle
3333         dxi=dc(1,i)
3334         dyi=dc(2,i)
3335         dzi=dc(3,i)
3336         dx_normi=dc_norm(1,i)
3337         dy_normi=dc_norm(2,i)
3338         dz_normi=dc_norm(3,i)
3339         xmedi=c(1,i)+0.5d0*dxi
3340         ymedi=c(2,i)+0.5d0*dyi
3341         zmedi=c(3,i)+0.5d0*dzi
3342 C Return atom into box, boxxsize is size of box in x dimension
3343 c  194   continue
3344 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3345 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3346 C Condition for being inside the proper box
3347 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3348 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3349 c        go to 194
3350 c        endif
3351 c  195   continue
3352 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3353 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3354 C Condition for being inside the proper box
3355 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3356 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3357 c        go to 195
3358 c        endif
3359 c  196   continue
3360 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3361 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3362 C Condition for being inside the proper box
3363 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3364 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3365 c        go to 196
3366 c        endif
3367           xmedi=mod(xmedi,boxxsize)
3368           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3369           ymedi=mod(ymedi,boxysize)
3370           if (ymedi.lt.0) ymedi=ymedi+boxysize
3371           zmedi=mod(zmedi,boxzsize)
3372           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3373
3374         num_conti=num_cont_hb(i)
3375 c        write(iout,*) "JESTEM W PETLI"
3376         call eelecij(i,i+3,ees,evdw1,eel_loc)
3377         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3378      &   call eturn4(i,eello_turn4)
3379         num_cont_hb(i)=num_conti
3380       enddo   ! i
3381 C Loop over all neighbouring boxes
3382 C      do xshift=-1,1
3383 C      do yshift=-1,1
3384 C      do zshift=-1,1
3385 c
3386 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3387 c
3388       do i=iatel_s,iatel_e
3389         if (i.le.1) cycle
3390         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3391 C changes suggested by Ana to avoid out of bounds
3392      & .or.((i+2).gt.nres)
3393      & .or.((i-1).le.0)
3394 C end of changes by Ana
3395      &  .or. itype(i+2).eq.ntyp1
3396      &  .or. itype(i-1).eq.ntyp1
3397      &                ) cycle
3398         dxi=dc(1,i)
3399         dyi=dc(2,i)
3400         dzi=dc(3,i)
3401         dx_normi=dc_norm(1,i)
3402         dy_normi=dc_norm(2,i)
3403         dz_normi=dc_norm(3,i)
3404         xmedi=c(1,i)+0.5d0*dxi
3405         ymedi=c(2,i)+0.5d0*dyi
3406         zmedi=c(3,i)+0.5d0*dzi
3407           xmedi=mod(xmedi,boxxsize)
3408           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3409           ymedi=mod(ymedi,boxysize)
3410           if (ymedi.lt.0) ymedi=ymedi+boxysize
3411           zmedi=mod(zmedi,boxzsize)
3412           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3413 C          xmedi=xmedi+xshift*boxxsize
3414 C          ymedi=ymedi+yshift*boxysize
3415 C          zmedi=zmedi+zshift*boxzsize
3416
3417 C Return tom into box, boxxsize is size of box in x dimension
3418 c  164   continue
3419 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3420 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3421 C Condition for being inside the proper box
3422 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3423 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3424 c        go to 164
3425 c        endif
3426 c  165   continue
3427 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3428 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3429 C Condition for being inside the proper box
3430 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3431 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3432 c        go to 165
3433 c        endif
3434 c  166   continue
3435 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3436 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3437 cC Condition for being inside the proper box
3438 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3439 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3440 c        go to 166
3441 c        endif
3442
3443 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3444         num_conti=num_cont_hb(i)
3445         do j=ielstart(i),ielend(i)
3446 C          write (iout,*) i,j
3447          if (j.le.1) cycle
3448           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3449 C changes suggested by Ana to avoid out of bounds
3450      & .or.((j+2).gt.nres)
3451      & .or.((j-1).le.0)
3452 C end of changes by Ana
3453      & .or.itype(j+2).eq.ntyp1
3454      & .or.itype(j-1).eq.ntyp1
3455      &) cycle
3456           call eelecij(i,j,ees,evdw1,eel_loc)
3457         enddo ! j
3458         num_cont_hb(i)=num_conti
3459       enddo   ! i
3460 C     enddo   ! zshift
3461 C      enddo   ! yshift
3462 C      enddo   ! xshift
3463
3464 c      write (iout,*) "Number of loop steps in EELEC:",ind
3465 cd      do i=1,nres
3466 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3467 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3468 cd      enddo
3469 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3470 ccc      eel_loc=eel_loc+eello_turn3
3471 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3472       return
3473       end
3474 C-------------------------------------------------------------------------------
3475       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3476       implicit real*8 (a-h,o-z)
3477       include 'DIMENSIONS'
3478 #ifdef MPI
3479       include "mpif.h"
3480 #endif
3481       include 'COMMON.CONTROL'
3482       include 'COMMON.IOUNITS'
3483       include 'COMMON.GEO'
3484       include 'COMMON.VAR'
3485       include 'COMMON.LOCAL'
3486       include 'COMMON.CHAIN'
3487       include 'COMMON.DERIV'
3488       include 'COMMON.INTERACT'
3489       include 'COMMON.CONTACTS'
3490       include 'COMMON.TORSION'
3491       include 'COMMON.VECTORS'
3492       include 'COMMON.FFIELD'
3493       include 'COMMON.TIME1'
3494       include 'COMMON.SPLITELE'
3495       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3496      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3497       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3498      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3499      &    gmuij2(4),gmuji2(4)
3500       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3501      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3502      &    num_conti,j1,j2
3503 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3504 #ifdef MOMENT
3505       double precision scal_el /1.0d0/
3506 #else
3507       double precision scal_el /0.5d0/
3508 #endif
3509 C 12/13/98
3510 C 13-go grudnia roku pamietnego...
3511       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3512      &                   0.0d0,1.0d0,0.0d0,
3513      &                   0.0d0,0.0d0,1.0d0/
3514 c          time00=MPI_Wtime()
3515 cd      write (iout,*) "eelecij",i,j
3516 c          ind=ind+1
3517           iteli=itel(i)
3518           itelj=itel(j)
3519           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3520           aaa=app(iteli,itelj)
3521           bbb=bpp(iteli,itelj)
3522           ael6i=ael6(iteli,itelj)
3523           ael3i=ael3(iteli,itelj)
3524           dxj=dc(1,j)
3525           dyj=dc(2,j)
3526           dzj=dc(3,j)
3527           dx_normj=dc_norm(1,j)
3528           dy_normj=dc_norm(2,j)
3529           dz_normj=dc_norm(3,j)
3530 C          xj=c(1,j)+0.5D0*dxj-xmedi
3531 C          yj=c(2,j)+0.5D0*dyj-ymedi
3532 C          zj=c(3,j)+0.5D0*dzj-zmedi
3533           xj=c(1,j)+0.5D0*dxj
3534           yj=c(2,j)+0.5D0*dyj
3535           zj=c(3,j)+0.5D0*dzj
3536           xj=mod(xj,boxxsize)
3537           if (xj.lt.0) xj=xj+boxxsize
3538           yj=mod(yj,boxysize)
3539           if (yj.lt.0) yj=yj+boxysize
3540           zj=mod(zj,boxzsize)
3541           if (zj.lt.0) zj=zj+boxzsize
3542           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3543       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3544       xj_safe=xj
3545       yj_safe=yj
3546       zj_safe=zj
3547       isubchap=0
3548       do xshift=-1,1
3549       do yshift=-1,1
3550       do zshift=-1,1
3551           xj=xj_safe+xshift*boxxsize
3552           yj=yj_safe+yshift*boxysize
3553           zj=zj_safe+zshift*boxzsize
3554           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3555           if(dist_temp.lt.dist_init) then
3556             dist_init=dist_temp
3557             xj_temp=xj
3558             yj_temp=yj
3559             zj_temp=zj
3560             isubchap=1
3561           endif
3562        enddo
3563        enddo
3564        enddo
3565        if (isubchap.eq.1) then
3566           xj=xj_temp-xmedi
3567           yj=yj_temp-ymedi
3568           zj=zj_temp-zmedi
3569        else
3570           xj=xj_safe-xmedi
3571           yj=yj_safe-ymedi
3572           zj=zj_safe-zmedi
3573        endif
3574 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3575 c  174   continue
3576 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3577 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3578 C Condition for being inside the proper box
3579 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3580 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3581 c        go to 174
3582 c        endif
3583 c  175   continue
3584 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3585 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3586 C Condition for being inside the proper box
3587 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3588 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3589 c        go to 175
3590 c        endif
3591 c  176   continue
3592 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3593 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3594 C Condition for being inside the proper box
3595 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3596 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3597 c        go to 176
3598 c        endif
3599 C        endif !endPBC condintion
3600 C        xj=xj-xmedi
3601 C        yj=yj-ymedi
3602 C        zj=zj-zmedi
3603           rij=xj*xj+yj*yj+zj*zj
3604
3605             sss=sscale(sqrt(rij))
3606             sssgrad=sscagrad(sqrt(rij))
3607 c            if (sss.gt.0.0d0) then
3608           rrmij=1.0D0/rij
3609           rij=dsqrt(rij)
3610           rmij=1.0D0/rij
3611           r3ij=rrmij*rmij
3612           r6ij=r3ij*r3ij
3613           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3614           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3615           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3616           fac=cosa-3.0D0*cosb*cosg
3617           ev1=aaa*r6ij*r6ij
3618 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3619           if (j.eq.i+2) ev1=scal_el*ev1
3620           ev2=bbb*r6ij
3621           fac3=ael6i*r6ij
3622           fac4=ael3i*r3ij
3623           evdwij=(ev1+ev2)
3624           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3625           el2=fac4*fac
3626 C MARYSIA
3627           eesij=(el1+el2)
3628 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3629           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3630           ees=ees+eesij
3631           evdw1=evdw1+evdwij*sss
3632 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3633 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3634 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3635 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3636
3637           if (energy_dec) then
3638               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3639      &'evdw1',i,j,evdwij
3640      &,iteli,itelj,aaa,evdw1
3641               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3642           endif
3643
3644 C
3645 C Calculate contributions to the Cartesian gradient.
3646 C
3647 #ifdef SPLITELE
3648           facvdw=-6*rrmij*(ev1+evdwij)*sss
3649           facel=-3*rrmij*(el1+eesij)
3650           fac1=fac
3651           erij(1)=xj*rmij
3652           erij(2)=yj*rmij
3653           erij(3)=zj*rmij
3654 *
3655 * Radial derivatives. First process both termini of the fragment (i,j)
3656 *
3657           ggg(1)=facel*xj
3658           ggg(2)=facel*yj
3659           ggg(3)=facel*zj
3660 c          do k=1,3
3661 c            ghalf=0.5D0*ggg(k)
3662 c            gelc(k,i)=gelc(k,i)+ghalf
3663 c            gelc(k,j)=gelc(k,j)+ghalf
3664 c          enddo
3665 c 9/28/08 AL Gradient compotents will be summed only at the end
3666           do k=1,3
3667             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3668             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3669           enddo
3670 *
3671 * Loop over residues i+1 thru j-1.
3672 *
3673 cgrad          do k=i+1,j-1
3674 cgrad            do l=1,3
3675 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3676 cgrad            enddo
3677 cgrad          enddo
3678           if (sss.gt.0.0) then
3679           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3680           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3681           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3682           else
3683           ggg(1)=0.0
3684           ggg(2)=0.0
3685           ggg(3)=0.0
3686           endif
3687 c          do k=1,3
3688 c            ghalf=0.5D0*ggg(k)
3689 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3690 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3691 c          enddo
3692 c 9/28/08 AL Gradient compotents will be summed only at the end
3693           do k=1,3
3694             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3695             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3696           enddo
3697 *
3698 * Loop over residues i+1 thru j-1.
3699 *
3700 cgrad          do k=i+1,j-1
3701 cgrad            do l=1,3
3702 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3703 cgrad            enddo
3704 cgrad          enddo
3705 #else
3706 C MARYSIA
3707           facvdw=(ev1+evdwij)*sss
3708           facel=(el1+eesij)
3709           fac1=fac
3710           fac=-3*rrmij*(facvdw+facvdw+facel)
3711           erij(1)=xj*rmij
3712           erij(2)=yj*rmij
3713           erij(3)=zj*rmij
3714 *
3715 * Radial derivatives. First process both termini of the fragment (i,j)
3716 *
3717           ggg(1)=fac*xj
3718           ggg(2)=fac*yj
3719           ggg(3)=fac*zj
3720 c          do k=1,3
3721 c            ghalf=0.5D0*ggg(k)
3722 c            gelc(k,i)=gelc(k,i)+ghalf
3723 c            gelc(k,j)=gelc(k,j)+ghalf
3724 c          enddo
3725 c 9/28/08 AL Gradient compotents will be summed only at the end
3726           do k=1,3
3727             gelc_long(k,j)=gelc(k,j)+ggg(k)
3728             gelc_long(k,i)=gelc(k,i)-ggg(k)
3729           enddo
3730 *
3731 * Loop over residues i+1 thru j-1.
3732 *
3733 cgrad          do k=i+1,j-1
3734 cgrad            do l=1,3
3735 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3736 cgrad            enddo
3737 cgrad          enddo
3738 c 9/28/08 AL Gradient compotents will be summed only at the end
3739           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3740           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3741           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3742           do k=1,3
3743             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3744             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3745           enddo
3746 #endif
3747 *
3748 * Angular part
3749 *
3750           ecosa=2.0D0*fac3*fac1+fac4
3751           fac4=-3.0D0*fac4
3752           fac3=-6.0D0*fac3
3753           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3754           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3755           do k=1,3
3756             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3757             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3758           enddo
3759 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3760 cd   &          (dcosg(k),k=1,3)
3761           do k=1,3
3762             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3763           enddo
3764 c          do k=1,3
3765 c            ghalf=0.5D0*ggg(k)
3766 c            gelc(k,i)=gelc(k,i)+ghalf
3767 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3768 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3769 c            gelc(k,j)=gelc(k,j)+ghalf
3770 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3771 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3772 c          enddo
3773 cgrad          do k=i+1,j-1
3774 cgrad            do l=1,3
3775 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3776 cgrad            enddo
3777 cgrad          enddo
3778           do k=1,3
3779             gelc(k,i)=gelc(k,i)
3780      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3781      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3782             gelc(k,j)=gelc(k,j)
3783      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3784      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3785             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3786             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3787           enddo
3788 C MARYSIA
3789 c          endif !sscale
3790           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3791      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3792      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3793 C
3794 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3795 C   energy of a peptide unit is assumed in the form of a second-order
3796 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3797 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3798 C   are computed for EVERY pair of non-contiguous peptide groups.
3799 C
3800
3801           if (j.lt.nres-1) then
3802             j1=j+1
3803             j2=j-1
3804           else
3805             j1=j-1
3806             j2=j-2
3807           endif
3808           kkk=0
3809           lll=0
3810           do k=1,2
3811             do l=1,2
3812               kkk=kkk+1
3813               muij(kkk)=mu(k,i)*mu(l,j)
3814 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3815 #ifdef NEWCORR
3816              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3817 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3818              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3819              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3820 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3821              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3822 #endif
3823             enddo
3824           enddo
3825 cd         write (iout,*) 'EELEC: i',i,' j',j
3826 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3827 cd          write(iout,*) 'muij',muij
3828           ury=scalar(uy(1,i),erij)
3829           urz=scalar(uz(1,i),erij)
3830           vry=scalar(uy(1,j),erij)
3831           vrz=scalar(uz(1,j),erij)
3832           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3833           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3834           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3835           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3836           fac=dsqrt(-ael6i)*r3ij
3837           a22=a22*fac
3838           a23=a23*fac
3839           a32=a32*fac
3840           a33=a33*fac
3841 cd          write (iout,'(4i5,4f10.5)')
3842 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3843 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3844 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3845 cd     &      uy(:,j),uz(:,j)
3846 cd          write (iout,'(4f10.5)')
3847 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3848 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3849 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3850 cd           write (iout,'(9f10.5/)')
3851 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3852 C Derivatives of the elements of A in virtual-bond vectors
3853           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3854           do k=1,3
3855             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3856             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3857             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3858             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3859             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3860             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3861             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3862             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3863             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3864             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3865             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3866             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3867           enddo
3868 C Compute radial contributions to the gradient
3869           facr=-3.0d0*rrmij
3870           a22der=a22*facr
3871           a23der=a23*facr
3872           a32der=a32*facr
3873           a33der=a33*facr
3874           agg(1,1)=a22der*xj
3875           agg(2,1)=a22der*yj
3876           agg(3,1)=a22der*zj
3877           agg(1,2)=a23der*xj
3878           agg(2,2)=a23der*yj
3879           agg(3,2)=a23der*zj
3880           agg(1,3)=a32der*xj
3881           agg(2,3)=a32der*yj
3882           agg(3,3)=a32der*zj
3883           agg(1,4)=a33der*xj
3884           agg(2,4)=a33der*yj
3885           agg(3,4)=a33der*zj
3886 C Add the contributions coming from er
3887           fac3=-3.0d0*fac
3888           do k=1,3
3889             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3890             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3891             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3892             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3893           enddo
3894           do k=1,3
3895 C Derivatives in DC(i)
3896 cgrad            ghalf1=0.5d0*agg(k,1)
3897 cgrad            ghalf2=0.5d0*agg(k,2)
3898 cgrad            ghalf3=0.5d0*agg(k,3)
3899 cgrad            ghalf4=0.5d0*agg(k,4)
3900             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3901      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3902             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3903      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3904             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3905      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3906             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3907      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3908 C Derivatives in DC(i+1)
3909             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3910      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3911             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3912      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3913             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3914      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3915             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3916      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3917 C Derivatives in DC(j)
3918             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3919      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3920             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3921      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3922             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3923      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3924             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3925      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3926 C Derivatives in DC(j+1) or DC(nres-1)
3927             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3928      &      -3.0d0*vryg(k,3)*ury)
3929             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3930      &      -3.0d0*vrzg(k,3)*ury)
3931             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3932      &      -3.0d0*vryg(k,3)*urz)
3933             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3934      &      -3.0d0*vrzg(k,3)*urz)
3935 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3936 cgrad              do l=1,4
3937 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3938 cgrad              enddo
3939 cgrad            endif
3940           enddo
3941           acipa(1,1)=a22
3942           acipa(1,2)=a23
3943           acipa(2,1)=a32
3944           acipa(2,2)=a33
3945           a22=-a22
3946           a23=-a23
3947           do l=1,2
3948             do k=1,3
3949               agg(k,l)=-agg(k,l)
3950               aggi(k,l)=-aggi(k,l)
3951               aggi1(k,l)=-aggi1(k,l)
3952               aggj(k,l)=-aggj(k,l)
3953               aggj1(k,l)=-aggj1(k,l)
3954             enddo
3955           enddo
3956           if (j.lt.nres-1) then
3957             a22=-a22
3958             a32=-a32
3959             do l=1,3,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           else
3969             a22=-a22
3970             a23=-a23
3971             a32=-a32
3972             a33=-a33
3973             do l=1,4
3974               do k=1,3
3975                 agg(k,l)=-agg(k,l)
3976                 aggi(k,l)=-aggi(k,l)
3977                 aggi1(k,l)=-aggi1(k,l)
3978                 aggj(k,l)=-aggj(k,l)
3979                 aggj1(k,l)=-aggj1(k,l)
3980               enddo
3981             enddo
3982           endif
3983           ENDIF ! WCORR
3984           IF (wel_loc.gt.0.0d0) THEN
3985 C Contribution to the local-electrostatic energy coming from the i-j pair
3986           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3987      &     +a33*muij(4)
3988 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3989 c     &                     ' eel_loc_ij',eel_loc_ij
3990 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3991 C Calculate patrial derivative for theta angle
3992 #ifdef NEWCORR
3993          geel_loc_ij=a22*gmuij1(1)
3994      &     +a23*gmuij1(2)
3995      &     +a32*gmuij1(3)
3996      &     +a33*gmuij1(4)
3997 c         write(iout,*) "derivative over thatai"
3998 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3999 c     &   a33*gmuij1(4)
4000          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4001      &      geel_loc_ij*wel_loc
4002 c         write(iout,*) "derivative over thatai-1"
4003 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4004 c     &   a33*gmuij2(4)
4005          geel_loc_ij=
4006      &     a22*gmuij2(1)
4007      &     +a23*gmuij2(2)
4008      &     +a32*gmuij2(3)
4009      &     +a33*gmuij2(4)
4010          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4011      &      geel_loc_ij*wel_loc
4012 c  Derivative over j residue
4013          geel_loc_ji=a22*gmuji1(1)
4014      &     +a23*gmuji1(2)
4015      &     +a32*gmuji1(3)
4016      &     +a33*gmuji1(4)
4017 c         write(iout,*) "derivative over thataj"
4018 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4019 c     &   a33*gmuji1(4)
4020
4021         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4022      &      geel_loc_ji*wel_loc
4023          geel_loc_ji=
4024      &     +a22*gmuji2(1)
4025      &     +a23*gmuji2(2)
4026      &     +a32*gmuji2(3)
4027      &     +a33*gmuji2(4)
4028 c         write(iout,*) "derivative over thataj-1"
4029 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4030 c     &   a33*gmuji2(4)
4031          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4032      &      geel_loc_ji*wel_loc
4033 #endif
4034 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4035
4036           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4037      &            'eelloc',i,j,eel_loc_ij
4038 c           if (eel_loc_ij.ne.0)
4039 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4040 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4041
4042           eel_loc=eel_loc+eel_loc_ij
4043 C Partial derivatives in virtual-bond dihedral angles gamma
4044           if (i.gt.1)
4045      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4046      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4047      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4048           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4049      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4050      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4051 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4052           do l=1,3
4053             ggg(l)=agg(l,1)*muij(1)+
4054      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4055             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4056             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4057 cgrad            ghalf=0.5d0*ggg(l)
4058 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4059 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4060           enddo
4061 cgrad          do k=i+1,j2
4062 cgrad            do l=1,3
4063 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4064 cgrad            enddo
4065 cgrad          enddo
4066 C Remaining derivatives of eello
4067           do l=1,3
4068             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4069      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4070             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4071      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4072             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4073      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4074             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4075      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4076           enddo
4077           ENDIF
4078 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4079 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4080           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4081      &       .and. num_conti.le.maxconts) then
4082 c            write (iout,*) i,j," entered corr"
4083 C
4084 C Calculate the contact function. The ith column of the array JCONT will
4085 C contain the numbers of atoms that make contacts with the atom I (of numbers
4086 C greater than I). The arrays FACONT and GACONT will contain the values of
4087 C the contact function and its derivative.
4088 c           r0ij=1.02D0*rpp(iteli,itelj)
4089 c           r0ij=1.11D0*rpp(iteli,itelj)
4090             r0ij=2.20D0*rpp(iteli,itelj)
4091 c           r0ij=1.55D0*rpp(iteli,itelj)
4092             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4093             if (fcont.gt.0.0D0) then
4094               num_conti=num_conti+1
4095               if (num_conti.gt.maxconts) then
4096                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4097      &                         ' will skip next contacts for this conf.'
4098               else
4099                 jcont_hb(num_conti,i)=j
4100 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4101 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4102                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4103      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4104 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4105 C  terms.
4106                 d_cont(num_conti,i)=rij
4107 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4108 C     --- Electrostatic-interaction matrix ---
4109                 a_chuj(1,1,num_conti,i)=a22
4110                 a_chuj(1,2,num_conti,i)=a23
4111                 a_chuj(2,1,num_conti,i)=a32
4112                 a_chuj(2,2,num_conti,i)=a33
4113 C     --- Gradient of rij
4114                 do kkk=1,3
4115                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4116                 enddo
4117                 kkll=0
4118                 do k=1,2
4119                   do l=1,2
4120                     kkll=kkll+1
4121                     do m=1,3
4122                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4123                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4124                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4125                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4126                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4127                     enddo
4128                   enddo
4129                 enddo
4130                 ENDIF
4131                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4132 C Calculate contact energies
4133                 cosa4=4.0D0*cosa
4134                 wij=cosa-3.0D0*cosb*cosg
4135                 cosbg1=cosb+cosg
4136                 cosbg2=cosb-cosg
4137 c               fac3=dsqrt(-ael6i)/r0ij**3
4138                 fac3=dsqrt(-ael6i)*r3ij
4139 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4140                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4141                 if (ees0tmp.gt.0) then
4142                   ees0pij=dsqrt(ees0tmp)
4143                 else
4144                   ees0pij=0
4145                 endif
4146 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4147                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4148                 if (ees0tmp.gt.0) then
4149                   ees0mij=dsqrt(ees0tmp)
4150                 else
4151                   ees0mij=0
4152                 endif
4153 c               ees0mij=0.0D0
4154                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4155                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4156 C Diagnostics. Comment out or remove after debugging!
4157 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4158 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4159 c               ees0m(num_conti,i)=0.0D0
4160 C End diagnostics.
4161 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4162 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4163 C Angular derivatives of the contact function
4164                 ees0pij1=fac3/ees0pij
4165                 ees0mij1=fac3/ees0mij
4166                 fac3p=-3.0D0*fac3*rrmij
4167                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4168                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4169 c               ees0mij1=0.0D0
4170                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4171                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4172                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4173                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4174                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4175                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4176                 ecosap=ecosa1+ecosa2
4177                 ecosbp=ecosb1+ecosb2
4178                 ecosgp=ecosg1+ecosg2
4179                 ecosam=ecosa1-ecosa2
4180                 ecosbm=ecosb1-ecosb2
4181                 ecosgm=ecosg1-ecosg2
4182 C Diagnostics
4183 c               ecosap=ecosa1
4184 c               ecosbp=ecosb1
4185 c               ecosgp=ecosg1
4186 c               ecosam=0.0D0
4187 c               ecosbm=0.0D0
4188 c               ecosgm=0.0D0
4189 C End diagnostics
4190                 facont_hb(num_conti,i)=fcont
4191                 fprimcont=fprimcont/rij
4192 cd              facont_hb(num_conti,i)=1.0D0
4193 C Following line is for diagnostics.
4194 cd              fprimcont=0.0D0
4195                 do k=1,3
4196                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4197                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4198                 enddo
4199                 do k=1,3
4200                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4201                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4202                 enddo
4203                 gggp(1)=gggp(1)+ees0pijp*xj
4204                 gggp(2)=gggp(2)+ees0pijp*yj
4205                 gggp(3)=gggp(3)+ees0pijp*zj
4206                 gggm(1)=gggm(1)+ees0mijp*xj
4207                 gggm(2)=gggm(2)+ees0mijp*yj
4208                 gggm(3)=gggm(3)+ees0mijp*zj
4209 C Derivatives due to the contact function
4210                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4211                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4212                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4213                 do k=1,3
4214 c
4215 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4216 c          following the change of gradient-summation algorithm.
4217 c
4218 cgrad                  ghalfp=0.5D0*gggp(k)
4219 cgrad                  ghalfm=0.5D0*gggm(k)
4220                   gacontp_hb1(k,num_conti,i)=!ghalfp
4221      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4222      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4223                   gacontp_hb2(k,num_conti,i)=!ghalfp
4224      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4225      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4226                   gacontp_hb3(k,num_conti,i)=gggp(k)
4227                   gacontm_hb1(k,num_conti,i)=!ghalfm
4228      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4229      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4230                   gacontm_hb2(k,num_conti,i)=!ghalfm
4231      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4232      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4233                   gacontm_hb3(k,num_conti,i)=gggm(k)
4234                 enddo
4235 C Diagnostics. Comment out or remove after debugging!
4236 cdiag           do k=1,3
4237 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4238 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4239 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4240 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4241 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4242 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4243 cdiag           enddo
4244               ENDIF ! wcorr
4245               endif  ! num_conti.le.maxconts
4246             endif  ! fcont.gt.0
4247           endif    ! j.gt.i+1
4248           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4249             do k=1,4
4250               do l=1,3
4251                 ghalf=0.5d0*agg(l,k)
4252                 aggi(l,k)=aggi(l,k)+ghalf
4253                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4254                 aggj(l,k)=aggj(l,k)+ghalf
4255               enddo
4256             enddo
4257             if (j.eq.nres-1 .and. i.lt.j-2) then
4258               do k=1,4
4259                 do l=1,3
4260                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4261                 enddo
4262               enddo
4263             endif
4264           endif
4265 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4266       return
4267       end
4268 C-----------------------------------------------------------------------------
4269       subroutine eturn3(i,eello_turn3)
4270 C Third- and fourth-order contributions from turns
4271       implicit real*8 (a-h,o-z)
4272       include 'DIMENSIONS'
4273       include 'COMMON.IOUNITS'
4274       include 'COMMON.GEO'
4275       include 'COMMON.VAR'
4276       include 'COMMON.LOCAL'
4277       include 'COMMON.CHAIN'
4278       include 'COMMON.DERIV'
4279       include 'COMMON.INTERACT'
4280       include 'COMMON.CONTACTS'
4281       include 'COMMON.TORSION'
4282       include 'COMMON.VECTORS'
4283       include 'COMMON.FFIELD'
4284       include 'COMMON.CONTROL'
4285       dimension ggg(3)
4286       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4287      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4288      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4289      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4290      &  auxgmat2(2,2),auxgmatt2(2,2)
4291       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4292      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4293       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4294      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4295      &    num_conti,j1,j2
4296       j=i+2
4297 c      write (iout,*) "eturn3",i,j,j1,j2
4298       a_temp(1,1)=a22
4299       a_temp(1,2)=a23
4300       a_temp(2,1)=a32
4301       a_temp(2,2)=a33
4302 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4303 C
4304 C               Third-order contributions
4305 C
4306 C                 (i+2)o----(i+3)
4307 C                      | |
4308 C                      | |
4309 C                 (i+1)o----i
4310 C
4311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4312 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4313         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4314 c auxalary matices for theta gradient
4315 c auxalary matrix for i+1 and constant i+2
4316         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4317 c auxalary matrix for i+2 and constant i+1
4318         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4319         call transpose2(auxmat(1,1),auxmat1(1,1))
4320         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4321         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4322         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4323         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4324         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4325         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4326 C Derivatives in theta
4327         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4328      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4329         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4330      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4331
4332         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4333      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4334 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4335 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4336 cd     &    ' eello_turn3_num',4*eello_turn3_num
4337 C Derivatives in gamma(i)
4338         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4339         call transpose2(auxmat2(1,1),auxmat3(1,1))
4340         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4341         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4342 C Derivatives in gamma(i+1)
4343         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4344         call transpose2(auxmat2(1,1),auxmat3(1,1))
4345         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4346         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4347      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4348 C Cartesian derivatives
4349         do l=1,3
4350 c            ghalf1=0.5d0*agg(l,1)
4351 c            ghalf2=0.5d0*agg(l,2)
4352 c            ghalf3=0.5d0*agg(l,3)
4353 c            ghalf4=0.5d0*agg(l,4)
4354           a_temp(1,1)=aggi(l,1)!+ghalf1
4355           a_temp(1,2)=aggi(l,2)!+ghalf2
4356           a_temp(2,1)=aggi(l,3)!+ghalf3
4357           a_temp(2,2)=aggi(l,4)!+ghalf4
4358           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4359           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4360      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4361           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4362           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4363           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4364           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4365           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4366           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4367      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4368           a_temp(1,1)=aggj(l,1)!+ghalf1
4369           a_temp(1,2)=aggj(l,2)!+ghalf2
4370           a_temp(2,1)=aggj(l,3)!+ghalf3
4371           a_temp(2,2)=aggj(l,4)!+ghalf4
4372           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4373           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4374      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4375           a_temp(1,1)=aggj1(l,1)
4376           a_temp(1,2)=aggj1(l,2)
4377           a_temp(2,1)=aggj1(l,3)
4378           a_temp(2,2)=aggj1(l,4)
4379           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4380           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4381      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4382         enddo
4383       return
4384       end
4385 C-------------------------------------------------------------------------------
4386       subroutine eturn4(i,eello_turn4)
4387 C Third- and fourth-order contributions from turns
4388       implicit real*8 (a-h,o-z)
4389       include 'DIMENSIONS'
4390       include 'COMMON.IOUNITS'
4391       include 'COMMON.GEO'
4392       include 'COMMON.VAR'
4393       include 'COMMON.LOCAL'
4394       include 'COMMON.CHAIN'
4395       include 'COMMON.DERIV'
4396       include 'COMMON.INTERACT'
4397       include 'COMMON.CONTACTS'
4398       include 'COMMON.TORSION'
4399       include 'COMMON.VECTORS'
4400       include 'COMMON.FFIELD'
4401       include 'COMMON.CONTROL'
4402       dimension ggg(3)
4403       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4404      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4405      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4406      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4407      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4408      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4409      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4410       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4411      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4412       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4413      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4414      &    num_conti,j1,j2
4415       j=i+3
4416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4417 C
4418 C               Fourth-order contributions
4419 C
4420 C                 (i+3)o----(i+4)
4421 C                     /  |
4422 C               (i+2)o   |
4423 C                     \  |
4424 C                 (i+1)o----i
4425 C
4426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4427 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4428 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4429 c        write(iout,*)"WCHODZE W PROGRAM"
4430         a_temp(1,1)=a22
4431         a_temp(1,2)=a23
4432         a_temp(2,1)=a32
4433         a_temp(2,2)=a33
4434         iti1=itortyp(itype(i+1))
4435         iti2=itortyp(itype(i+2))
4436         iti3=itortyp(itype(i+3))
4437 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4438         call transpose2(EUg(1,1,i+1),e1t(1,1))
4439         call transpose2(Eug(1,1,i+2),e2t(1,1))
4440         call transpose2(Eug(1,1,i+3),e3t(1,1))
4441 C Ematrix derivative in theta
4442         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4443         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4444         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4445         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4446 c       eta1 in derivative theta
4447         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4448         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4449 c       auxgvec is derivative of Ub2 so i+3 theta
4450         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4451 c       auxalary matrix of E i+1
4452         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4453 c        s1=0.0
4454 c        gs1=0.0
4455         s1=scalar2(b1(1,i+2),auxvec(1))
4456 c derivative of theta i+2 with constant i+3
4457         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4458 c derivative of theta i+2 with constant i+2
4459         gs32=scalar2(b1(1,i+2),auxgvec(1))
4460 c derivative of E matix in theta of i+1
4461         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4462
4463         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4464 c       ea31 in derivative theta
4465         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4466         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4467 c auxilary matrix auxgvec of Ub2 with constant E matirx
4468         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4469 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4470         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4471
4472 c        s2=0.0
4473 c        gs2=0.0
4474         s2=scalar2(b1(1,i+1),auxvec(1))
4475 c derivative of theta i+1 with constant i+3
4476         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4477 c derivative of theta i+2 with constant i+1
4478         gs21=scalar2(b1(1,i+1),auxgvec(1))
4479 c derivative of theta i+3 with constant i+1
4480         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4481 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4482 c     &  gtb1(1,i+1)
4483         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4484 c two derivatives over diffetent matrices
4485 c gtae3e2 is derivative over i+3
4486         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4487 c ae3gte2 is derivative over i+2
4488         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4489         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4490 c three possible derivative over theta E matices
4491 c i+1
4492         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4493 c i+2
4494         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4495 c i+3
4496         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4497         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4498
4499         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4500         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4501         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4502
4503         eello_turn4=eello_turn4-(s1+s2+s3)
4504 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4505         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4506      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4507 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4508 cd     &    ' eello_turn4_num',8*eello_turn4_num
4509 #ifdef NEWCORR
4510         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4511      &                  -(gs13+gsE13+gsEE1)*wturn4
4512         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4513      &                    -(gs23+gs21+gsEE2)*wturn4
4514         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4515      &                    -(gs32+gsE31+gsEE3)*wturn4
4516 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4517 c     &   gs2
4518 #endif
4519         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4520      &      'eturn4',i,j,-(s1+s2+s3)
4521 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4522 c     &    ' eello_turn4_num',8*eello_turn4_num
4523 C Derivatives in gamma(i)
4524         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4525         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4526         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4527         s1=scalar2(b1(1,i+2),auxvec(1))
4528         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4529         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4530         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4531 C Derivatives in gamma(i+1)
4532         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4533         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4534         s2=scalar2(b1(1,i+1),auxvec(1))
4535         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4536         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4537         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4538         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4539 C Derivatives in gamma(i+2)
4540         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4541         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4542         s1=scalar2(b1(1,i+2),auxvec(1))
4543         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4544         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4545         s2=scalar2(b1(1,i+1),auxvec(1))
4546         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4547         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4548         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4549         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4550 C Cartesian derivatives
4551 C Derivatives of this turn contributions in DC(i+2)
4552         if (j.lt.nres-1) then
4553           do l=1,3
4554             a_temp(1,1)=agg(l,1)
4555             a_temp(1,2)=agg(l,2)
4556             a_temp(2,1)=agg(l,3)
4557             a_temp(2,2)=agg(l,4)
4558             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4559             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4560             s1=scalar2(b1(1,i+2),auxvec(1))
4561             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4562             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4563             s2=scalar2(b1(1,i+1),auxvec(1))
4564             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4565             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4566             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4567             ggg(l)=-(s1+s2+s3)
4568             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4569           enddo
4570         endif
4571 C Remaining derivatives of this turn contribution
4572         do l=1,3
4573           a_temp(1,1)=aggi(l,1)
4574           a_temp(1,2)=aggi(l,2)
4575           a_temp(2,1)=aggi(l,3)
4576           a_temp(2,2)=aggi(l,4)
4577           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4578           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4579           s1=scalar2(b1(1,i+2),auxvec(1))
4580           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4581           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4582           s2=scalar2(b1(1,i+1),auxvec(1))
4583           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4584           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4585           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4586           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4587           a_temp(1,1)=aggi1(l,1)
4588           a_temp(1,2)=aggi1(l,2)
4589           a_temp(2,1)=aggi1(l,3)
4590           a_temp(2,2)=aggi1(l,4)
4591           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4592           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4593           s1=scalar2(b1(1,i+2),auxvec(1))
4594           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4595           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4596           s2=scalar2(b1(1,i+1),auxvec(1))
4597           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4598           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4599           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4600           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4601           a_temp(1,1)=aggj(l,1)
4602           a_temp(1,2)=aggj(l,2)
4603           a_temp(2,1)=aggj(l,3)
4604           a_temp(2,2)=aggj(l,4)
4605           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4606           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4607           s1=scalar2(b1(1,i+2),auxvec(1))
4608           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4609           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4610           s2=scalar2(b1(1,i+1),auxvec(1))
4611           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4612           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4613           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4614           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4615           a_temp(1,1)=aggj1(l,1)
4616           a_temp(1,2)=aggj1(l,2)
4617           a_temp(2,1)=aggj1(l,3)
4618           a_temp(2,2)=aggj1(l,4)
4619           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4620           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4621           s1=scalar2(b1(1,i+2),auxvec(1))
4622           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4623           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4624           s2=scalar2(b1(1,i+1),auxvec(1))
4625           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4626           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4627           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4628 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4629           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4630         enddo
4631       return
4632       end
4633 C-----------------------------------------------------------------------------
4634       subroutine vecpr(u,v,w)
4635       implicit real*8(a-h,o-z)
4636       dimension u(3),v(3),w(3)
4637       w(1)=u(2)*v(3)-u(3)*v(2)
4638       w(2)=-u(1)*v(3)+u(3)*v(1)
4639       w(3)=u(1)*v(2)-u(2)*v(1)
4640       return
4641       end
4642 C-----------------------------------------------------------------------------
4643       subroutine unormderiv(u,ugrad,unorm,ungrad)
4644 C This subroutine computes the derivatives of a normalized vector u, given
4645 C the derivatives computed without normalization conditions, ugrad. Returns
4646 C ungrad.
4647       implicit none
4648       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4649       double precision vec(3)
4650       double precision scalar
4651       integer i,j
4652 c      write (2,*) 'ugrad',ugrad
4653 c      write (2,*) 'u',u
4654       do i=1,3
4655         vec(i)=scalar(ugrad(1,i),u(1))
4656       enddo
4657 c      write (2,*) 'vec',vec
4658       do i=1,3
4659         do j=1,3
4660           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4661         enddo
4662       enddo
4663 c      write (2,*) 'ungrad',ungrad
4664       return
4665       end
4666 C-----------------------------------------------------------------------------
4667       subroutine escp_soft_sphere(evdw2,evdw2_14)
4668 C
4669 C This subroutine calculates the excluded-volume interaction energy between
4670 C peptide-group centers and side chains and its gradient in virtual-bond and
4671 C side-chain vectors.
4672 C
4673       implicit real*8 (a-h,o-z)
4674       include 'DIMENSIONS'
4675       include 'COMMON.GEO'
4676       include 'COMMON.VAR'
4677       include 'COMMON.LOCAL'
4678       include 'COMMON.CHAIN'
4679       include 'COMMON.DERIV'
4680       include 'COMMON.INTERACT'
4681       include 'COMMON.FFIELD'
4682       include 'COMMON.IOUNITS'
4683       include 'COMMON.CONTROL'
4684       dimension ggg(3)
4685       evdw2=0.0D0
4686       evdw2_14=0.0d0
4687       r0_scp=4.5d0
4688 cd    print '(a)','Enter ESCP'
4689 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4690 C      do xshift=-1,1
4691 C      do yshift=-1,1
4692 C      do zshift=-1,1
4693       do i=iatscp_s,iatscp_e
4694         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4695         iteli=itel(i)
4696         xi=0.5D0*(c(1,i)+c(1,i+1))
4697         yi=0.5D0*(c(2,i)+c(2,i+1))
4698         zi=0.5D0*(c(3,i)+c(3,i+1))
4699 C Return atom into box, boxxsize is size of box in x dimension
4700 c  134   continue
4701 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4702 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4703 C Condition for being inside the proper box
4704 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4705 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4706 c        go to 134
4707 c        endif
4708 c  135   continue
4709 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4710 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4711 C Condition for being inside the proper box
4712 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4713 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4714 c        go to 135
4715 c c       endif
4716 c  136   continue
4717 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4718 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4719 cC Condition for being inside the proper box
4720 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4721 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4722 c        go to 136
4723 c        endif
4724           xi=mod(xi,boxxsize)
4725           if (xi.lt.0) xi=xi+boxxsize
4726           yi=mod(yi,boxysize)
4727           if (yi.lt.0) yi=yi+boxysize
4728           zi=mod(zi,boxzsize)
4729           if (zi.lt.0) zi=zi+boxzsize
4730 C          xi=xi+xshift*boxxsize
4731 C          yi=yi+yshift*boxysize
4732 C          zi=zi+zshift*boxzsize
4733         do iint=1,nscp_gr(i)
4734
4735         do j=iscpstart(i,iint),iscpend(i,iint)
4736           if (itype(j).eq.ntyp1) cycle
4737           itypj=iabs(itype(j))
4738 C Uncomment following three lines for SC-p interactions
4739 c         xj=c(1,nres+j)-xi
4740 c         yj=c(2,nres+j)-yi
4741 c         zj=c(3,nres+j)-zi
4742 C Uncomment following three lines for Ca-p interactions
4743           xj=c(1,j)
4744           yj=c(2,j)
4745           zj=c(3,j)
4746 c  174   continue
4747 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4748 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4749 C Condition for being inside the proper box
4750 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4751 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4752 c        go to 174
4753 c        endif
4754 c  175   continue
4755 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4756 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4757 cC Condition for being inside the proper box
4758 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4759 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4760 c        go to 175
4761 c        endif
4762 c  176   continue
4763 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4764 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4765 C Condition for being inside the proper box
4766 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4767 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4768 c        go to 176
4769           xj=mod(xj,boxxsize)
4770           if (xj.lt.0) xj=xj+boxxsize
4771           yj=mod(yj,boxysize)
4772           if (yj.lt.0) yj=yj+boxysize
4773           zj=mod(zj,boxzsize)
4774           if (zj.lt.0) zj=zj+boxzsize
4775       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4776       xj_safe=xj
4777       yj_safe=yj
4778       zj_safe=zj
4779       subchap=0
4780       do xshift=-1,1
4781       do yshift=-1,1
4782       do zshift=-1,1
4783           xj=xj_safe+xshift*boxxsize
4784           yj=yj_safe+yshift*boxysize
4785           zj=zj_safe+zshift*boxzsize
4786           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4787           if(dist_temp.lt.dist_init) then
4788             dist_init=dist_temp
4789             xj_temp=xj
4790             yj_temp=yj
4791             zj_temp=zj
4792             subchap=1
4793           endif
4794        enddo
4795        enddo
4796        enddo
4797        if (subchap.eq.1) then
4798           xj=xj_temp-xi
4799           yj=yj_temp-yi
4800           zj=zj_temp-zi
4801        else
4802           xj=xj_safe-xi
4803           yj=yj_safe-yi
4804           zj=zj_safe-zi
4805        endif
4806 c c       endif
4807 C          xj=xj-xi
4808 C          yj=yj-yi
4809 C          zj=zj-zi
4810           rij=xj*xj+yj*yj+zj*zj
4811
4812           r0ij=r0_scp
4813           r0ijsq=r0ij*r0ij
4814           if (rij.lt.r0ijsq) then
4815             evdwij=0.25d0*(rij-r0ijsq)**2
4816             fac=rij-r0ijsq
4817           else
4818             evdwij=0.0d0
4819             fac=0.0d0
4820           endif
4821           evdw2=evdw2+evdwij
4822 C
4823 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4824 C
4825           ggg(1)=xj*fac
4826           ggg(2)=yj*fac
4827           ggg(3)=zj*fac
4828 cgrad          if (j.lt.i) then
4829 cd          write (iout,*) 'j<i'
4830 C Uncomment following three lines for SC-p interactions
4831 c           do k=1,3
4832 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4833 c           enddo
4834 cgrad          else
4835 cd          write (iout,*) 'j>i'
4836 cgrad            do k=1,3
4837 cgrad              ggg(k)=-ggg(k)
4838 C Uncomment following line for SC-p interactions
4839 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4840 cgrad            enddo
4841 cgrad          endif
4842 cgrad          do k=1,3
4843 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4844 cgrad          enddo
4845 cgrad          kstart=min0(i+1,j)
4846 cgrad          kend=max0(i-1,j-1)
4847 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4848 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4849 cgrad          do k=kstart,kend
4850 cgrad            do l=1,3
4851 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4852 cgrad            enddo
4853 cgrad          enddo
4854           do k=1,3
4855             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4856             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4857           enddo
4858         enddo
4859
4860         enddo ! iint
4861       enddo ! i
4862 C      enddo !zshift
4863 C      enddo !yshift
4864 C      enddo !xshift
4865       return
4866       end
4867 C-----------------------------------------------------------------------------
4868       subroutine escp(evdw2,evdw2_14)
4869 C
4870 C This subroutine calculates the excluded-volume interaction energy between
4871 C peptide-group centers and side chains and its gradient in virtual-bond and
4872 C side-chain vectors.
4873 C
4874       implicit real*8 (a-h,o-z)
4875       include 'DIMENSIONS'
4876       include 'COMMON.GEO'
4877       include 'COMMON.VAR'
4878       include 'COMMON.LOCAL'
4879       include 'COMMON.CHAIN'
4880       include 'COMMON.DERIV'
4881       include 'COMMON.INTERACT'
4882       include 'COMMON.FFIELD'
4883       include 'COMMON.IOUNITS'
4884       include 'COMMON.CONTROL'
4885       include 'COMMON.SPLITELE'
4886       dimension ggg(3)
4887       evdw2=0.0D0
4888       evdw2_14=0.0d0
4889 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4890 cd    print '(a)','Enter ESCP'
4891 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4892 C      do xshift=-1,1
4893 C      do yshift=-1,1
4894 C      do zshift=-1,1
4895       do i=iatscp_s,iatscp_e
4896         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4897         iteli=itel(i)
4898         xi=0.5D0*(c(1,i)+c(1,i+1))
4899         yi=0.5D0*(c(2,i)+c(2,i+1))
4900         zi=0.5D0*(c(3,i)+c(3,i+1))
4901           xi=mod(xi,boxxsize)
4902           if (xi.lt.0) xi=xi+boxxsize
4903           yi=mod(yi,boxysize)
4904           if (yi.lt.0) yi=yi+boxysize
4905           zi=mod(zi,boxzsize)
4906           if (zi.lt.0) zi=zi+boxzsize
4907 c          xi=xi+xshift*boxxsize
4908 c          yi=yi+yshift*boxysize
4909 c          zi=zi+zshift*boxzsize
4910 c        print *,xi,yi,zi,'polozenie i'
4911 C Return atom into box, boxxsize is size of box in x dimension
4912 c  134   continue
4913 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4914 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4915 C Condition for being inside the proper box
4916 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4917 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4918 c        go to 134
4919 c        endif
4920 c  135   continue
4921 c          print *,xi,boxxsize,"pierwszy"
4922
4923 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4924 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4925 C Condition for being inside the proper box
4926 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4927 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4928 c        go to 135
4929 c        endif
4930 c  136   continue
4931 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4932 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4933 C Condition for being inside the proper box
4934 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4935 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4936 c        go to 136
4937 c        endif
4938         do iint=1,nscp_gr(i)
4939
4940         do j=iscpstart(i,iint),iscpend(i,iint)
4941           itypj=iabs(itype(j))
4942           if (itypj.eq.ntyp1) cycle
4943 C Uncomment following three lines for SC-p interactions
4944 c         xj=c(1,nres+j)-xi
4945 c         yj=c(2,nres+j)-yi
4946 c         zj=c(3,nres+j)-zi
4947 C Uncomment following three lines for Ca-p interactions
4948           xj=c(1,j)
4949           yj=c(2,j)
4950           zj=c(3,j)
4951           xj=mod(xj,boxxsize)
4952           if (xj.lt.0) xj=xj+boxxsize
4953           yj=mod(yj,boxysize)
4954           if (yj.lt.0) yj=yj+boxysize
4955           zj=mod(zj,boxzsize)
4956           if (zj.lt.0) zj=zj+boxzsize
4957 c  174   continue
4958 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4959 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4960 C Condition for being inside the proper box
4961 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4962 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4963 c        go to 174
4964 c        endif
4965 c  175   continue
4966 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4967 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4968 cC Condition for being inside the proper box
4969 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4970 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4971 c        go to 175
4972 c        endif
4973 c  176   continue
4974 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4975 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4976 C Condition for being inside the proper box
4977 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4978 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4979 c        go to 176
4980 c        endif
4981 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4982       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4983       xj_safe=xj
4984       yj_safe=yj
4985       zj_safe=zj
4986       subchap=0
4987       do xshift=-1,1
4988       do yshift=-1,1
4989       do zshift=-1,1
4990           xj=xj_safe+xshift*boxxsize
4991           yj=yj_safe+yshift*boxysize
4992           zj=zj_safe+zshift*boxzsize
4993           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4994           if(dist_temp.lt.dist_init) then
4995             dist_init=dist_temp
4996             xj_temp=xj
4997             yj_temp=yj
4998             zj_temp=zj
4999             subchap=1
5000           endif
5001        enddo
5002        enddo
5003        enddo
5004        if (subchap.eq.1) then
5005           xj=xj_temp-xi
5006           yj=yj_temp-yi
5007           zj=zj_temp-zi
5008        else
5009           xj=xj_safe-xi
5010           yj=yj_safe-yi
5011           zj=zj_safe-zi
5012        endif
5013 c          print *,xj,yj,zj,'polozenie j'
5014           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5015 c          print *,rrij
5016           sss=sscale(1.0d0/(dsqrt(rrij)))
5017 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5018 c          if (sss.eq.0) print *,'czasem jest OK'
5019           if (sss.le.0.0d0) cycle
5020           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5021           fac=rrij**expon2
5022           e1=fac*fac*aad(itypj,iteli)
5023           e2=fac*bad(itypj,iteli)
5024           if (iabs(j-i) .le. 2) then
5025             e1=scal14*e1
5026             e2=scal14*e2
5027             evdw2_14=evdw2_14+(e1+e2)*sss
5028           endif
5029           evdwij=e1+e2
5030           evdw2=evdw2+evdwij*sss
5031           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5032      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5033      &       bad(itypj,iteli)
5034 C
5035 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5036 C
5037           fac=-(evdwij+e1)*rrij*sss
5038           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5039           ggg(1)=xj*fac
5040           ggg(2)=yj*fac
5041           ggg(3)=zj*fac
5042 cgrad          if (j.lt.i) then
5043 cd          write (iout,*) 'j<i'
5044 C Uncomment following three lines for SC-p interactions
5045 c           do k=1,3
5046 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5047 c           enddo
5048 cgrad          else
5049 cd          write (iout,*) 'j>i'
5050 cgrad            do k=1,3
5051 cgrad              ggg(k)=-ggg(k)
5052 C Uncomment following line for SC-p interactions
5053 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5054 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5055 cgrad            enddo
5056 cgrad          endif
5057 cgrad          do k=1,3
5058 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5059 cgrad          enddo
5060 cgrad          kstart=min0(i+1,j)
5061 cgrad          kend=max0(i-1,j-1)
5062 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5063 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5064 cgrad          do k=kstart,kend
5065 cgrad            do l=1,3
5066 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5067 cgrad            enddo
5068 cgrad          enddo
5069           do k=1,3
5070             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5071             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5072           enddo
5073 c        endif !endif for sscale cutoff
5074         enddo ! j
5075
5076         enddo ! iint
5077       enddo ! i
5078 c      enddo !zshift
5079 c      enddo !yshift
5080 c      enddo !xshift
5081       do i=1,nct
5082         do j=1,3
5083           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5084           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5085           gradx_scp(j,i)=expon*gradx_scp(j,i)
5086         enddo
5087       enddo
5088 C******************************************************************************
5089 C
5090 C                              N O T E !!!
5091 C
5092 C To save time the factor EXPON has been extracted from ALL components
5093 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5094 C use!
5095 C
5096 C******************************************************************************
5097       return
5098       end
5099 C--------------------------------------------------------------------------
5100       subroutine edis(ehpb)
5101 C
5102 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5103 C
5104       implicit real*8 (a-h,o-z)
5105       include 'DIMENSIONS'
5106       include 'COMMON.SBRIDGE'
5107       include 'COMMON.CHAIN'
5108       include 'COMMON.DERIV'
5109       include 'COMMON.VAR'
5110       include 'COMMON.INTERACT'
5111       include 'COMMON.IOUNITS'
5112       dimension ggg(3)
5113       ehpb=0.0D0
5114 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5115 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5116       if (link_end.eq.0) return
5117       do i=link_start,link_end
5118 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5119 C CA-CA distance used in regularization of structure.
5120         ii=ihpb(i)
5121         jj=jhpb(i)
5122 C iii and jjj point to the residues for which the distance is assigned.
5123         if (ii.gt.nres) then
5124           iii=ii-nres
5125           jjj=jj-nres
5126         else
5127           iii=ii
5128           jjj=jj
5129         endif
5130 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5131 c     &    dhpb(i),dhpb1(i),forcon(i)
5132 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5133 C    distance and angle dependent SS bond potential.
5134 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5135 C     & iabs(itype(jjj)).eq.1) then
5136 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5137 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5138         if (.not.dyn_ss .and. i.le.nss) then
5139 C 15/02/13 CC dynamic SSbond - additional check
5140          if (ii.gt.nres
5141      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5142           call ssbond_ene(iii,jjj,eij)
5143           ehpb=ehpb+2*eij
5144          endif
5145 cd          write (iout,*) "eij",eij
5146         else
5147 C Calculate the distance between the two points and its difference from the
5148 C target distance.
5149           dd=dist(ii,jj)
5150             rdis=dd-dhpb(i)
5151 C Get the force constant corresponding to this distance.
5152             waga=forcon(i)
5153 C Calculate the contribution to energy.
5154             ehpb=ehpb+waga*rdis*rdis
5155 C
5156 C Evaluate gradient.
5157 C
5158             fac=waga*rdis/dd
5159 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5160 cd   &   ' waga=',waga,' fac=',fac
5161             do j=1,3
5162               ggg(j)=fac*(c(j,jj)-c(j,ii))
5163             enddo
5164 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5165 C If this is a SC-SC distance, we need to calculate the contributions to the
5166 C Cartesian gradient in the SC vectors (ghpbx).
5167           if (iii.lt.ii) then
5168           do j=1,3
5169             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5170             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5171           enddo
5172           endif
5173 cgrad        do j=iii,jjj-1
5174 cgrad          do k=1,3
5175 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5176 cgrad          enddo
5177 cgrad        enddo
5178           do k=1,3
5179             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5180             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5181           enddo
5182         endif
5183       enddo
5184       ehpb=0.5D0*ehpb
5185       return
5186       end
5187 C--------------------------------------------------------------------------
5188       subroutine ssbond_ene(i,j,eij)
5189 C
5190 C Calculate the distance and angle dependent SS-bond potential energy
5191 C using a free-energy function derived based on RHF/6-31G** ab initio
5192 C calculations of diethyl disulfide.
5193 C
5194 C A. Liwo and U. Kozlowska, 11/24/03
5195 C
5196       implicit real*8 (a-h,o-z)
5197       include 'DIMENSIONS'
5198       include 'COMMON.SBRIDGE'
5199       include 'COMMON.CHAIN'
5200       include 'COMMON.DERIV'
5201       include 'COMMON.LOCAL'
5202       include 'COMMON.INTERACT'
5203       include 'COMMON.VAR'
5204       include 'COMMON.IOUNITS'
5205       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5206       itypi=iabs(itype(i))
5207       xi=c(1,nres+i)
5208       yi=c(2,nres+i)
5209       zi=c(3,nres+i)
5210       dxi=dc_norm(1,nres+i)
5211       dyi=dc_norm(2,nres+i)
5212       dzi=dc_norm(3,nres+i)
5213 c      dsci_inv=dsc_inv(itypi)
5214       dsci_inv=vbld_inv(nres+i)
5215       itypj=iabs(itype(j))
5216 c      dscj_inv=dsc_inv(itypj)
5217       dscj_inv=vbld_inv(nres+j)
5218       xj=c(1,nres+j)-xi
5219       yj=c(2,nres+j)-yi
5220       zj=c(3,nres+j)-zi
5221       dxj=dc_norm(1,nres+j)
5222       dyj=dc_norm(2,nres+j)
5223       dzj=dc_norm(3,nres+j)
5224       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5225       rij=dsqrt(rrij)
5226       erij(1)=xj*rij
5227       erij(2)=yj*rij
5228       erij(3)=zj*rij
5229       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5230       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5231       om12=dxi*dxj+dyi*dyj+dzi*dzj
5232       do k=1,3
5233         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5234         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5235       enddo
5236       rij=1.0d0/rij
5237       deltad=rij-d0cm
5238       deltat1=1.0d0-om1
5239       deltat2=1.0d0+om2
5240       deltat12=om2-om1+2.0d0
5241       cosphi=om12-om1*om2
5242       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5243      &  +akct*deltad*deltat12
5244      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5245 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5246 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5247 c     &  " deltat12",deltat12," eij",eij
5248       ed=2*akcm*deltad+akct*deltat12
5249       pom1=akct*deltad
5250       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5251       eom1=-2*akth*deltat1-pom1-om2*pom2
5252       eom2= 2*akth*deltat2+pom1-om1*pom2
5253       eom12=pom2
5254       do k=1,3
5255         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5256         ghpbx(k,i)=ghpbx(k,i)-ggk
5257      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5258      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5259         ghpbx(k,j)=ghpbx(k,j)+ggk
5260      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5261      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5262         ghpbc(k,i)=ghpbc(k,i)-ggk
5263         ghpbc(k,j)=ghpbc(k,j)+ggk
5264       enddo
5265 C
5266 C Calculate the components of the gradient in DC and X
5267 C
5268 cgrad      do k=i,j-1
5269 cgrad        do l=1,3
5270 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5271 cgrad        enddo
5272 cgrad      enddo
5273       return
5274       end
5275 C--------------------------------------------------------------------------
5276       subroutine ebond(estr)
5277 c
5278 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5279 c
5280       implicit real*8 (a-h,o-z)
5281       include 'DIMENSIONS'
5282       include 'COMMON.LOCAL'
5283       include 'COMMON.GEO'
5284       include 'COMMON.INTERACT'
5285       include 'COMMON.DERIV'
5286       include 'COMMON.VAR'
5287       include 'COMMON.CHAIN'
5288       include 'COMMON.IOUNITS'
5289       include 'COMMON.NAMES'
5290       include 'COMMON.FFIELD'
5291       include 'COMMON.CONTROL'
5292       include 'COMMON.SETUP'
5293       double precision u(3),ud(3)
5294       estr=0.0d0
5295       estr1=0.0d0
5296       do i=ibondp_start,ibondp_end
5297         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5298 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5299 c          do j=1,3
5300 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5301 c     &      *dc(j,i-1)/vbld(i)
5302 c          enddo
5303 c          if (energy_dec) write(iout,*)
5304 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5305 c        else
5306 C       Checking if it involves dummy (NH3+ or COO-) group
5307          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5308 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5309         diff = vbld(i)-vbldpDUM
5310          else
5311 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5312         diff = vbld(i)-vbldp0
5313          endif
5314         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5315      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5316         estr=estr+diff*diff
5317         do j=1,3
5318           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5319         enddo
5320 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5321 c        endif
5322       enddo
5323       estr=0.5d0*AKP*estr+estr1
5324 c
5325 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5326 c
5327       do i=ibond_start,ibond_end
5328         iti=iabs(itype(i))
5329         if (iti.ne.10 .and. iti.ne.ntyp1) then
5330           nbi=nbondterm(iti)
5331           if (nbi.eq.1) then
5332             diff=vbld(i+nres)-vbldsc0(1,iti)
5333             if (energy_dec)  write (iout,*)
5334      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5335      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5336             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5337             do j=1,3
5338               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5339             enddo
5340           else
5341             do j=1,nbi
5342               diff=vbld(i+nres)-vbldsc0(j,iti)
5343               ud(j)=aksc(j,iti)*diff
5344               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5345             enddo
5346             uprod=u(1)
5347             do j=2,nbi
5348               uprod=uprod*u(j)
5349             enddo
5350             usum=0.0d0
5351             usumsqder=0.0d0
5352             do j=1,nbi
5353               uprod1=1.0d0
5354               uprod2=1.0d0
5355               do k=1,nbi
5356                 if (k.ne.j) then
5357                   uprod1=uprod1*u(k)
5358                   uprod2=uprod2*u(k)*u(k)
5359                 endif
5360               enddo
5361               usum=usum+uprod1
5362               usumsqder=usumsqder+ud(j)*uprod2
5363             enddo
5364             estr=estr+uprod/usum
5365             do j=1,3
5366              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5367             enddo
5368           endif
5369         endif
5370       enddo
5371       return
5372       end
5373 #ifdef CRYST_THETA
5374 C--------------------------------------------------------------------------
5375       subroutine ebend(etheta)
5376 C
5377 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5378 C angles gamma and its derivatives in consecutive thetas and gammas.
5379 C
5380       implicit real*8 (a-h,o-z)
5381       include 'DIMENSIONS'
5382       include 'COMMON.LOCAL'
5383       include 'COMMON.GEO'
5384       include 'COMMON.INTERACT'
5385       include 'COMMON.DERIV'
5386       include 'COMMON.VAR'
5387       include 'COMMON.CHAIN'
5388       include 'COMMON.IOUNITS'
5389       include 'COMMON.NAMES'
5390       include 'COMMON.FFIELD'
5391       include 'COMMON.CONTROL'
5392       common /calcthet/ term1,term2,termm,diffak,ratak,
5393      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5394      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5395       double precision y(2),z(2)
5396       delta=0.02d0*pi
5397 c      time11=dexp(-2*time)
5398 c      time12=1.0d0
5399       etheta=0.0D0
5400 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5401       do i=ithet_start,ithet_end
5402         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5403      &  .or.itype(i).eq.ntyp1) cycle
5404 C Zero the energy function and its derivative at 0 or pi.
5405         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5406         it=itype(i-1)
5407         ichir1=isign(1,itype(i-2))
5408         ichir2=isign(1,itype(i))
5409          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5410          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5411          if (itype(i-1).eq.10) then
5412           itype1=isign(10,itype(i-2))
5413           ichir11=isign(1,itype(i-2))
5414           ichir12=isign(1,itype(i-2))
5415           itype2=isign(10,itype(i))
5416           ichir21=isign(1,itype(i))
5417           ichir22=isign(1,itype(i))
5418          endif
5419
5420         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5421 #ifdef OSF
5422           phii=phi(i)
5423           if (phii.ne.phii) phii=150.0
5424 #else
5425           phii=phi(i)
5426 #endif
5427           y(1)=dcos(phii)
5428           y(2)=dsin(phii)
5429         else
5430           y(1)=0.0D0
5431           y(2)=0.0D0
5432         endif
5433         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5434 #ifdef OSF
5435           phii1=phi(i+1)
5436           if (phii1.ne.phii1) phii1=150.0
5437           phii1=pinorm(phii1)
5438           z(1)=cos(phii1)
5439 #else
5440           phii1=phi(i+1)
5441 #endif
5442           z(1)=dcos(phii1)
5443           z(2)=dsin(phii1)
5444         else
5445           z(1)=0.0D0
5446           z(2)=0.0D0
5447         endif
5448 C Calculate the "mean" value of theta from the part of the distribution
5449 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5450 C In following comments this theta will be referred to as t_c.
5451         thet_pred_mean=0.0d0
5452         do k=1,2
5453             athetk=athet(k,it,ichir1,ichir2)
5454             bthetk=bthet(k,it,ichir1,ichir2)
5455           if (it.eq.10) then
5456              athetk=athet(k,itype1,ichir11,ichir12)
5457              bthetk=bthet(k,itype2,ichir21,ichir22)
5458           endif
5459          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5460 c         write(iout,*) 'chuj tu', y(k),z(k)
5461         enddo
5462         dthett=thet_pred_mean*ssd
5463         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5464 C Derivatives of the "mean" values in gamma1 and gamma2.
5465         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5466      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5467          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5468      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5469          if (it.eq.10) then
5470       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5471      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5472         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5473      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5474          endif
5475         if (theta(i).gt.pi-delta) then
5476           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5477      &         E_tc0)
5478           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5479           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5480           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5481      &        E_theta)
5482           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5483      &        E_tc)
5484         else if (theta(i).lt.delta) then
5485           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5486           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5487           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5488      &        E_theta)
5489           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5490           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5491      &        E_tc)
5492         else
5493           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5494      &        E_theta,E_tc)
5495         endif
5496         etheta=etheta+ethetai
5497         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5498      &      'ebend',i,ethetai,theta(i),itype(i)
5499         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5500         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5501         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5502       enddo
5503 C Ufff.... We've done all this!!!
5504       return
5505       end
5506 C---------------------------------------------------------------------------
5507       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5508      &     E_tc)
5509       implicit real*8 (a-h,o-z)
5510       include 'DIMENSIONS'
5511       include 'COMMON.LOCAL'
5512       include 'COMMON.IOUNITS'
5513       common /calcthet/ term1,term2,termm,diffak,ratak,
5514      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5515      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5516 C Calculate the contributions to both Gaussian lobes.
5517 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5518 C The "polynomial part" of the "standard deviation" of this part of
5519 C the distributioni.
5520 ccc        write (iout,*) thetai,thet_pred_mean
5521         sig=polthet(3,it)
5522         do j=2,0,-1
5523           sig=sig*thet_pred_mean+polthet(j,it)
5524         enddo
5525 C Derivative of the "interior part" of the "standard deviation of the"
5526 C gamma-dependent Gaussian lobe in t_c.
5527         sigtc=3*polthet(3,it)
5528         do j=2,1,-1
5529           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5530         enddo
5531         sigtc=sig*sigtc
5532 C Set the parameters of both Gaussian lobes of the distribution.
5533 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5534         fac=sig*sig+sigc0(it)
5535         sigcsq=fac+fac
5536         sigc=1.0D0/sigcsq
5537 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5538         sigsqtc=-4.0D0*sigcsq*sigtc
5539 c       print *,i,sig,sigtc,sigsqtc
5540 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5541         sigtc=-sigtc/(fac*fac)
5542 C Following variable is sigma(t_c)**(-2)
5543         sigcsq=sigcsq*sigcsq
5544         sig0i=sig0(it)
5545         sig0inv=1.0D0/sig0i**2
5546         delthec=thetai-thet_pred_mean
5547         delthe0=thetai-theta0i
5548         term1=-0.5D0*sigcsq*delthec*delthec
5549         term2=-0.5D0*sig0inv*delthe0*delthe0
5550 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5551 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5552 C NaNs in taking the logarithm. We extract the largest exponent which is added
5553 C to the energy (this being the log of the distribution) at the end of energy
5554 C term evaluation for this virtual-bond angle.
5555         if (term1.gt.term2) then
5556           termm=term1
5557           term2=dexp(term2-termm)
5558           term1=1.0d0
5559         else
5560           termm=term2
5561           term1=dexp(term1-termm)
5562           term2=1.0d0
5563         endif
5564 C The ratio between the gamma-independent and gamma-dependent lobes of
5565 C the distribution is a Gaussian function of thet_pred_mean too.
5566         diffak=gthet(2,it)-thet_pred_mean
5567         ratak=diffak/gthet(3,it)**2
5568         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5569 C Let's differentiate it in thet_pred_mean NOW.
5570         aktc=ak*ratak
5571 C Now put together the distribution terms to make complete distribution.
5572         termexp=term1+ak*term2
5573         termpre=sigc+ak*sig0i
5574 C Contribution of the bending energy from this theta is just the -log of
5575 C the sum of the contributions from the two lobes and the pre-exponential
5576 C factor. Simple enough, isn't it?
5577         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5578 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5579 C NOW the derivatives!!!
5580 C 6/6/97 Take into account the deformation.
5581         E_theta=(delthec*sigcsq*term1
5582      &       +ak*delthe0*sig0inv*term2)/termexp
5583         E_tc=((sigtc+aktc*sig0i)/termpre
5584      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5585      &       aktc*term2)/termexp)
5586       return
5587       end
5588 c-----------------------------------------------------------------------------
5589       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5590       implicit real*8 (a-h,o-z)
5591       include 'DIMENSIONS'
5592       include 'COMMON.LOCAL'
5593       include 'COMMON.IOUNITS'
5594       common /calcthet/ term1,term2,termm,diffak,ratak,
5595      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5596      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5597       delthec=thetai-thet_pred_mean
5598       delthe0=thetai-theta0i
5599 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5600       t3 = thetai-thet_pred_mean
5601       t6 = t3**2
5602       t9 = term1
5603       t12 = t3*sigcsq
5604       t14 = t12+t6*sigsqtc
5605       t16 = 1.0d0
5606       t21 = thetai-theta0i
5607       t23 = t21**2
5608       t26 = term2
5609       t27 = t21*t26
5610       t32 = termexp
5611       t40 = t32**2
5612       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5613      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5614      & *(-t12*t9-ak*sig0inv*t27)
5615       return
5616       end
5617 #else
5618 C--------------------------------------------------------------------------
5619       subroutine ebend(etheta)
5620 C
5621 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5622 C angles gamma and its derivatives in consecutive thetas and gammas.
5623 C ab initio-derived potentials from
5624 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5625 C
5626       implicit real*8 (a-h,o-z)
5627       include 'DIMENSIONS'
5628       include 'COMMON.LOCAL'
5629       include 'COMMON.GEO'
5630       include 'COMMON.INTERACT'
5631       include 'COMMON.DERIV'
5632       include 'COMMON.VAR'
5633       include 'COMMON.CHAIN'
5634       include 'COMMON.IOUNITS'
5635       include 'COMMON.NAMES'
5636       include 'COMMON.FFIELD'
5637       include 'COMMON.CONTROL'
5638       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5639      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5640      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5641      & sinph1ph2(maxdouble,maxdouble)
5642       logical lprn /.false./, lprn1 /.false./
5643       etheta=0.0D0
5644       do i=ithet_start,ithet_end
5645 c        print *,i,itype(i-1),itype(i),itype(i-2)
5646         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5647      &  .or.itype(i).eq.ntyp1) cycle
5648 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5649
5650         if (iabs(itype(i+1)).eq.20) iblock=2
5651         if (iabs(itype(i+1)).ne.20) iblock=1
5652         dethetai=0.0d0
5653         dephii=0.0d0
5654         dephii1=0.0d0
5655         theti2=0.5d0*theta(i)
5656         ityp2=ithetyp((itype(i-1)))
5657         do k=1,nntheterm
5658           coskt(k)=dcos(k*theti2)
5659           sinkt(k)=dsin(k*theti2)
5660         enddo
5661         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5662 #ifdef OSF
5663           phii=phi(i)
5664           if (phii.ne.phii) phii=150.0
5665 #else
5666           phii=phi(i)
5667 #endif
5668           ityp1=ithetyp((itype(i-2)))
5669 C propagation of chirality for glycine type
5670           do k=1,nsingle
5671             cosph1(k)=dcos(k*phii)
5672             sinph1(k)=dsin(k*phii)
5673           enddo
5674         else
5675           phii=0.0d0
5676           ityp1=nthetyp+1
5677           do k=1,nsingle
5678             cosph1(k)=0.0d0
5679             sinph1(k)=0.0d0
5680           enddo
5681         endif
5682         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5683 #ifdef OSF
5684           phii1=phi(i+1)
5685           if (phii1.ne.phii1) phii1=150.0
5686           phii1=pinorm(phii1)
5687 #else
5688           phii1=phi(i+1)
5689 #endif
5690           ityp3=ithetyp((itype(i)))
5691           do k=1,nsingle
5692             cosph2(k)=dcos(k*phii1)
5693             sinph2(k)=dsin(k*phii1)
5694           enddo
5695         else
5696           phii1=0.0d0
5697           ityp3=nthetyp+1
5698           do k=1,nsingle
5699             cosph2(k)=0.0d0
5700             sinph2(k)=0.0d0
5701           enddo
5702         endif
5703         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5704         do k=1,ndouble
5705           do l=1,k-1
5706             ccl=cosph1(l)*cosph2(k-l)
5707             ssl=sinph1(l)*sinph2(k-l)
5708             scl=sinph1(l)*cosph2(k-l)
5709             csl=cosph1(l)*sinph2(k-l)
5710             cosph1ph2(l,k)=ccl-ssl
5711             cosph1ph2(k,l)=ccl+ssl
5712             sinph1ph2(l,k)=scl+csl
5713             sinph1ph2(k,l)=scl-csl
5714           enddo
5715         enddo
5716         if (lprn) then
5717         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5718      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5719         write (iout,*) "coskt and sinkt"
5720         do k=1,nntheterm
5721           write (iout,*) k,coskt(k),sinkt(k)
5722         enddo
5723         endif
5724         do k=1,ntheterm
5725           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5726           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5727      &      *coskt(k)
5728           if (lprn)
5729      &    write (iout,*) "k",k,"
5730      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5731      &     " ethetai",ethetai
5732         enddo
5733         if (lprn) then
5734         write (iout,*) "cosph and sinph"
5735         do k=1,nsingle
5736           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5737         enddo
5738         write (iout,*) "cosph1ph2 and sinph2ph2"
5739         do k=2,ndouble
5740           do l=1,k-1
5741             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5742      &         sinph1ph2(l,k),sinph1ph2(k,l)
5743           enddo
5744         enddo
5745         write(iout,*) "ethetai",ethetai
5746         endif
5747         do m=1,ntheterm2
5748           do k=1,nsingle
5749             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5750      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5751      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5752      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5753             ethetai=ethetai+sinkt(m)*aux
5754             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5755             dephii=dephii+k*sinkt(m)*(
5756      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5757      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5758             dephii1=dephii1+k*sinkt(m)*(
5759      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5760      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5761             if (lprn)
5762      &      write (iout,*) "m",m," k",k," bbthet",
5763      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5764      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5765      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5766      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5767           enddo
5768         enddo
5769         if (lprn)
5770      &  write(iout,*) "ethetai",ethetai
5771         do m=1,ntheterm3
5772           do k=2,ndouble
5773             do l=1,k-1
5774               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5775      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5776      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5777      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5778               ethetai=ethetai+sinkt(m)*aux
5779               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5780               dephii=dephii+l*sinkt(m)*(
5781      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5782      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5783      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5784      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5785               dephii1=dephii1+(k-l)*sinkt(m)*(
5786      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5787      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5788      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5789      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5790               if (lprn) then
5791               write (iout,*) "m",m," k",k," l",l," ffthet",
5792      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5793      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5794      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5795      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5796      &            " ethetai",ethetai
5797               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5798      &            cosph1ph2(k,l)*sinkt(m),
5799      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5800               endif
5801             enddo
5802           enddo
5803         enddo
5804 10      continue
5805 c        lprn1=.true.
5806         if (lprn1)
5807      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5808      &   i,theta(i)*rad2deg,phii*rad2deg,
5809      &   phii1*rad2deg,ethetai
5810 c        lprn1=.false.
5811         etheta=etheta+ethetai
5812         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5813         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5814         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5815       enddo
5816       return
5817       end
5818 #endif
5819 #ifdef CRYST_SC
5820 c-----------------------------------------------------------------------------
5821       subroutine esc(escloc)
5822 C Calculate the local energy of a side chain and its derivatives in the
5823 C corresponding virtual-bond valence angles THETA and the spherical angles
5824 C ALPHA and OMEGA.
5825       implicit real*8 (a-h,o-z)
5826       include 'DIMENSIONS'
5827       include 'COMMON.GEO'
5828       include 'COMMON.LOCAL'
5829       include 'COMMON.VAR'
5830       include 'COMMON.INTERACT'
5831       include 'COMMON.DERIV'
5832       include 'COMMON.CHAIN'
5833       include 'COMMON.IOUNITS'
5834       include 'COMMON.NAMES'
5835       include 'COMMON.FFIELD'
5836       include 'COMMON.CONTROL'
5837       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5838      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5839       common /sccalc/ time11,time12,time112,theti,it,nlobit
5840       delta=0.02d0*pi
5841       escloc=0.0D0
5842 c     write (iout,'(a)') 'ESC'
5843       do i=loc_start,loc_end
5844         it=itype(i)
5845         if (it.eq.ntyp1) cycle
5846         if (it.eq.10) goto 1
5847         nlobit=nlob(iabs(it))
5848 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5849 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5850         theti=theta(i+1)-pipol
5851         x(1)=dtan(theti)
5852         x(2)=alph(i)
5853         x(3)=omeg(i)
5854
5855         if (x(2).gt.pi-delta) then
5856           xtemp(1)=x(1)
5857           xtemp(2)=pi-delta
5858           xtemp(3)=x(3)
5859           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5860           xtemp(2)=pi
5861           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5862           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5863      &        escloci,dersc(2))
5864           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5865      &        ddersc0(1),dersc(1))
5866           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5867      &        ddersc0(3),dersc(3))
5868           xtemp(2)=pi-delta
5869           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5870           xtemp(2)=pi
5871           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5872           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5873      &            dersc0(2),esclocbi,dersc02)
5874           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5875      &            dersc12,dersc01)
5876           call splinthet(x(2),0.5d0*delta,ss,ssd)
5877           dersc0(1)=dersc01
5878           dersc0(2)=dersc02
5879           dersc0(3)=0.0d0
5880           do k=1,3
5881             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5882           enddo
5883           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5884 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5885 c    &             esclocbi,ss,ssd
5886           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5887 c         escloci=esclocbi
5888 c         write (iout,*) escloci
5889         else if (x(2).lt.delta) then
5890           xtemp(1)=x(1)
5891           xtemp(2)=delta
5892           xtemp(3)=x(3)
5893           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5894           xtemp(2)=0.0d0
5895           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5896           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5897      &        escloci,dersc(2))
5898           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5899      &        ddersc0(1),dersc(1))
5900           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5901      &        ddersc0(3),dersc(3))
5902           xtemp(2)=delta
5903           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5904           xtemp(2)=0.0d0
5905           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5906           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5907      &            dersc0(2),esclocbi,dersc02)
5908           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5909      &            dersc12,dersc01)
5910           dersc0(1)=dersc01
5911           dersc0(2)=dersc02
5912           dersc0(3)=0.0d0
5913           call splinthet(x(2),0.5d0*delta,ss,ssd)
5914           do k=1,3
5915             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5916           enddo
5917           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5918 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5919 c    &             esclocbi,ss,ssd
5920           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5921 c         write (iout,*) escloci
5922         else
5923           call enesc(x,escloci,dersc,ddummy,.false.)
5924         endif
5925
5926         escloc=escloc+escloci
5927         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5928      &     'escloc',i,escloci
5929 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5930
5931         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5932      &   wscloc*dersc(1)
5933         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5934         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5935     1   continue
5936       enddo
5937       return
5938       end
5939 C---------------------------------------------------------------------------
5940       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5941       implicit real*8 (a-h,o-z)
5942       include 'DIMENSIONS'
5943       include 'COMMON.GEO'
5944       include 'COMMON.LOCAL'
5945       include 'COMMON.IOUNITS'
5946       common /sccalc/ time11,time12,time112,theti,it,nlobit
5947       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5948       double precision contr(maxlob,-1:1)
5949       logical mixed
5950 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5951         escloc_i=0.0D0
5952         do j=1,3
5953           dersc(j)=0.0D0
5954           if (mixed) ddersc(j)=0.0d0
5955         enddo
5956         x3=x(3)
5957
5958 C Because of periodicity of the dependence of the SC energy in omega we have
5959 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5960 C To avoid underflows, first compute & store the exponents.
5961
5962         do iii=-1,1
5963
5964           x(3)=x3+iii*dwapi
5965
5966           do j=1,nlobit
5967             do k=1,3
5968               z(k)=x(k)-censc(k,j,it)
5969             enddo
5970             do k=1,3
5971               Axk=0.0D0
5972               do l=1,3
5973                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5974               enddo
5975               Ax(k,j,iii)=Axk
5976             enddo
5977             expfac=0.0D0
5978             do k=1,3
5979               expfac=expfac+Ax(k,j,iii)*z(k)
5980             enddo
5981             contr(j,iii)=expfac
5982           enddo ! j
5983
5984         enddo ! iii
5985
5986         x(3)=x3
5987 C As in the case of ebend, we want to avoid underflows in exponentiation and
5988 C subsequent NaNs and INFs in energy calculation.
5989 C Find the largest exponent
5990         emin=contr(1,-1)
5991         do iii=-1,1
5992           do j=1,nlobit
5993             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5994           enddo
5995         enddo
5996         emin=0.5D0*emin
5997 cd      print *,'it=',it,' emin=',emin
5998
5999 C Compute the contribution to SC energy and derivatives
6000         do iii=-1,1
6001
6002           do j=1,nlobit
6003 #ifdef OSF
6004             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6005             if(adexp.ne.adexp) adexp=1.0
6006             expfac=dexp(adexp)
6007 #else
6008             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6009 #endif
6010 cd          print *,'j=',j,' expfac=',expfac
6011             escloc_i=escloc_i+expfac
6012             do k=1,3
6013               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6014             enddo
6015             if (mixed) then
6016               do k=1,3,2
6017                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6018      &            +gaussc(k,2,j,it))*expfac
6019               enddo
6020             endif
6021           enddo
6022
6023         enddo ! iii
6024
6025         dersc(1)=dersc(1)/cos(theti)**2
6026         ddersc(1)=ddersc(1)/cos(theti)**2
6027         ddersc(3)=ddersc(3)
6028
6029         escloci=-(dlog(escloc_i)-emin)
6030         do j=1,3
6031           dersc(j)=dersc(j)/escloc_i
6032         enddo
6033         if (mixed) then
6034           do j=1,3,2
6035             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6036           enddo
6037         endif
6038       return
6039       end
6040 C------------------------------------------------------------------------------
6041       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6042       implicit real*8 (a-h,o-z)
6043       include 'DIMENSIONS'
6044       include 'COMMON.GEO'
6045       include 'COMMON.LOCAL'
6046       include 'COMMON.IOUNITS'
6047       common /sccalc/ time11,time12,time112,theti,it,nlobit
6048       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6049       double precision contr(maxlob)
6050       logical mixed
6051
6052       escloc_i=0.0D0
6053
6054       do j=1,3
6055         dersc(j)=0.0D0
6056       enddo
6057
6058       do j=1,nlobit
6059         do k=1,2
6060           z(k)=x(k)-censc(k,j,it)
6061         enddo
6062         z(3)=dwapi
6063         do k=1,3
6064           Axk=0.0D0
6065           do l=1,3
6066             Axk=Axk+gaussc(l,k,j,it)*z(l)
6067           enddo
6068           Ax(k,j)=Axk
6069         enddo
6070         expfac=0.0D0
6071         do k=1,3
6072           expfac=expfac+Ax(k,j)*z(k)
6073         enddo
6074         contr(j)=expfac
6075       enddo ! j
6076
6077 C As in the case of ebend, we want to avoid underflows in exponentiation and
6078 C subsequent NaNs and INFs in energy calculation.
6079 C Find the largest exponent
6080       emin=contr(1)
6081       do j=1,nlobit
6082         if (emin.gt.contr(j)) emin=contr(j)
6083       enddo
6084       emin=0.5D0*emin
6085
6086 C Compute the contribution to SC energy and derivatives
6087
6088       dersc12=0.0d0
6089       do j=1,nlobit
6090         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6091         escloc_i=escloc_i+expfac
6092         do k=1,2
6093           dersc(k)=dersc(k)+Ax(k,j)*expfac
6094         enddo
6095         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6096      &            +gaussc(1,2,j,it))*expfac
6097         dersc(3)=0.0d0
6098       enddo
6099
6100       dersc(1)=dersc(1)/cos(theti)**2
6101       dersc12=dersc12/cos(theti)**2
6102       escloci=-(dlog(escloc_i)-emin)
6103       do j=1,2
6104         dersc(j)=dersc(j)/escloc_i
6105       enddo
6106       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6107       return
6108       end
6109 #else
6110 c----------------------------------------------------------------------------------
6111       subroutine esc(escloc)
6112 C Calculate the local energy of a side chain and its derivatives in the
6113 C corresponding virtual-bond valence angles THETA and the spherical angles
6114 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6115 C added by Urszula Kozlowska. 07/11/2007
6116 C
6117       implicit real*8 (a-h,o-z)
6118       include 'DIMENSIONS'
6119       include 'COMMON.GEO'
6120       include 'COMMON.LOCAL'
6121       include 'COMMON.VAR'
6122       include 'COMMON.SCROT'
6123       include 'COMMON.INTERACT'
6124       include 'COMMON.DERIV'
6125       include 'COMMON.CHAIN'
6126       include 'COMMON.IOUNITS'
6127       include 'COMMON.NAMES'
6128       include 'COMMON.FFIELD'
6129       include 'COMMON.CONTROL'
6130       include 'COMMON.VECTORS'
6131       double precision x_prime(3),y_prime(3),z_prime(3)
6132      &    , sumene,dsc_i,dp2_i,x(65),
6133      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6134      &    de_dxx,de_dyy,de_dzz,de_dt
6135       double precision s1_t,s1_6_t,s2_t,s2_6_t
6136       double precision
6137      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6138      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6139      & dt_dCi(3),dt_dCi1(3)
6140       common /sccalc/ time11,time12,time112,theti,it,nlobit
6141       delta=0.02d0*pi
6142       escloc=0.0D0
6143       do i=loc_start,loc_end
6144         if (itype(i).eq.ntyp1) cycle
6145         costtab(i+1) =dcos(theta(i+1))
6146         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6147         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6148         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6149         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6150         cosfac=dsqrt(cosfac2)
6151         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6152         sinfac=dsqrt(sinfac2)
6153         it=iabs(itype(i))
6154         if (it.eq.10) goto 1
6155 c
6156 C  Compute the axes of tghe local cartesian coordinates system; store in
6157 c   x_prime, y_prime and z_prime
6158 c
6159         do j=1,3
6160           x_prime(j) = 0.00
6161           y_prime(j) = 0.00
6162           z_prime(j) = 0.00
6163         enddo
6164 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6165 C     &   dc_norm(3,i+nres)
6166         do j = 1,3
6167           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6168           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6169         enddo
6170         do j = 1,3
6171           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6172         enddo
6173 c       write (2,*) "i",i
6174 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6175 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6176 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6177 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6178 c      & " xy",scalar(x_prime(1),y_prime(1)),
6179 c      & " xz",scalar(x_prime(1),z_prime(1)),
6180 c      & " yy",scalar(y_prime(1),y_prime(1)),
6181 c      & " yz",scalar(y_prime(1),z_prime(1)),
6182 c      & " zz",scalar(z_prime(1),z_prime(1))
6183 c
6184 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6185 C to local coordinate system. Store in xx, yy, zz.
6186 c
6187         xx=0.0d0
6188         yy=0.0d0
6189         zz=0.0d0
6190         do j = 1,3
6191           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6192           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6193           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6194         enddo
6195
6196         xxtab(i)=xx
6197         yytab(i)=yy
6198         zztab(i)=zz
6199 C
6200 C Compute the energy of the ith side cbain
6201 C
6202 c        write (2,*) "xx",xx," yy",yy," zz",zz
6203         it=iabs(itype(i))
6204         do j = 1,65
6205           x(j) = sc_parmin(j,it)
6206         enddo
6207 #ifdef CHECK_COORD
6208 Cc diagnostics - remove later
6209         xx1 = dcos(alph(2))
6210         yy1 = dsin(alph(2))*dcos(omeg(2))
6211         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6212         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6213      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6214      &    xx1,yy1,zz1
6215 C,"  --- ", xx_w,yy_w,zz_w
6216 c end diagnostics
6217 #endif
6218         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6219      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6220      &   + x(10)*yy*zz
6221         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6222      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6223      & + x(20)*yy*zz
6224         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6225      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6226      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6227      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6228      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6229      &  +x(40)*xx*yy*zz
6230         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6231      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6232      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6233      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6234      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6235      &  +x(60)*xx*yy*zz
6236         dsc_i   = 0.743d0+x(61)
6237         dp2_i   = 1.9d0+x(62)
6238         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6239      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6240         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6241      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6242         s1=(1+x(63))/(0.1d0 + dscp1)
6243         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6244         s2=(1+x(65))/(0.1d0 + dscp2)
6245         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6246         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6247      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6248 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6249 c     &   sumene4,
6250 c     &   dscp1,dscp2,sumene
6251 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6252         escloc = escloc + sumene
6253 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6254 c     & ,zz,xx,yy
6255 c#define DEBUG
6256 #ifdef DEBUG
6257 C
6258 C This section to check the numerical derivatives of the energy of ith side
6259 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6260 C #define DEBUG in the code to turn it on.
6261 C
6262         write (2,*) "sumene               =",sumene
6263         aincr=1.0d-7
6264         xxsave=xx
6265         xx=xx+aincr
6266         write (2,*) xx,yy,zz
6267         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6268         de_dxx_num=(sumenep-sumene)/aincr
6269         xx=xxsave
6270         write (2,*) "xx+ sumene from enesc=",sumenep
6271         yysave=yy
6272         yy=yy+aincr
6273         write (2,*) xx,yy,zz
6274         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6275         de_dyy_num=(sumenep-sumene)/aincr
6276         yy=yysave
6277         write (2,*) "yy+ sumene from enesc=",sumenep
6278         zzsave=zz
6279         zz=zz+aincr
6280         write (2,*) xx,yy,zz
6281         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6282         de_dzz_num=(sumenep-sumene)/aincr
6283         zz=zzsave
6284         write (2,*) "zz+ sumene from enesc=",sumenep
6285         costsave=cost2tab(i+1)
6286         sintsave=sint2tab(i+1)
6287         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6288         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6289         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6290         de_dt_num=(sumenep-sumene)/aincr
6291         write (2,*) " t+ sumene from enesc=",sumenep
6292         cost2tab(i+1)=costsave
6293         sint2tab(i+1)=sintsave
6294 C End of diagnostics section.
6295 #endif
6296 C
6297 C Compute the gradient of esc
6298 C
6299 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6300         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6301         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6302         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6303         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6304         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6305         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6306         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6307         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6308         pom1=(sumene3*sint2tab(i+1)+sumene1)
6309      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6310         pom2=(sumene4*cost2tab(i+1)+sumene2)
6311      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6312         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6313         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6314      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6315      &  +x(40)*yy*zz
6316         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6317         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6318      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6319      &  +x(60)*yy*zz
6320         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6321      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6322      &        +(pom1+pom2)*pom_dx
6323 #ifdef DEBUG
6324         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6325 #endif
6326 C
6327         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6328         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6329      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6330      &  +x(40)*xx*zz
6331         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6332         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6333      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6334      &  +x(59)*zz**2 +x(60)*xx*zz
6335         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6336      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6337      &        +(pom1-pom2)*pom_dy
6338 #ifdef DEBUG
6339         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6340 #endif
6341 C
6342         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6343      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6344      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6345      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6346      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6347      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6348      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6349      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6350 #ifdef DEBUG
6351         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6352 #endif
6353 C
6354         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6355      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6356      &  +pom1*pom_dt1+pom2*pom_dt2
6357 #ifdef DEBUG
6358         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6359 #endif
6360 c#undef DEBUG
6361 c
6362 C
6363        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6364        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6365        cosfac2xx=cosfac2*xx
6366        sinfac2yy=sinfac2*yy
6367        do k = 1,3
6368          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6369      &      vbld_inv(i+1)
6370          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6371      &      vbld_inv(i)
6372          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6373          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6374 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6375 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6376 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6377 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6378          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6379          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6380          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6381          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6382          dZZ_Ci1(k)=0.0d0
6383          dZZ_Ci(k)=0.0d0
6384          do j=1,3
6385            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6386      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6387            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6388      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6389          enddo
6390
6391          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6392          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6393          dZZ_XYZ(k)=vbld_inv(i+nres)*
6394      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6395 c
6396          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6397          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6398        enddo
6399
6400        do k=1,3
6401          dXX_Ctab(k,i)=dXX_Ci(k)
6402          dXX_C1tab(k,i)=dXX_Ci1(k)
6403          dYY_Ctab(k,i)=dYY_Ci(k)
6404          dYY_C1tab(k,i)=dYY_Ci1(k)
6405          dZZ_Ctab(k,i)=dZZ_Ci(k)
6406          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6407          dXX_XYZtab(k,i)=dXX_XYZ(k)
6408          dYY_XYZtab(k,i)=dYY_XYZ(k)
6409          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6410        enddo
6411
6412        do k = 1,3
6413 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6414 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6415 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6416 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6417 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6418 c     &    dt_dci(k)
6419 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6420 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6421          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6422      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6423          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6424      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6425          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6426      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6427        enddo
6428 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6429 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6430
6431 C to check gradient call subroutine check_grad
6432
6433     1 continue
6434       enddo
6435       return
6436       end
6437 c------------------------------------------------------------------------------
6438       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6439       implicit none
6440       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6441      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6442       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6443      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6444      &   + x(10)*yy*zz
6445       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6446      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6447      & + x(20)*yy*zz
6448       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6449      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6450      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6451      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6452      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6453      &  +x(40)*xx*yy*zz
6454       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6455      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6456      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6457      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6458      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6459      &  +x(60)*xx*yy*zz
6460       dsc_i   = 0.743d0+x(61)
6461       dp2_i   = 1.9d0+x(62)
6462       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6463      &          *(xx*cost2+yy*sint2))
6464       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6465      &          *(xx*cost2-yy*sint2))
6466       s1=(1+x(63))/(0.1d0 + dscp1)
6467       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6468       s2=(1+x(65))/(0.1d0 + dscp2)
6469       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6470       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6471      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6472       enesc=sumene
6473       return
6474       end
6475 #endif
6476 c------------------------------------------------------------------------------
6477       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6478 C
6479 C This procedure calculates two-body contact function g(rij) and its derivative:
6480 C
6481 C           eps0ij                                     !       x < -1
6482 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6483 C            0                                         !       x > 1
6484 C
6485 C where x=(rij-r0ij)/delta
6486 C
6487 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6488 C
6489       implicit none
6490       double precision rij,r0ij,eps0ij,fcont,fprimcont
6491       double precision x,x2,x4,delta
6492 c     delta=0.02D0*r0ij
6493 c      delta=0.2D0*r0ij
6494       x=(rij-r0ij)/delta
6495       if (x.lt.-1.0D0) then
6496         fcont=eps0ij
6497         fprimcont=0.0D0
6498       else if (x.le.1.0D0) then
6499         x2=x*x
6500         x4=x2*x2
6501         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6502         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6503       else
6504         fcont=0.0D0
6505         fprimcont=0.0D0
6506       endif
6507       return
6508       end
6509 c------------------------------------------------------------------------------
6510       subroutine splinthet(theti,delta,ss,ssder)
6511       implicit real*8 (a-h,o-z)
6512       include 'DIMENSIONS'
6513       include 'COMMON.VAR'
6514       include 'COMMON.GEO'
6515       thetup=pi-delta
6516       thetlow=delta
6517       if (theti.gt.pipol) then
6518         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6519       else
6520         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6521         ssder=-ssder
6522       endif
6523       return
6524       end
6525 c------------------------------------------------------------------------------
6526       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6527       implicit none
6528       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6529       double precision ksi,ksi2,ksi3,a1,a2,a3
6530       a1=fprim0*delta/(f1-f0)
6531       a2=3.0d0-2.0d0*a1
6532       a3=a1-2.0d0
6533       ksi=(x-x0)/delta
6534       ksi2=ksi*ksi
6535       ksi3=ksi2*ksi
6536       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6537       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6538       return
6539       end
6540 c------------------------------------------------------------------------------
6541       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6542       implicit none
6543       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6544       double precision ksi,ksi2,ksi3,a1,a2,a3
6545       ksi=(x-x0)/delta
6546       ksi2=ksi*ksi
6547       ksi3=ksi2*ksi
6548       a1=fprim0x*delta
6549       a2=3*(f1x-f0x)-2*fprim0x*delta
6550       a3=fprim0x*delta-2*(f1x-f0x)
6551       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6552       return
6553       end
6554 C-----------------------------------------------------------------------------
6555 #ifdef CRYST_TOR
6556 C-----------------------------------------------------------------------------
6557       subroutine etor(etors,edihcnstr)
6558       implicit real*8 (a-h,o-z)
6559       include 'DIMENSIONS'
6560       include 'COMMON.VAR'
6561       include 'COMMON.GEO'
6562       include 'COMMON.LOCAL'
6563       include 'COMMON.TORSION'
6564       include 'COMMON.INTERACT'
6565       include 'COMMON.DERIV'
6566       include 'COMMON.CHAIN'
6567       include 'COMMON.NAMES'
6568       include 'COMMON.IOUNITS'
6569       include 'COMMON.FFIELD'
6570       include 'COMMON.TORCNSTR'
6571       include 'COMMON.CONTROL'
6572       logical lprn
6573 C Set lprn=.true. for debugging
6574       lprn=.false.
6575 c      lprn=.true.
6576       etors=0.0D0
6577       do i=iphi_start,iphi_end
6578       etors_ii=0.0D0
6579         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6580      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6581         itori=itortyp(itype(i-2))
6582         itori1=itortyp(itype(i-1))
6583         phii=phi(i)
6584         gloci=0.0D0
6585 C Proline-Proline pair is a special case...
6586         if (itori.eq.3 .and. itori1.eq.3) then
6587           if (phii.gt.-dwapi3) then
6588             cosphi=dcos(3*phii)
6589             fac=1.0D0/(1.0D0-cosphi)
6590             etorsi=v1(1,3,3)*fac
6591             etorsi=etorsi+etorsi
6592             etors=etors+etorsi-v1(1,3,3)
6593             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6594             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6595           endif
6596           do j=1,3
6597             v1ij=v1(j+1,itori,itori1)
6598             v2ij=v2(j+1,itori,itori1)
6599             cosphi=dcos(j*phii)
6600             sinphi=dsin(j*phii)
6601             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6602             if (energy_dec) etors_ii=etors_ii+
6603      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6604             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6605           enddo
6606         else
6607           do j=1,nterm_old
6608             v1ij=v1(j,itori,itori1)
6609             v2ij=v2(j,itori,itori1)
6610             cosphi=dcos(j*phii)
6611             sinphi=dsin(j*phii)
6612             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6613             if (energy_dec) etors_ii=etors_ii+
6614      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6615             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6616           enddo
6617         endif
6618         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6619              'etor',i,etors_ii
6620         if (lprn)
6621      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6622      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6623      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6624         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6625 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6626       enddo
6627 ! 6/20/98 - dihedral angle constraints
6628       edihcnstr=0.0d0
6629       do i=1,ndih_constr
6630         itori=idih_constr(i)
6631         phii=phi(itori)
6632         difi=phii-phi0(i)
6633         if (difi.gt.drange(i)) then
6634           difi=difi-drange(i)
6635           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6636           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6637         else if (difi.lt.-drange(i)) then
6638           difi=difi+drange(i)
6639           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6640           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6641         endif
6642 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6643 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6644       enddo
6645 !      write (iout,*) 'edihcnstr',edihcnstr
6646       return
6647       end
6648 c------------------------------------------------------------------------------
6649       subroutine etor_d(etors_d)
6650       etors_d=0.0d0
6651       return
6652       end
6653 c----------------------------------------------------------------------------
6654 #else
6655       subroutine etor(etors,edihcnstr)
6656       implicit real*8 (a-h,o-z)
6657       include 'DIMENSIONS'
6658       include 'COMMON.VAR'
6659       include 'COMMON.GEO'
6660       include 'COMMON.LOCAL'
6661       include 'COMMON.TORSION'
6662       include 'COMMON.INTERACT'
6663       include 'COMMON.DERIV'
6664       include 'COMMON.CHAIN'
6665       include 'COMMON.NAMES'
6666       include 'COMMON.IOUNITS'
6667       include 'COMMON.FFIELD'
6668       include 'COMMON.TORCNSTR'
6669       include 'COMMON.CONTROL'
6670       logical lprn
6671 C Set lprn=.true. for debugging
6672       lprn=.false.
6673 c     lprn=.true.
6674       etors=0.0D0
6675       do i=iphi_start,iphi_end
6676 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6677 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6678 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6679 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6680         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6681      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6682 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6683 C For introducing the NH3+ and COO- group please check the etor_d for reference
6684 C and guidance
6685         etors_ii=0.0D0
6686          if (iabs(itype(i)).eq.20) then
6687          iblock=2
6688          else
6689          iblock=1
6690          endif
6691         itori=itortyp(itype(i-2))
6692         itori1=itortyp(itype(i-1))
6693         phii=phi(i)
6694         gloci=0.0D0
6695 C Regular cosine and sine terms
6696         do j=1,nterm(itori,itori1,iblock)
6697           v1ij=v1(j,itori,itori1,iblock)
6698           v2ij=v2(j,itori,itori1,iblock)
6699           cosphi=dcos(j*phii)
6700           sinphi=dsin(j*phii)
6701           etors=etors+v1ij*cosphi+v2ij*sinphi
6702           if (energy_dec) etors_ii=etors_ii+
6703      &                v1ij*cosphi+v2ij*sinphi
6704           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6705         enddo
6706 C Lorentz terms
6707 C                         v1
6708 C  E = SUM ----------------------------------- - v1
6709 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6710 C
6711         cosphi=dcos(0.5d0*phii)
6712         sinphi=dsin(0.5d0*phii)
6713         do j=1,nlor(itori,itori1,iblock)
6714           vl1ij=vlor1(j,itori,itori1)
6715           vl2ij=vlor2(j,itori,itori1)
6716           vl3ij=vlor3(j,itori,itori1)
6717           pom=vl2ij*cosphi+vl3ij*sinphi
6718           pom1=1.0d0/(pom*pom+1.0d0)
6719           etors=etors+vl1ij*pom1
6720           if (energy_dec) etors_ii=etors_ii+
6721      &                vl1ij*pom1
6722           pom=-pom*pom1*pom1
6723           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6724         enddo
6725 C Subtract the constant term
6726         etors=etors-v0(itori,itori1,iblock)
6727           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6728      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6729         if (lprn)
6730      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6731      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6732      &  (v1(j,itori,itori1,iblock),j=1,6),
6733      &  (v2(j,itori,itori1,iblock),j=1,6)
6734         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6735 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6736       enddo
6737 ! 6/20/98 - dihedral angle constraints
6738       edihcnstr=0.0d0
6739 c      do i=1,ndih_constr
6740       do i=idihconstr_start,idihconstr_end
6741         itori=idih_constr(i)
6742         phii=phi(itori)
6743         difi=pinorm(phii-phi0(i))
6744         if (difi.gt.drange(i)) then
6745           difi=difi-drange(i)
6746           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6748         else if (difi.lt.-drange(i)) then
6749           difi=difi+drange(i)
6750           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6751           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6752         else
6753           difi=0.0
6754         endif
6755 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6756 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6757 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6758       enddo
6759 cd       write (iout,*) 'edihcnstr',edihcnstr
6760       return
6761       end
6762 c----------------------------------------------------------------------------
6763       subroutine etor_d(etors_d)
6764 C 6/23/01 Compute double torsional energy
6765       implicit real*8 (a-h,o-z)
6766       include 'DIMENSIONS'
6767       include 'COMMON.VAR'
6768       include 'COMMON.GEO'
6769       include 'COMMON.LOCAL'
6770       include 'COMMON.TORSION'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.DERIV'
6773       include 'COMMON.CHAIN'
6774       include 'COMMON.NAMES'
6775       include 'COMMON.IOUNITS'
6776       include 'COMMON.FFIELD'
6777       include 'COMMON.TORCNSTR'
6778       logical lprn
6779 C Set lprn=.true. for debugging
6780       lprn=.false.
6781 c     lprn=.true.
6782       etors_d=0.0D0
6783 c      write(iout,*) "a tu??"
6784       do i=iphid_start,iphid_end
6785 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6786 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6787 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6788 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6789 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6790          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6791      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6792      &  (itype(i+1).eq.ntyp1)) cycle
6793 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6794         itori=itortyp(itype(i-2))
6795         itori1=itortyp(itype(i-1))
6796         itori2=itortyp(itype(i))
6797         phii=phi(i)
6798         phii1=phi(i+1)
6799         gloci1=0.0D0
6800         gloci2=0.0D0
6801         iblock=1
6802         if (iabs(itype(i+1)).eq.20) iblock=2
6803 C Iblock=2 Proline type
6804 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6805 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6806 C        if (itype(i+1).eq.ntyp1) iblock=3
6807 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6808 C IS or IS NOT need for this
6809 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6810 C        is (itype(i-3).eq.ntyp1) ntblock=2
6811 C        ntblock is N-terminal blocking group
6812
6813 C Regular cosine and sine terms
6814         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6815 C Example of changes for NH3+ blocking group
6816 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6817 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6818           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6819           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6820           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6821           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6822           cosphi1=dcos(j*phii)
6823           sinphi1=dsin(j*phii)
6824           cosphi2=dcos(j*phii1)
6825           sinphi2=dsin(j*phii1)
6826           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6827      &     v2cij*cosphi2+v2sij*sinphi2
6828           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6829           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6830         enddo
6831         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6832           do l=1,k-1
6833             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6834             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6835             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6836             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6837             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6838             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6839             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6840             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6841             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6842      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6843             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6844      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6845             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6846      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6847           enddo
6848         enddo
6849         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6850         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6851       enddo
6852       return
6853       end
6854 #endif
6855 c------------------------------------------------------------------------------
6856       subroutine eback_sc_corr(esccor)
6857 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6858 c        conformational states; temporarily implemented as differences
6859 c        between UNRES torsional potentials (dependent on three types of
6860 c        residues) and the torsional potentials dependent on all 20 types
6861 c        of residues computed from AM1  energy surfaces of terminally-blocked
6862 c        amino-acid residues.
6863       implicit real*8 (a-h,o-z)
6864       include 'DIMENSIONS'
6865       include 'COMMON.VAR'
6866       include 'COMMON.GEO'
6867       include 'COMMON.LOCAL'
6868       include 'COMMON.TORSION'
6869       include 'COMMON.SCCOR'
6870       include 'COMMON.INTERACT'
6871       include 'COMMON.DERIV'
6872       include 'COMMON.CHAIN'
6873       include 'COMMON.NAMES'
6874       include 'COMMON.IOUNITS'
6875       include 'COMMON.FFIELD'
6876       include 'COMMON.CONTROL'
6877       logical lprn
6878 C Set lprn=.true. for debugging
6879       lprn=.false.
6880 c      lprn=.true.
6881 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6882       esccor=0.0D0
6883       do i=itau_start,itau_end
6884         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6885         esccor_ii=0.0D0
6886         isccori=isccortyp(itype(i-2))
6887         isccori1=isccortyp(itype(i-1))
6888 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6889         phii=phi(i)
6890         do intertyp=1,3 !intertyp
6891 cc Added 09 May 2012 (Adasko)
6892 cc  Intertyp means interaction type of backbone mainchain correlation:
6893 c   1 = SC...Ca...Ca...Ca
6894 c   2 = Ca...Ca...Ca...SC
6895 c   3 = SC...Ca...Ca...SCi
6896         gloci=0.0D0
6897         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6898      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6899      &      (itype(i-1).eq.ntyp1)))
6900      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6901      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6902      &     .or.(itype(i).eq.ntyp1)))
6903      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6904      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6905      &      (itype(i-3).eq.ntyp1)))) cycle
6906         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6907         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6908      & cycle
6909        do j=1,nterm_sccor(isccori,isccori1)
6910           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6911           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6912           cosphi=dcos(j*tauangle(intertyp,i))
6913           sinphi=dsin(j*tauangle(intertyp,i))
6914           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6915           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6916         enddo
6917 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6918         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6919         if (lprn)
6920      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6921      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6922      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6923      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6924         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6925        enddo !intertyp
6926       enddo
6927
6928       return
6929       end
6930 c----------------------------------------------------------------------------
6931       subroutine multibody(ecorr)
6932 C This subroutine calculates multi-body contributions to energy following
6933 C the idea of Skolnick et al. If side chains I and J make a contact and
6934 C at the same time side chains I+1 and J+1 make a contact, an extra
6935 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6936       implicit real*8 (a-h,o-z)
6937       include 'DIMENSIONS'
6938       include 'COMMON.IOUNITS'
6939       include 'COMMON.DERIV'
6940       include 'COMMON.INTERACT'
6941       include 'COMMON.CONTACTS'
6942       double precision gx(3),gx1(3)
6943       logical lprn
6944
6945 C Set lprn=.true. for debugging
6946       lprn=.false.
6947
6948       if (lprn) then
6949         write (iout,'(a)') 'Contact function values:'
6950         do i=nnt,nct-2
6951           write (iout,'(i2,20(1x,i2,f10.5))')
6952      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6953         enddo
6954       endif
6955       ecorr=0.0D0
6956       do i=nnt,nct
6957         do j=1,3
6958           gradcorr(j,i)=0.0D0
6959           gradxorr(j,i)=0.0D0
6960         enddo
6961       enddo
6962       do i=nnt,nct-2
6963
6964         DO ISHIFT = 3,4
6965
6966         i1=i+ishift
6967         num_conti=num_cont(i)
6968         num_conti1=num_cont(i1)
6969         do jj=1,num_conti
6970           j=jcont(jj,i)
6971           do kk=1,num_conti1
6972             j1=jcont(kk,i1)
6973             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6974 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6975 cd   &                   ' ishift=',ishift
6976 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6977 C The system gains extra energy.
6978               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6979             endif   ! j1==j+-ishift
6980           enddo     ! kk
6981         enddo       ! jj
6982
6983         ENDDO ! ISHIFT
6984
6985       enddo         ! i
6986       return
6987       end
6988 c------------------------------------------------------------------------------
6989       double precision function esccorr(i,j,k,l,jj,kk)
6990       implicit real*8 (a-h,o-z)
6991       include 'DIMENSIONS'
6992       include 'COMMON.IOUNITS'
6993       include 'COMMON.DERIV'
6994       include 'COMMON.INTERACT'
6995       include 'COMMON.CONTACTS'
6996       double precision gx(3),gx1(3)
6997       logical lprn
6998       lprn=.false.
6999       eij=facont(jj,i)
7000       ekl=facont(kk,k)
7001 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7002 C Calculate the multi-body contribution to energy.
7003 C Calculate multi-body contributions to the gradient.
7004 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7005 cd   & k,l,(gacont(m,kk,k),m=1,3)
7006       do m=1,3
7007         gx(m) =ekl*gacont(m,jj,i)
7008         gx1(m)=eij*gacont(m,kk,k)
7009         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7010         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7011         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7012         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7013       enddo
7014       do m=i,j-1
7015         do ll=1,3
7016           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7017         enddo
7018       enddo
7019       do m=k,l-1
7020         do ll=1,3
7021           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7022         enddo
7023       enddo
7024       esccorr=-eij*ekl
7025       return
7026       end
7027 c------------------------------------------------------------------------------
7028       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7029 C This subroutine calculates multi-body contributions to hydrogen-bonding
7030       implicit real*8 (a-h,o-z)
7031       include 'DIMENSIONS'
7032       include 'COMMON.IOUNITS'
7033 #ifdef MPI
7034       include "mpif.h"
7035       parameter (max_cont=maxconts)
7036       parameter (max_dim=26)
7037       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7038       double precision zapas(max_dim,maxconts,max_fg_procs),
7039      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7040       common /przechowalnia/ zapas
7041       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7042      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7043 #endif
7044       include 'COMMON.SETUP'
7045       include 'COMMON.FFIELD'
7046       include 'COMMON.DERIV'
7047       include 'COMMON.INTERACT'
7048       include 'COMMON.CONTACTS'
7049       include 'COMMON.CONTROL'
7050       include 'COMMON.LOCAL'
7051       double precision gx(3),gx1(3),time00
7052       logical lprn,ldone
7053
7054 C Set lprn=.true. for debugging
7055       lprn=.false.
7056 #ifdef MPI
7057       n_corr=0
7058       n_corr1=0
7059       if (nfgtasks.le.1) goto 30
7060       if (lprn) then
7061         write (iout,'(a)') 'Contact function values before RECEIVE:'
7062         do i=nnt,nct-2
7063           write (iout,'(2i3,50(1x,i2,f5.2))')
7064      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7065      &    j=1,num_cont_hb(i))
7066         enddo
7067       endif
7068       call flush(iout)
7069       do i=1,ntask_cont_from
7070         ncont_recv(i)=0
7071       enddo
7072       do i=1,ntask_cont_to
7073         ncont_sent(i)=0
7074       enddo
7075 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7076 c     & ntask_cont_to
7077 C Make the list of contacts to send to send to other procesors
7078 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7079 c      call flush(iout)
7080       do i=iturn3_start,iturn3_end
7081 c        write (iout,*) "make contact list turn3",i," num_cont",
7082 c     &    num_cont_hb(i)
7083         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7084       enddo
7085       do i=iturn4_start,iturn4_end
7086 c        write (iout,*) "make contact list turn4",i," num_cont",
7087 c     &   num_cont_hb(i)
7088         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7089       enddo
7090       do ii=1,nat_sent
7091         i=iat_sent(ii)
7092 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7093 c     &    num_cont_hb(i)
7094         do j=1,num_cont_hb(i)
7095         do k=1,4
7096           jjc=jcont_hb(j,i)
7097           iproc=iint_sent_local(k,jjc,ii)
7098 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7099           if (iproc.gt.0) then
7100             ncont_sent(iproc)=ncont_sent(iproc)+1
7101             nn=ncont_sent(iproc)
7102             zapas(1,nn,iproc)=i
7103             zapas(2,nn,iproc)=jjc
7104             zapas(3,nn,iproc)=facont_hb(j,i)
7105             zapas(4,nn,iproc)=ees0p(j,i)
7106             zapas(5,nn,iproc)=ees0m(j,i)
7107             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7108             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7109             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7110             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7111             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7112             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7113             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7114             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7115             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7116             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7117             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7118             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7119             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7120             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7121             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7122             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7123             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7124             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7125             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7126             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7127             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7128           endif
7129         enddo
7130         enddo
7131       enddo
7132       if (lprn) then
7133       write (iout,*)
7134      &  "Numbers of contacts to be sent to other processors",
7135      &  (ncont_sent(i),i=1,ntask_cont_to)
7136       write (iout,*) "Contacts sent"
7137       do ii=1,ntask_cont_to
7138         nn=ncont_sent(ii)
7139         iproc=itask_cont_to(ii)
7140         write (iout,*) nn," contacts to processor",iproc,
7141      &   " of CONT_TO_COMM group"
7142         do i=1,nn
7143           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7144         enddo
7145       enddo
7146       call flush(iout)
7147       endif
7148       CorrelType=477
7149       CorrelID=fg_rank+1
7150       CorrelType1=478
7151       CorrelID1=nfgtasks+fg_rank+1
7152       ireq=0
7153 C Receive the numbers of needed contacts from other processors
7154       do ii=1,ntask_cont_from
7155         iproc=itask_cont_from(ii)
7156         ireq=ireq+1
7157         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7158      &    FG_COMM,req(ireq),IERR)
7159       enddo
7160 c      write (iout,*) "IRECV ended"
7161 c      call flush(iout)
7162 C Send the number of contacts needed by other processors
7163       do ii=1,ntask_cont_to
7164         iproc=itask_cont_to(ii)
7165         ireq=ireq+1
7166         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7167      &    FG_COMM,req(ireq),IERR)
7168       enddo
7169 c      write (iout,*) "ISEND ended"
7170 c      write (iout,*) "number of requests (nn)",ireq
7171       call flush(iout)
7172       if (ireq.gt.0)
7173      &  call MPI_Waitall(ireq,req,status_array,ierr)
7174 c      write (iout,*)
7175 c     &  "Numbers of contacts to be received from other processors",
7176 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7177 c      call flush(iout)
7178 C Receive contacts
7179       ireq=0
7180       do ii=1,ntask_cont_from
7181         iproc=itask_cont_from(ii)
7182         nn=ncont_recv(ii)
7183 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7184 c     &   " of CONT_TO_COMM group"
7185         call flush(iout)
7186         if (nn.gt.0) then
7187           ireq=ireq+1
7188           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7189      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7190 c          write (iout,*) "ireq,req",ireq,req(ireq)
7191         endif
7192       enddo
7193 C Send the contacts to processors that need them
7194       do ii=1,ntask_cont_to
7195         iproc=itask_cont_to(ii)
7196         nn=ncont_sent(ii)
7197 c        write (iout,*) nn," contacts to processor",iproc,
7198 c     &   " of CONT_TO_COMM group"
7199         if (nn.gt.0) then
7200           ireq=ireq+1
7201           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7202      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7203 c          write (iout,*) "ireq,req",ireq,req(ireq)
7204 c          do i=1,nn
7205 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7206 c          enddo
7207         endif
7208       enddo
7209 c      write (iout,*) "number of requests (contacts)",ireq
7210 c      write (iout,*) "req",(req(i),i=1,4)
7211 c      call flush(iout)
7212       if (ireq.gt.0)
7213      & call MPI_Waitall(ireq,req,status_array,ierr)
7214       do iii=1,ntask_cont_from
7215         iproc=itask_cont_from(iii)
7216         nn=ncont_recv(iii)
7217         if (lprn) then
7218         write (iout,*) "Received",nn," contacts from processor",iproc,
7219      &   " of CONT_FROM_COMM group"
7220         call flush(iout)
7221         do i=1,nn
7222           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7223         enddo
7224         call flush(iout)
7225         endif
7226         do i=1,nn
7227           ii=zapas_recv(1,i,iii)
7228 c Flag the received contacts to prevent double-counting
7229           jj=-zapas_recv(2,i,iii)
7230 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7231 c          call flush(iout)
7232           nnn=num_cont_hb(ii)+1
7233           num_cont_hb(ii)=nnn
7234           jcont_hb(nnn,ii)=jj
7235           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7236           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7237           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7238           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7239           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7240           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7241           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7242           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7243           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7244           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7245           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7246           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7247           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7248           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7249           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7250           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7251           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7252           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7253           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7254           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7255           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7256           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7257           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7258           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7259         enddo
7260       enddo
7261       call flush(iout)
7262       if (lprn) then
7263         write (iout,'(a)') 'Contact function values after receive:'
7264         do i=nnt,nct-2
7265           write (iout,'(2i3,50(1x,i3,f5.2))')
7266      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7267      &    j=1,num_cont_hb(i))
7268         enddo
7269         call flush(iout)
7270       endif
7271    30 continue
7272 #endif
7273       if (lprn) then
7274         write (iout,'(a)') 'Contact function values:'
7275         do i=nnt,nct-2
7276           write (iout,'(2i3,50(1x,i3,f5.2))')
7277      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7278      &    j=1,num_cont_hb(i))
7279         enddo
7280       endif
7281       ecorr=0.0D0
7282 C Remove the loop below after debugging !!!
7283       do i=nnt,nct
7284         do j=1,3
7285           gradcorr(j,i)=0.0D0
7286           gradxorr(j,i)=0.0D0
7287         enddo
7288       enddo
7289 C Calculate the local-electrostatic correlation terms
7290       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7291         i1=i+1
7292         num_conti=num_cont_hb(i)
7293         num_conti1=num_cont_hb(i+1)
7294         do jj=1,num_conti
7295           j=jcont_hb(jj,i)
7296           jp=iabs(j)
7297           do kk=1,num_conti1
7298             j1=jcont_hb(kk,i1)
7299             jp1=iabs(j1)
7300 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7301 c     &         ' jj=',jj,' kk=',kk
7302             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7303      &          .or. j.lt.0 .and. j1.gt.0) .and.
7304      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7305 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7306 C The system gains extra energy.
7307               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7308               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7309      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7310               n_corr=n_corr+1
7311             else if (j1.eq.j) then
7312 C Contacts I-J and I-(J+1) occur simultaneously.
7313 C The system loses extra energy.
7314 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7315             endif
7316           enddo ! kk
7317           do kk=1,num_conti
7318             j1=jcont_hb(kk,i)
7319 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7320 c    &         ' jj=',jj,' kk=',kk
7321             if (j1.eq.j+1) then
7322 C Contacts I-J and (I+1)-J occur simultaneously.
7323 C The system loses extra energy.
7324 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7325             endif ! j1==j+1
7326           enddo ! kk
7327         enddo ! jj
7328       enddo ! i
7329       return
7330       end
7331 c------------------------------------------------------------------------------
7332       subroutine add_hb_contact(ii,jj,itask)
7333       implicit real*8 (a-h,o-z)
7334       include "DIMENSIONS"
7335       include "COMMON.IOUNITS"
7336       integer max_cont
7337       integer max_dim
7338       parameter (max_cont=maxconts)
7339       parameter (max_dim=26)
7340       include "COMMON.CONTACTS"
7341       double precision zapas(max_dim,maxconts,max_fg_procs),
7342      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7343       common /przechowalnia/ zapas
7344       integer i,j,ii,jj,iproc,itask(4),nn
7345 c      write (iout,*) "itask",itask
7346       do i=1,2
7347         iproc=itask(i)
7348         if (iproc.gt.0) then
7349           do j=1,num_cont_hb(ii)
7350             jjc=jcont_hb(j,ii)
7351 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7352             if (jjc.eq.jj) then
7353               ncont_sent(iproc)=ncont_sent(iproc)+1
7354               nn=ncont_sent(iproc)
7355               zapas(1,nn,iproc)=ii
7356               zapas(2,nn,iproc)=jjc
7357               zapas(3,nn,iproc)=facont_hb(j,ii)
7358               zapas(4,nn,iproc)=ees0p(j,ii)
7359               zapas(5,nn,iproc)=ees0m(j,ii)
7360               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7361               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7362               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7363               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7364               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7365               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7366               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7367               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7368               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7369               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7370               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7371               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7372               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7373               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7374               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7375               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7376               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7377               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7378               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7379               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7380               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7381               exit
7382             endif
7383           enddo
7384         endif
7385       enddo
7386       return
7387       end
7388 c------------------------------------------------------------------------------
7389       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7390      &  n_corr1)
7391 C This subroutine calculates multi-body contributions to hydrogen-bonding
7392       implicit real*8 (a-h,o-z)
7393       include 'DIMENSIONS'
7394       include 'COMMON.IOUNITS'
7395 #ifdef MPI
7396       include "mpif.h"
7397       parameter (max_cont=maxconts)
7398       parameter (max_dim=70)
7399       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7400       double precision zapas(max_dim,maxconts,max_fg_procs),
7401      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7402       common /przechowalnia/ zapas
7403       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7404      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7405 #endif
7406       include 'COMMON.SETUP'
7407       include 'COMMON.FFIELD'
7408       include 'COMMON.DERIV'
7409       include 'COMMON.LOCAL'
7410       include 'COMMON.INTERACT'
7411       include 'COMMON.CONTACTS'
7412       include 'COMMON.CHAIN'
7413       include 'COMMON.CONTROL'
7414       double precision gx(3),gx1(3)
7415       integer num_cont_hb_old(maxres)
7416       logical lprn,ldone
7417       double precision eello4,eello5,eelo6,eello_turn6
7418       external eello4,eello5,eello6,eello_turn6
7419 C Set lprn=.true. for debugging
7420       lprn=.false.
7421       eturn6=0.0d0
7422 #ifdef MPI
7423       do i=1,nres
7424         num_cont_hb_old(i)=num_cont_hb(i)
7425       enddo
7426       n_corr=0
7427       n_corr1=0
7428       if (nfgtasks.le.1) goto 30
7429       if (lprn) then
7430         write (iout,'(a)') 'Contact function values before RECEIVE:'
7431         do i=nnt,nct-2
7432           write (iout,'(2i3,50(1x,i2,f5.2))')
7433      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7434      &    j=1,num_cont_hb(i))
7435         enddo
7436       endif
7437       call flush(iout)
7438       do i=1,ntask_cont_from
7439         ncont_recv(i)=0
7440       enddo
7441       do i=1,ntask_cont_to
7442         ncont_sent(i)=0
7443       enddo
7444 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7445 c     & ntask_cont_to
7446 C Make the list of contacts to send to send to other procesors
7447       do i=iturn3_start,iturn3_end
7448 c        write (iout,*) "make contact list turn3",i," num_cont",
7449 c     &    num_cont_hb(i)
7450         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7451       enddo
7452       do i=iturn4_start,iturn4_end
7453 c        write (iout,*) "make contact list turn4",i," num_cont",
7454 c     &   num_cont_hb(i)
7455         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7456       enddo
7457       do ii=1,nat_sent
7458         i=iat_sent(ii)
7459 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7460 c     &    num_cont_hb(i)
7461         do j=1,num_cont_hb(i)
7462         do k=1,4
7463           jjc=jcont_hb(j,i)
7464           iproc=iint_sent_local(k,jjc,ii)
7465 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7466           if (iproc.ne.0) then
7467             ncont_sent(iproc)=ncont_sent(iproc)+1
7468             nn=ncont_sent(iproc)
7469             zapas(1,nn,iproc)=i
7470             zapas(2,nn,iproc)=jjc
7471             zapas(3,nn,iproc)=d_cont(j,i)
7472             ind=3
7473             do kk=1,3
7474               ind=ind+1
7475               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7476             enddo
7477             do kk=1,2
7478               do ll=1,2
7479                 ind=ind+1
7480                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7481               enddo
7482             enddo
7483             do jj=1,5
7484               do kk=1,3
7485                 do ll=1,2
7486                   do mm=1,2
7487                     ind=ind+1
7488                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7489                   enddo
7490                 enddo
7491               enddo
7492             enddo
7493           endif
7494         enddo
7495         enddo
7496       enddo
7497       if (lprn) then
7498       write (iout,*)
7499      &  "Numbers of contacts to be sent to other processors",
7500      &  (ncont_sent(i),i=1,ntask_cont_to)
7501       write (iout,*) "Contacts sent"
7502       do ii=1,ntask_cont_to
7503         nn=ncont_sent(ii)
7504         iproc=itask_cont_to(ii)
7505         write (iout,*) nn," contacts to processor",iproc,
7506      &   " of CONT_TO_COMM group"
7507         do i=1,nn
7508           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7509         enddo
7510       enddo
7511       call flush(iout)
7512       endif
7513       CorrelType=477
7514       CorrelID=fg_rank+1
7515       CorrelType1=478
7516       CorrelID1=nfgtasks+fg_rank+1
7517       ireq=0
7518 C Receive the numbers of needed contacts from other processors
7519       do ii=1,ntask_cont_from
7520         iproc=itask_cont_from(ii)
7521         ireq=ireq+1
7522         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7523      &    FG_COMM,req(ireq),IERR)
7524       enddo
7525 c      write (iout,*) "IRECV ended"
7526 c      call flush(iout)
7527 C Send the number of contacts needed by other processors
7528       do ii=1,ntask_cont_to
7529         iproc=itask_cont_to(ii)
7530         ireq=ireq+1
7531         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7532      &    FG_COMM,req(ireq),IERR)
7533       enddo
7534 c      write (iout,*) "ISEND ended"
7535 c      write (iout,*) "number of requests (nn)",ireq
7536       call flush(iout)
7537       if (ireq.gt.0)
7538      &  call MPI_Waitall(ireq,req,status_array,ierr)
7539 c      write (iout,*)
7540 c     &  "Numbers of contacts to be received from other processors",
7541 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7542 c      call flush(iout)
7543 C Receive contacts
7544       ireq=0
7545       do ii=1,ntask_cont_from
7546         iproc=itask_cont_from(ii)
7547         nn=ncont_recv(ii)
7548 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7549 c     &   " of CONT_TO_COMM group"
7550         call flush(iout)
7551         if (nn.gt.0) then
7552           ireq=ireq+1
7553           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7554      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7555 c          write (iout,*) "ireq,req",ireq,req(ireq)
7556         endif
7557       enddo
7558 C Send the contacts to processors that need them
7559       do ii=1,ntask_cont_to
7560         iproc=itask_cont_to(ii)
7561         nn=ncont_sent(ii)
7562 c        write (iout,*) nn," contacts to processor",iproc,
7563 c     &   " of CONT_TO_COMM group"
7564         if (nn.gt.0) then
7565           ireq=ireq+1
7566           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7567      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7568 c          write (iout,*) "ireq,req",ireq,req(ireq)
7569 c          do i=1,nn
7570 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7571 c          enddo
7572         endif
7573       enddo
7574 c      write (iout,*) "number of requests (contacts)",ireq
7575 c      write (iout,*) "req",(req(i),i=1,4)
7576 c      call flush(iout)
7577       if (ireq.gt.0)
7578      & call MPI_Waitall(ireq,req,status_array,ierr)
7579       do iii=1,ntask_cont_from
7580         iproc=itask_cont_from(iii)
7581         nn=ncont_recv(iii)
7582         if (lprn) then
7583         write (iout,*) "Received",nn," contacts from processor",iproc,
7584      &   " of CONT_FROM_COMM group"
7585         call flush(iout)
7586         do i=1,nn
7587           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7588         enddo
7589         call flush(iout)
7590         endif
7591         do i=1,nn
7592           ii=zapas_recv(1,i,iii)
7593 c Flag the received contacts to prevent double-counting
7594           jj=-zapas_recv(2,i,iii)
7595 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7596 c          call flush(iout)
7597           nnn=num_cont_hb(ii)+1
7598           num_cont_hb(ii)=nnn
7599           jcont_hb(nnn,ii)=jj
7600           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7601           ind=3
7602           do kk=1,3
7603             ind=ind+1
7604             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7605           enddo
7606           do kk=1,2
7607             do ll=1,2
7608               ind=ind+1
7609               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7610             enddo
7611           enddo
7612           do jj=1,5
7613             do kk=1,3
7614               do ll=1,2
7615                 do mm=1,2
7616                   ind=ind+1
7617                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7618                 enddo
7619               enddo
7620             enddo
7621           enddo
7622         enddo
7623       enddo
7624       call flush(iout)
7625       if (lprn) then
7626         write (iout,'(a)') 'Contact function values after receive:'
7627         do i=nnt,nct-2
7628           write (iout,'(2i3,50(1x,i3,5f6.3))')
7629      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7630      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7631         enddo
7632         call flush(iout)
7633       endif
7634    30 continue
7635 #endif
7636       if (lprn) then
7637         write (iout,'(a)') 'Contact function values:'
7638         do i=nnt,nct-2
7639           write (iout,'(2i3,50(1x,i2,5f6.3))')
7640      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7641      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7642         enddo
7643       endif
7644       ecorr=0.0D0
7645       ecorr5=0.0d0
7646       ecorr6=0.0d0
7647 C Remove the loop below after debugging !!!
7648       do i=nnt,nct
7649         do j=1,3
7650           gradcorr(j,i)=0.0D0
7651           gradxorr(j,i)=0.0D0
7652         enddo
7653       enddo
7654 C Calculate the dipole-dipole interaction energies
7655       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7656       do i=iatel_s,iatel_e+1
7657         num_conti=num_cont_hb(i)
7658         do jj=1,num_conti
7659           j=jcont_hb(jj,i)
7660 #ifdef MOMENT
7661           call dipole(i,j,jj)
7662 #endif
7663         enddo
7664       enddo
7665       endif
7666 C Calculate the local-electrostatic correlation terms
7667 c                write (iout,*) "gradcorr5 in eello5 before loop"
7668 c                do iii=1,nres
7669 c                  write (iout,'(i5,3f10.5)')
7670 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7671 c                enddo
7672       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7673 c        write (iout,*) "corr loop i",i
7674         i1=i+1
7675         num_conti=num_cont_hb(i)
7676         num_conti1=num_cont_hb(i+1)
7677         do jj=1,num_conti
7678           j=jcont_hb(jj,i)
7679           jp=iabs(j)
7680           do kk=1,num_conti1
7681             j1=jcont_hb(kk,i1)
7682             jp1=iabs(j1)
7683 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7684 c     &         ' jj=',jj,' kk=',kk
7685 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7686             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7687      &          .or. j.lt.0 .and. j1.gt.0) .and.
7688      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7689 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7690 C The system gains extra energy.
7691               n_corr=n_corr+1
7692               sqd1=dsqrt(d_cont(jj,i))
7693               sqd2=dsqrt(d_cont(kk,i1))
7694               sred_geom = sqd1*sqd2
7695               IF (sred_geom.lt.cutoff_corr) THEN
7696                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7697      &            ekont,fprimcont)
7698 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7699 cd     &         ' jj=',jj,' kk=',kk
7700                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7701                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7702                 do l=1,3
7703                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7704                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7705                 enddo
7706                 n_corr1=n_corr1+1
7707 cd               write (iout,*) 'sred_geom=',sred_geom,
7708 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7709 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7710 cd               write (iout,*) "g_contij",g_contij
7711 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7712 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7713                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7714                 if (wcorr4.gt.0.0d0)
7715      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7716                   if (energy_dec.and.wcorr4.gt.0.0d0)
7717      1                 write (iout,'(a6,4i5,0pf7.3)')
7718      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7719 c                write (iout,*) "gradcorr5 before eello5"
7720 c                do iii=1,nres
7721 c                  write (iout,'(i5,3f10.5)')
7722 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7723 c                enddo
7724                 if (wcorr5.gt.0.0d0)
7725      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7726 c                write (iout,*) "gradcorr5 after eello5"
7727 c                do iii=1,nres
7728 c                  write (iout,'(i5,3f10.5)')
7729 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7730 c                enddo
7731                   if (energy_dec.and.wcorr5.gt.0.0d0)
7732      1                 write (iout,'(a6,4i5,0pf7.3)')
7733      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7734 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7735 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7736                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7737      &               .or. wturn6.eq.0.0d0))then
7738 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7739                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7740                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7741      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7742 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7743 cd     &            'ecorr6=',ecorr6
7744 cd                write (iout,'(4e15.5)') sred_geom,
7745 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7746 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7747 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7748                 else if (wturn6.gt.0.0d0
7749      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7750 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7751                   eturn6=eturn6+eello_turn6(i,jj,kk)
7752                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7753      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7754 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7755                 endif
7756               ENDIF
7757 1111          continue
7758             endif
7759           enddo ! kk
7760         enddo ! jj
7761       enddo ! i
7762       do i=1,nres
7763         num_cont_hb(i)=num_cont_hb_old(i)
7764       enddo
7765 c                write (iout,*) "gradcorr5 in eello5"
7766 c                do iii=1,nres
7767 c                  write (iout,'(i5,3f10.5)')
7768 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7769 c                enddo
7770       return
7771       end
7772 c------------------------------------------------------------------------------
7773       subroutine add_hb_contact_eello(ii,jj,itask)
7774       implicit real*8 (a-h,o-z)
7775       include "DIMENSIONS"
7776       include "COMMON.IOUNITS"
7777       integer max_cont
7778       integer max_dim
7779       parameter (max_cont=maxconts)
7780       parameter (max_dim=70)
7781       include "COMMON.CONTACTS"
7782       double precision zapas(max_dim,maxconts,max_fg_procs),
7783      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7784       common /przechowalnia/ zapas
7785       integer i,j,ii,jj,iproc,itask(4),nn
7786 c      write (iout,*) "itask",itask
7787       do i=1,2
7788         iproc=itask(i)
7789         if (iproc.gt.0) then
7790           do j=1,num_cont_hb(ii)
7791             jjc=jcont_hb(j,ii)
7792 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7793             if (jjc.eq.jj) then
7794               ncont_sent(iproc)=ncont_sent(iproc)+1
7795               nn=ncont_sent(iproc)
7796               zapas(1,nn,iproc)=ii
7797               zapas(2,nn,iproc)=jjc
7798               zapas(3,nn,iproc)=d_cont(j,ii)
7799               ind=3
7800               do kk=1,3
7801                 ind=ind+1
7802                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7803               enddo
7804               do kk=1,2
7805                 do ll=1,2
7806                   ind=ind+1
7807                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7808                 enddo
7809               enddo
7810               do jj=1,5
7811                 do kk=1,3
7812                   do ll=1,2
7813                     do mm=1,2
7814                       ind=ind+1
7815                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7816                     enddo
7817                   enddo
7818                 enddo
7819               enddo
7820               exit
7821             endif
7822           enddo
7823         endif
7824       enddo
7825       return
7826       end
7827 c------------------------------------------------------------------------------
7828       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7829       implicit real*8 (a-h,o-z)
7830       include 'DIMENSIONS'
7831       include 'COMMON.IOUNITS'
7832       include 'COMMON.DERIV'
7833       include 'COMMON.INTERACT'
7834       include 'COMMON.CONTACTS'
7835       double precision gx(3),gx1(3)
7836       logical lprn
7837       lprn=.false.
7838       eij=facont_hb(jj,i)
7839       ekl=facont_hb(kk,k)
7840       ees0pij=ees0p(jj,i)
7841       ees0pkl=ees0p(kk,k)
7842       ees0mij=ees0m(jj,i)
7843       ees0mkl=ees0m(kk,k)
7844       ekont=eij*ekl
7845       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7846 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7847 C Following 4 lines for diagnostics.
7848 cd    ees0pkl=0.0D0
7849 cd    ees0pij=1.0D0
7850 cd    ees0mkl=0.0D0
7851 cd    ees0mij=1.0D0
7852 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7853 c     & 'Contacts ',i,j,
7854 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7855 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7856 c     & 'gradcorr_long'
7857 C Calculate the multi-body contribution to energy.
7858 c      ecorr=ecorr+ekont*ees
7859 C Calculate multi-body contributions to the gradient.
7860       coeffpees0pij=coeffp*ees0pij
7861       coeffmees0mij=coeffm*ees0mij
7862       coeffpees0pkl=coeffp*ees0pkl
7863       coeffmees0mkl=coeffm*ees0mkl
7864       do ll=1,3
7865 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7866         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7867      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7868      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7869         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7870      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7871      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7872 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7873         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7874      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7875      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7876         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7877      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7878      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7879         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7880      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7881      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7882         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7883         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7884         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7885      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7886      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7887         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7888         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7889 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7890       enddo
7891 c      write (iout,*)
7892 cgrad      do m=i+1,j-1
7893 cgrad        do ll=1,3
7894 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7895 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7896 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7897 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7898 cgrad        enddo
7899 cgrad      enddo
7900 cgrad      do m=k+1,l-1
7901 cgrad        do ll=1,3
7902 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7903 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7904 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7905 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7906 cgrad        enddo
7907 cgrad      enddo
7908 c      write (iout,*) "ehbcorr",ekont*ees
7909       ehbcorr=ekont*ees
7910       return
7911       end
7912 #ifdef MOMENT
7913 C---------------------------------------------------------------------------
7914       subroutine dipole(i,j,jj)
7915       implicit real*8 (a-h,o-z)
7916       include 'DIMENSIONS'
7917       include 'COMMON.IOUNITS'
7918       include 'COMMON.CHAIN'
7919       include 'COMMON.FFIELD'
7920       include 'COMMON.DERIV'
7921       include 'COMMON.INTERACT'
7922       include 'COMMON.CONTACTS'
7923       include 'COMMON.TORSION'
7924       include 'COMMON.VAR'
7925       include 'COMMON.GEO'
7926       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7927      &  auxmat(2,2)
7928       iti1 = itortyp(itype(i+1))
7929       if (j.lt.nres-1) then
7930         itj1 = itortyp(itype(j+1))
7931       else
7932         itj1=ntortyp
7933       endif
7934       do iii=1,2
7935         dipi(iii,1)=Ub2(iii,i)
7936         dipderi(iii)=Ub2der(iii,i)
7937         dipi(iii,2)=b1(iii,i+1)
7938         dipj(iii,1)=Ub2(iii,j)
7939         dipderj(iii)=Ub2der(iii,j)
7940         dipj(iii,2)=b1(iii,j+1)
7941       enddo
7942       kkk=0
7943       do iii=1,2
7944         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7945         do jjj=1,2
7946           kkk=kkk+1
7947           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7948         enddo
7949       enddo
7950       do kkk=1,5
7951         do lll=1,3
7952           mmm=0
7953           do iii=1,2
7954             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7955      &        auxvec(1))
7956             do jjj=1,2
7957               mmm=mmm+1
7958               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7959             enddo
7960           enddo
7961         enddo
7962       enddo
7963       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7964       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7965       do iii=1,2
7966         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7967       enddo
7968       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7969       do iii=1,2
7970         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7971       enddo
7972       return
7973       end
7974 #endif
7975 C---------------------------------------------------------------------------
7976       subroutine calc_eello(i,j,k,l,jj,kk)
7977 C
7978 C This subroutine computes matrices and vectors needed to calculate
7979 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7980 C
7981       implicit real*8 (a-h,o-z)
7982       include 'DIMENSIONS'
7983       include 'COMMON.IOUNITS'
7984       include 'COMMON.CHAIN'
7985       include 'COMMON.DERIV'
7986       include 'COMMON.INTERACT'
7987       include 'COMMON.CONTACTS'
7988       include 'COMMON.TORSION'
7989       include 'COMMON.VAR'
7990       include 'COMMON.GEO'
7991       include 'COMMON.FFIELD'
7992       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7993      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7994       logical lprn
7995       common /kutas/ lprn
7996 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7997 cd     & ' jj=',jj,' kk=',kk
7998 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7999 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8000 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8001       do iii=1,2
8002         do jjj=1,2
8003           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8004           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8005         enddo
8006       enddo
8007       call transpose2(aa1(1,1),aa1t(1,1))
8008       call transpose2(aa2(1,1),aa2t(1,1))
8009       do kkk=1,5
8010         do lll=1,3
8011           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8012      &      aa1tder(1,1,lll,kkk))
8013           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8014      &      aa2tder(1,1,lll,kkk))
8015         enddo
8016       enddo
8017       if (l.eq.j+1) then
8018 C parallel orientation of the two CA-CA-CA frames.
8019         if (i.gt.1) then
8020           iti=itortyp(itype(i))
8021         else
8022           iti=ntortyp
8023         endif
8024         itk1=itortyp(itype(k+1))
8025         itj=itortyp(itype(j))
8026         if (l.lt.nres-1) then
8027           itl1=itortyp(itype(l+1))
8028         else
8029           itl1=ntortyp
8030         endif
8031 C A1 kernel(j+1) A2T
8032 cd        do iii=1,2
8033 cd          write (iout,'(3f10.5,5x,3f10.5)')
8034 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8035 cd        enddo
8036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8037      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8038      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8039 C Following matrices are needed only for 6-th order cumulants
8040         IF (wcorr6.gt.0.0d0) THEN
8041         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8042      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8043      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8044         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8045      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8046      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8047      &   ADtEAderx(1,1,1,1,1,1))
8048         lprn=.false.
8049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8050      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8051      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8052      &   ADtEA1derx(1,1,1,1,1,1))
8053         ENDIF
8054 C End 6-th order cumulants
8055 cd        lprn=.false.
8056 cd        if (lprn) then
8057 cd        write (2,*) 'In calc_eello6'
8058 cd        do iii=1,2
8059 cd          write (2,*) 'iii=',iii
8060 cd          do kkk=1,5
8061 cd            write (2,*) 'kkk=',kkk
8062 cd            do jjj=1,2
8063 cd              write (2,'(3(2f10.5),5x)')
8064 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8065 cd            enddo
8066 cd          enddo
8067 cd        enddo
8068 cd        endif
8069         call transpose2(EUgder(1,1,k),auxmat(1,1))
8070         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8071         call transpose2(EUg(1,1,k),auxmat(1,1))
8072         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8073         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8074         do iii=1,2
8075           do kkk=1,5
8076             do lll=1,3
8077               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8078      &          EAEAderx(1,1,lll,kkk,iii,1))
8079             enddo
8080           enddo
8081         enddo
8082 C A1T kernel(i+1) A2
8083         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8084      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8085      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8086 C Following matrices are needed only for 6-th order cumulants
8087         IF (wcorr6.gt.0.0d0) THEN
8088         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8089      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8090      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8091         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8092      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8093      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8094      &   ADtEAderx(1,1,1,1,1,2))
8095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8096      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8097      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8098      &   ADtEA1derx(1,1,1,1,1,2))
8099         ENDIF
8100 C End 6-th order cumulants
8101         call transpose2(EUgder(1,1,l),auxmat(1,1))
8102         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8103         call transpose2(EUg(1,1,l),auxmat(1,1))
8104         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8105         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8106         do iii=1,2
8107           do kkk=1,5
8108             do lll=1,3
8109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8110      &          EAEAderx(1,1,lll,kkk,iii,2))
8111             enddo
8112           enddo
8113         enddo
8114 C AEAb1 and AEAb2
8115 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8116 C They are needed only when the fifth- or the sixth-order cumulants are
8117 C indluded.
8118         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8119         call transpose2(AEA(1,1,1),auxmat(1,1))
8120         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8121         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8122         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8123         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8124         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8125         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8126         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8127         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8128         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8129         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8130         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8131         call transpose2(AEA(1,1,2),auxmat(1,1))
8132         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8133         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8134         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8135         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8136         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8137         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8138         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8139         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8140         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8141         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8142         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8143 C Calculate the Cartesian derivatives of the vectors.
8144         do iii=1,2
8145           do kkk=1,5
8146             do lll=1,3
8147               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8148               call matvec2(auxmat(1,1),b1(1,i),
8149      &          AEAb1derx(1,lll,kkk,iii,1,1))
8150               call matvec2(auxmat(1,1),Ub2(1,i),
8151      &          AEAb2derx(1,lll,kkk,iii,1,1))
8152               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8153      &          AEAb1derx(1,lll,kkk,iii,2,1))
8154               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8155      &          AEAb2derx(1,lll,kkk,iii,2,1))
8156               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8157               call matvec2(auxmat(1,1),b1(1,j),
8158      &          AEAb1derx(1,lll,kkk,iii,1,2))
8159               call matvec2(auxmat(1,1),Ub2(1,j),
8160      &          AEAb2derx(1,lll,kkk,iii,1,2))
8161               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8162      &          AEAb1derx(1,lll,kkk,iii,2,2))
8163               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8164      &          AEAb2derx(1,lll,kkk,iii,2,2))
8165             enddo
8166           enddo
8167         enddo
8168         ENDIF
8169 C End vectors
8170       else
8171 C Antiparallel orientation of the two CA-CA-CA frames.
8172         if (i.gt.1) then
8173           iti=itortyp(itype(i))
8174         else
8175           iti=ntortyp
8176         endif
8177         itk1=itortyp(itype(k+1))
8178         itl=itortyp(itype(l))
8179         itj=itortyp(itype(j))
8180         if (j.lt.nres-1) then
8181           itj1=itortyp(itype(j+1))
8182         else
8183           itj1=ntortyp
8184         endif
8185 C A2 kernel(j-1)T A1T
8186         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8187      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8188      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8189 C Following matrices are needed only for 6-th order cumulants
8190         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8191      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8192         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8193      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8194      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8195         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8196      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8197      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8198      &   ADtEAderx(1,1,1,1,1,1))
8199         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8200      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8201      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8202      &   ADtEA1derx(1,1,1,1,1,1))
8203         ENDIF
8204 C End 6-th order cumulants
8205         call transpose2(EUgder(1,1,k),auxmat(1,1))
8206         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8207         call transpose2(EUg(1,1,k),auxmat(1,1))
8208         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8209         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8210         do iii=1,2
8211           do kkk=1,5
8212             do lll=1,3
8213               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8214      &          EAEAderx(1,1,lll,kkk,iii,1))
8215             enddo
8216           enddo
8217         enddo
8218 C A2T kernel(i+1)T A1
8219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8220      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8221      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8222 C Following matrices are needed only for 6-th order cumulants
8223         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8224      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8225         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8226      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8227      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8228         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8229      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8230      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8231      &   ADtEAderx(1,1,1,1,1,2))
8232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8233      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8234      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8235      &   ADtEA1derx(1,1,1,1,1,2))
8236         ENDIF
8237 C End 6-th order cumulants
8238         call transpose2(EUgder(1,1,j),auxmat(1,1))
8239         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8240         call transpose2(EUg(1,1,j),auxmat(1,1))
8241         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8242         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8243         do iii=1,2
8244           do kkk=1,5
8245             do lll=1,3
8246               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8247      &          EAEAderx(1,1,lll,kkk,iii,2))
8248             enddo
8249           enddo
8250         enddo
8251 C AEAb1 and AEAb2
8252 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8253 C They are needed only when the fifth- or the sixth-order cumulants are
8254 C indluded.
8255         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8256      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8257         call transpose2(AEA(1,1,1),auxmat(1,1))
8258         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8259         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8260         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8261         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8262         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8263         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8264         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8265         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8266         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8267         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8268         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8269         call transpose2(AEA(1,1,2),auxmat(1,1))
8270         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8271         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8272         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8273         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8274         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8275         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8276         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8277         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8278         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8279         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8280         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8281 C Calculate the Cartesian derivatives of the vectors.
8282         do iii=1,2
8283           do kkk=1,5
8284             do lll=1,3
8285               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8286               call matvec2(auxmat(1,1),b1(1,i),
8287      &          AEAb1derx(1,lll,kkk,iii,1,1))
8288               call matvec2(auxmat(1,1),Ub2(1,i),
8289      &          AEAb2derx(1,lll,kkk,iii,1,1))
8290               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8291      &          AEAb1derx(1,lll,kkk,iii,2,1))
8292               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8293      &          AEAb2derx(1,lll,kkk,iii,2,1))
8294               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8295               call matvec2(auxmat(1,1),b1(1,l),
8296      &          AEAb1derx(1,lll,kkk,iii,1,2))
8297               call matvec2(auxmat(1,1),Ub2(1,l),
8298      &          AEAb2derx(1,lll,kkk,iii,1,2))
8299               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8300      &          AEAb1derx(1,lll,kkk,iii,2,2))
8301               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8302      &          AEAb2derx(1,lll,kkk,iii,2,2))
8303             enddo
8304           enddo
8305         enddo
8306         ENDIF
8307 C End vectors
8308       endif
8309       return
8310       end
8311 C---------------------------------------------------------------------------
8312       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8313      &  KK,KKderg,AKA,AKAderg,AKAderx)
8314       implicit none
8315       integer nderg
8316       logical transp
8317       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8318      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8319      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8320       integer iii,kkk,lll
8321       integer jjj,mmm
8322       logical lprn
8323       common /kutas/ lprn
8324       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8325       do iii=1,nderg
8326         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8327      &    AKAderg(1,1,iii))
8328       enddo
8329 cd      if (lprn) write (2,*) 'In kernel'
8330       do kkk=1,5
8331 cd        if (lprn) write (2,*) 'kkk=',kkk
8332         do lll=1,3
8333           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8334      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8335 cd          if (lprn) then
8336 cd            write (2,*) 'lll=',lll
8337 cd            write (2,*) 'iii=1'
8338 cd            do jjj=1,2
8339 cd              write (2,'(3(2f10.5),5x)')
8340 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8341 cd            enddo
8342 cd          endif
8343           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8344      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8345 cd          if (lprn) then
8346 cd            write (2,*) 'lll=',lll
8347 cd            write (2,*) 'iii=2'
8348 cd            do jjj=1,2
8349 cd              write (2,'(3(2f10.5),5x)')
8350 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8351 cd            enddo
8352 cd          endif
8353         enddo
8354       enddo
8355       return
8356       end
8357 C---------------------------------------------------------------------------
8358       double precision function eello4(i,j,k,l,jj,kk)
8359       implicit real*8 (a-h,o-z)
8360       include 'DIMENSIONS'
8361       include 'COMMON.IOUNITS'
8362       include 'COMMON.CHAIN'
8363       include 'COMMON.DERIV'
8364       include 'COMMON.INTERACT'
8365       include 'COMMON.CONTACTS'
8366       include 'COMMON.TORSION'
8367       include 'COMMON.VAR'
8368       include 'COMMON.GEO'
8369       double precision pizda(2,2),ggg1(3),ggg2(3)
8370 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8371 cd        eello4=0.0d0
8372 cd        return
8373 cd      endif
8374 cd      print *,'eello4:',i,j,k,l,jj,kk
8375 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8376 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8377 cold      eij=facont_hb(jj,i)
8378 cold      ekl=facont_hb(kk,k)
8379 cold      ekont=eij*ekl
8380       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8381 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8382       gcorr_loc(k-1)=gcorr_loc(k-1)
8383      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8384       if (l.eq.j+1) then
8385         gcorr_loc(l-1)=gcorr_loc(l-1)
8386      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8387       else
8388         gcorr_loc(j-1)=gcorr_loc(j-1)
8389      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8390       endif
8391       do iii=1,2
8392         do kkk=1,5
8393           do lll=1,3
8394             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8395      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8396 cd            derx(lll,kkk,iii)=0.0d0
8397           enddo
8398         enddo
8399       enddo
8400 cd      gcorr_loc(l-1)=0.0d0
8401 cd      gcorr_loc(j-1)=0.0d0
8402 cd      gcorr_loc(k-1)=0.0d0
8403 cd      eel4=1.0d0
8404 cd      write (iout,*)'Contacts have occurred for peptide groups',
8405 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8406 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8407       if (j.lt.nres-1) then
8408         j1=j+1
8409         j2=j-1
8410       else
8411         j1=j-1
8412         j2=j-2
8413       endif
8414       if (l.lt.nres-1) then
8415         l1=l+1
8416         l2=l-1
8417       else
8418         l1=l-1
8419         l2=l-2
8420       endif
8421       do ll=1,3
8422 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8423 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8424         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8425         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8426 cgrad        ghalf=0.5d0*ggg1(ll)
8427         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8428         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8429         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8430         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8431         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8432         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8433 cgrad        ghalf=0.5d0*ggg2(ll)
8434         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8435         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8436         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8437         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8438         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8439         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8440       enddo
8441 cgrad      do m=i+1,j-1
8442 cgrad        do ll=1,3
8443 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8444 cgrad        enddo
8445 cgrad      enddo
8446 cgrad      do m=k+1,l-1
8447 cgrad        do ll=1,3
8448 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8449 cgrad        enddo
8450 cgrad      enddo
8451 cgrad      do m=i+2,j2
8452 cgrad        do ll=1,3
8453 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8454 cgrad        enddo
8455 cgrad      enddo
8456 cgrad      do m=k+2,l2
8457 cgrad        do ll=1,3
8458 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8459 cgrad        enddo
8460 cgrad      enddo
8461 cd      do iii=1,nres-3
8462 cd        write (2,*) iii,gcorr_loc(iii)
8463 cd      enddo
8464       eello4=ekont*eel4
8465 cd      write (2,*) 'ekont',ekont
8466 cd      write (iout,*) 'eello4',ekont*eel4
8467       return
8468       end
8469 C---------------------------------------------------------------------------
8470       double precision function eello5(i,j,k,l,jj,kk)
8471       implicit real*8 (a-h,o-z)
8472       include 'DIMENSIONS'
8473       include 'COMMON.IOUNITS'
8474       include 'COMMON.CHAIN'
8475       include 'COMMON.DERIV'
8476       include 'COMMON.INTERACT'
8477       include 'COMMON.CONTACTS'
8478       include 'COMMON.TORSION'
8479       include 'COMMON.VAR'
8480       include 'COMMON.GEO'
8481       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8482       double precision ggg1(3),ggg2(3)
8483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8484 C                                                                              C
8485 C                            Parallel chains                                   C
8486 C                                                                              C
8487 C          o             o                   o             o                   C
8488 C         /l\           / \             \   / \           / \   /              C
8489 C        /   \         /   \             \ /   \         /   \ /               C
8490 C       j| o |l1       | o |              o| o |         | o |o                C
8491 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8492 C      \i/   \         /   \ /             /   \         /   \                 C
8493 C       o    k1             o                                                  C
8494 C         (I)          (II)                (III)          (IV)                 C
8495 C                                                                              C
8496 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8497 C                                                                              C
8498 C                            Antiparallel chains                               C
8499 C                                                                              C
8500 C          o             o                   o             o                   C
8501 C         /j\           / \             \   / \           / \   /              C
8502 C        /   \         /   \             \ /   \         /   \ /               C
8503 C      j1| o |l        | o |              o| o |         | o |o                C
8504 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8505 C      \i/   \         /   \ /             /   \         /   \                 C
8506 C       o     k1            o                                                  C
8507 C         (I)          (II)                (III)          (IV)                 C
8508 C                                                                              C
8509 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8510 C                                                                              C
8511 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8512 C                                                                              C
8513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8514 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8515 cd        eello5=0.0d0
8516 cd        return
8517 cd      endif
8518 cd      write (iout,*)
8519 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8520 cd     &   ' and',k,l
8521       itk=itortyp(itype(k))
8522       itl=itortyp(itype(l))
8523       itj=itortyp(itype(j))
8524       eello5_1=0.0d0
8525       eello5_2=0.0d0
8526       eello5_3=0.0d0
8527       eello5_4=0.0d0
8528 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8529 cd     &   eel5_3_num,eel5_4_num)
8530       do iii=1,2
8531         do kkk=1,5
8532           do lll=1,3
8533             derx(lll,kkk,iii)=0.0d0
8534           enddo
8535         enddo
8536       enddo
8537 cd      eij=facont_hb(jj,i)
8538 cd      ekl=facont_hb(kk,k)
8539 cd      ekont=eij*ekl
8540 cd      write (iout,*)'Contacts have occurred for peptide groups',
8541 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8542 cd      goto 1111
8543 C Contribution from the graph I.
8544 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8545 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8546       call transpose2(EUg(1,1,k),auxmat(1,1))
8547       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8548       vv(1)=pizda(1,1)-pizda(2,2)
8549       vv(2)=pizda(1,2)+pizda(2,1)
8550       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8551      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8552 C Explicit gradient in virtual-dihedral angles.
8553       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8554      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8555      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8556       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8557       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8558       vv(1)=pizda(1,1)-pizda(2,2)
8559       vv(2)=pizda(1,2)+pizda(2,1)
8560       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8561      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8562      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8563       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8564       vv(1)=pizda(1,1)-pizda(2,2)
8565       vv(2)=pizda(1,2)+pizda(2,1)
8566       if (l.eq.j+1) then
8567         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8568      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8569      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8570       else
8571         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8572      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8573      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8574       endif
8575 C Cartesian gradient
8576       do iii=1,2
8577         do kkk=1,5
8578           do lll=1,3
8579             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8580      &        pizda(1,1))
8581             vv(1)=pizda(1,1)-pizda(2,2)
8582             vv(2)=pizda(1,2)+pizda(2,1)
8583             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8584      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8585      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8586           enddo
8587         enddo
8588       enddo
8589 c      goto 1112
8590 c1111  continue
8591 C Contribution from graph II
8592       call transpose2(EE(1,1,itk),auxmat(1,1))
8593       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8594       vv(1)=pizda(1,1)+pizda(2,2)
8595       vv(2)=pizda(2,1)-pizda(1,2)
8596       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8597      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8598 C Explicit gradient in virtual-dihedral angles.
8599       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8600      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8601       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8602       vv(1)=pizda(1,1)+pizda(2,2)
8603       vv(2)=pizda(2,1)-pizda(1,2)
8604       if (l.eq.j+1) then
8605         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8606      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8607      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8608       else
8609         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8610      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8611      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8612       endif
8613 C Cartesian gradient
8614       do iii=1,2
8615         do kkk=1,5
8616           do lll=1,3
8617             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8618      &        pizda(1,1))
8619             vv(1)=pizda(1,1)+pizda(2,2)
8620             vv(2)=pizda(2,1)-pizda(1,2)
8621             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8622      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8623      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8624           enddo
8625         enddo
8626       enddo
8627 cd      goto 1112
8628 cd1111  continue
8629       if (l.eq.j+1) then
8630 cd        goto 1110
8631 C Parallel orientation
8632 C Contribution from graph III
8633         call transpose2(EUg(1,1,l),auxmat(1,1))
8634         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8635         vv(1)=pizda(1,1)-pizda(2,2)
8636         vv(2)=pizda(1,2)+pizda(2,1)
8637         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8638      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8639 C Explicit gradient in virtual-dihedral angles.
8640         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8641      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8642      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8643         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8644         vv(1)=pizda(1,1)-pizda(2,2)
8645         vv(2)=pizda(1,2)+pizda(2,1)
8646         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8647      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8648      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8649         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8650         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(1,2)+pizda(2,1)
8653         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8654      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8655      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8656 C Cartesian gradient
8657         do iii=1,2
8658           do kkk=1,5
8659             do lll=1,3
8660               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8661      &          pizda(1,1))
8662               vv(1)=pizda(1,1)-pizda(2,2)
8663               vv(2)=pizda(1,2)+pizda(2,1)
8664               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8665      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8666      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8667             enddo
8668           enddo
8669         enddo
8670 cd        goto 1112
8671 C Contribution from graph IV
8672 cd1110    continue
8673         call transpose2(EE(1,1,itl),auxmat(1,1))
8674         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8675         vv(1)=pizda(1,1)+pizda(2,2)
8676         vv(2)=pizda(2,1)-pizda(1,2)
8677         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8678      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8679 C Explicit gradient in virtual-dihedral angles.
8680         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8681      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8682         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8683         vv(1)=pizda(1,1)+pizda(2,2)
8684         vv(2)=pizda(2,1)-pizda(1,2)
8685         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8686      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8687      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8688 C Cartesian gradient
8689         do iii=1,2
8690           do kkk=1,5
8691             do lll=1,3
8692               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8693      &          pizda(1,1))
8694               vv(1)=pizda(1,1)+pizda(2,2)
8695               vv(2)=pizda(2,1)-pizda(1,2)
8696               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8697      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8698      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8699             enddo
8700           enddo
8701         enddo
8702       else
8703 C Antiparallel orientation
8704 C Contribution from graph III
8705 c        goto 1110
8706         call transpose2(EUg(1,1,j),auxmat(1,1))
8707         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8708         vv(1)=pizda(1,1)-pizda(2,2)
8709         vv(2)=pizda(1,2)+pizda(2,1)
8710         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8711      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8712 C Explicit gradient in virtual-dihedral angles.
8713         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8714      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8715      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8716         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8717         vv(1)=pizda(1,1)-pizda(2,2)
8718         vv(2)=pizda(1,2)+pizda(2,1)
8719         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8720      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8721      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8722         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8723         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8724         vv(1)=pizda(1,1)-pizda(2,2)
8725         vv(2)=pizda(1,2)+pizda(2,1)
8726         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8727      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8728      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8729 C Cartesian gradient
8730         do iii=1,2
8731           do kkk=1,5
8732             do lll=1,3
8733               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8734      &          pizda(1,1))
8735               vv(1)=pizda(1,1)-pizda(2,2)
8736               vv(2)=pizda(1,2)+pizda(2,1)
8737               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8738      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8739      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8740             enddo
8741           enddo
8742         enddo
8743 cd        goto 1112
8744 C Contribution from graph IV
8745 1110    continue
8746         call transpose2(EE(1,1,itj),auxmat(1,1))
8747         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8748         vv(1)=pizda(1,1)+pizda(2,2)
8749         vv(2)=pizda(2,1)-pizda(1,2)
8750         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8751      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8752 C Explicit gradient in virtual-dihedral angles.
8753         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8754      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8755         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8756         vv(1)=pizda(1,1)+pizda(2,2)
8757         vv(2)=pizda(2,1)-pizda(1,2)
8758         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8759      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8760      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8761 C Cartesian gradient
8762         do iii=1,2
8763           do kkk=1,5
8764             do lll=1,3
8765               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8766      &          pizda(1,1))
8767               vv(1)=pizda(1,1)+pizda(2,2)
8768               vv(2)=pizda(2,1)-pizda(1,2)
8769               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8770      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8771      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8772             enddo
8773           enddo
8774         enddo
8775       endif
8776 1112  continue
8777       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8778 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8779 cd        write (2,*) 'ijkl',i,j,k,l
8780 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8781 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8782 cd      endif
8783 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8784 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8785 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8786 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8787       if (j.lt.nres-1) then
8788         j1=j+1
8789         j2=j-1
8790       else
8791         j1=j-1
8792         j2=j-2
8793       endif
8794       if (l.lt.nres-1) then
8795         l1=l+1
8796         l2=l-1
8797       else
8798         l1=l-1
8799         l2=l-2
8800       endif
8801 cd      eij=1.0d0
8802 cd      ekl=1.0d0
8803 cd      ekont=1.0d0
8804 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8805 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8806 C        summed up outside the subrouine as for the other subroutines
8807 C        handling long-range interactions. The old code is commented out
8808 C        with "cgrad" to keep track of changes.
8809       do ll=1,3
8810 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8811 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8812         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8813         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8814 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8815 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8816 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8817 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8818 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8819 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8820 c     &   gradcorr5ij,
8821 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8822 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8823 cgrad        ghalf=0.5d0*ggg1(ll)
8824 cd        ghalf=0.0d0
8825         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8826         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8827         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8828         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8829         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8830         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8831 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8832 cgrad        ghalf=0.5d0*ggg2(ll)
8833 cd        ghalf=0.0d0
8834         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8835         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8836         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8837         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8838         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8839         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8840       enddo
8841 cd      goto 1112
8842 cgrad      do m=i+1,j-1
8843 cgrad        do ll=1,3
8844 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8845 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8846 cgrad        enddo
8847 cgrad      enddo
8848 cgrad      do m=k+1,l-1
8849 cgrad        do ll=1,3
8850 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8851 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8852 cgrad        enddo
8853 cgrad      enddo
8854 c1112  continue
8855 cgrad      do m=i+2,j2
8856 cgrad        do ll=1,3
8857 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8858 cgrad        enddo
8859 cgrad      enddo
8860 cgrad      do m=k+2,l2
8861 cgrad        do ll=1,3
8862 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8863 cgrad        enddo
8864 cgrad      enddo
8865 cd      do iii=1,nres-3
8866 cd        write (2,*) iii,g_corr5_loc(iii)
8867 cd      enddo
8868       eello5=ekont*eel5
8869 cd      write (2,*) 'ekont',ekont
8870 cd      write (iout,*) 'eello5',ekont*eel5
8871       return
8872       end
8873 c--------------------------------------------------------------------------
8874       double precision function eello6(i,j,k,l,jj,kk)
8875       implicit real*8 (a-h,o-z)
8876       include 'DIMENSIONS'
8877       include 'COMMON.IOUNITS'
8878       include 'COMMON.CHAIN'
8879       include 'COMMON.DERIV'
8880       include 'COMMON.INTERACT'
8881       include 'COMMON.CONTACTS'
8882       include 'COMMON.TORSION'
8883       include 'COMMON.VAR'
8884       include 'COMMON.GEO'
8885       include 'COMMON.FFIELD'
8886       double precision ggg1(3),ggg2(3)
8887 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8888 cd        eello6=0.0d0
8889 cd        return
8890 cd      endif
8891 cd      write (iout,*)
8892 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8893 cd     &   ' and',k,l
8894       eello6_1=0.0d0
8895       eello6_2=0.0d0
8896       eello6_3=0.0d0
8897       eello6_4=0.0d0
8898       eello6_5=0.0d0
8899       eello6_6=0.0d0
8900 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8901 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8902       do iii=1,2
8903         do kkk=1,5
8904           do lll=1,3
8905             derx(lll,kkk,iii)=0.0d0
8906           enddo
8907         enddo
8908       enddo
8909 cd      eij=facont_hb(jj,i)
8910 cd      ekl=facont_hb(kk,k)
8911 cd      ekont=eij*ekl
8912 cd      eij=1.0d0
8913 cd      ekl=1.0d0
8914 cd      ekont=1.0d0
8915       if (l.eq.j+1) then
8916         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8917         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8918         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8919         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8920         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8921         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8922       else
8923         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8924         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8925         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8926         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8927         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8928           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8929         else
8930           eello6_5=0.0d0
8931         endif
8932         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8933       endif
8934 C If turn contributions are considered, they will be handled separately.
8935       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8936 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8937 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8938 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8939 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8940 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8941 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8942 cd      goto 1112
8943       if (j.lt.nres-1) then
8944         j1=j+1
8945         j2=j-1
8946       else
8947         j1=j-1
8948         j2=j-2
8949       endif
8950       if (l.lt.nres-1) then
8951         l1=l+1
8952         l2=l-1
8953       else
8954         l1=l-1
8955         l2=l-2
8956       endif
8957       do ll=1,3
8958 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8959 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8960 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8961 cgrad        ghalf=0.5d0*ggg1(ll)
8962 cd        ghalf=0.0d0
8963         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8964         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8965         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8966         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8967         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8968         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8969         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8970         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8971 cgrad        ghalf=0.5d0*ggg2(ll)
8972 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8973 cd        ghalf=0.0d0
8974         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8975         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8976         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8977         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8978         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8979         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8980       enddo
8981 cd      goto 1112
8982 cgrad      do m=i+1,j-1
8983 cgrad        do ll=1,3
8984 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8985 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8986 cgrad        enddo
8987 cgrad      enddo
8988 cgrad      do m=k+1,l-1
8989 cgrad        do ll=1,3
8990 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8991 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8992 cgrad        enddo
8993 cgrad      enddo
8994 cgrad1112  continue
8995 cgrad      do m=i+2,j2
8996 cgrad        do ll=1,3
8997 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8998 cgrad        enddo
8999 cgrad      enddo
9000 cgrad      do m=k+2,l2
9001 cgrad        do ll=1,3
9002 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9003 cgrad        enddo
9004 cgrad      enddo
9005 cd      do iii=1,nres-3
9006 cd        write (2,*) iii,g_corr6_loc(iii)
9007 cd      enddo
9008       eello6=ekont*eel6
9009 cd      write (2,*) 'ekont',ekont
9010 cd      write (iout,*) 'eello6',ekont*eel6
9011       return
9012       end
9013 c--------------------------------------------------------------------------
9014       double precision function eello6_graph1(i,j,k,l,imat,swap)
9015       implicit real*8 (a-h,o-z)
9016       include 'DIMENSIONS'
9017       include 'COMMON.IOUNITS'
9018       include 'COMMON.CHAIN'
9019       include 'COMMON.DERIV'
9020       include 'COMMON.INTERACT'
9021       include 'COMMON.CONTACTS'
9022       include 'COMMON.TORSION'
9023       include 'COMMON.VAR'
9024       include 'COMMON.GEO'
9025       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9026       logical swap
9027       logical lprn
9028       common /kutas/ lprn
9029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9030 C                                                                              C
9031 C      Parallel       Antiparallel                                             C
9032 C                                                                              C
9033 C          o             o                                                     C
9034 C         /l\           /j\                                                    C
9035 C        /   \         /   \                                                   C
9036 C       /| o |         | o |\                                                  C
9037 C     \ j|/k\|  /   \  |/k\|l /                                                C
9038 C      \ /   \ /     \ /   \ /                                                 C
9039 C       o     o       o     o                                                  C
9040 C       i             i                                                        C
9041 C                                                                              C
9042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9043       itk=itortyp(itype(k))
9044       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9045       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9046       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9047       call transpose2(EUgC(1,1,k),auxmat(1,1))
9048       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9049       vv1(1)=pizda1(1,1)-pizda1(2,2)
9050       vv1(2)=pizda1(1,2)+pizda1(2,1)
9051       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9052       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9053       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9054       s5=scalar2(vv(1),Dtobr2(1,i))
9055 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9056       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9057       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9058      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9059      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9060      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9061      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9062      & +scalar2(vv(1),Dtobr2der(1,i)))
9063       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9064       vv1(1)=pizda1(1,1)-pizda1(2,2)
9065       vv1(2)=pizda1(1,2)+pizda1(2,1)
9066       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9067       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9068       if (l.eq.j+1) then
9069         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9070      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9071      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9072      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9073      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9074       else
9075         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9076      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9077      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9078      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9079      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9080       endif
9081       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9082       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9083       vv1(1)=pizda1(1,1)-pizda1(2,2)
9084       vv1(2)=pizda1(1,2)+pizda1(2,1)
9085       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9086      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9087      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9088      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9089       do iii=1,2
9090         if (swap) then
9091           ind=3-iii
9092         else
9093           ind=iii
9094         endif
9095         do kkk=1,5
9096           do lll=1,3
9097             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9098             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9099             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9100             call transpose2(EUgC(1,1,k),auxmat(1,1))
9101             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9102      &        pizda1(1,1))
9103             vv1(1)=pizda1(1,1)-pizda1(2,2)
9104             vv1(2)=pizda1(1,2)+pizda1(2,1)
9105             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9106             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9107      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9108             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9109      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9110             s5=scalar2(vv(1),Dtobr2(1,i))
9111             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9112           enddo
9113         enddo
9114       enddo
9115       return
9116       end
9117 c----------------------------------------------------------------------------
9118       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9119       implicit real*8 (a-h,o-z)
9120       include 'DIMENSIONS'
9121       include 'COMMON.IOUNITS'
9122       include 'COMMON.CHAIN'
9123       include 'COMMON.DERIV'
9124       include 'COMMON.INTERACT'
9125       include 'COMMON.CONTACTS'
9126       include 'COMMON.TORSION'
9127       include 'COMMON.VAR'
9128       include 'COMMON.GEO'
9129       logical swap
9130       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9131      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9132       logical lprn
9133       common /kutas/ lprn
9134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9135 C                                                                              C
9136 C      Parallel       Antiparallel                                             C
9137 C                                                                              C
9138 C          o             o                                                     C
9139 C     \   /l\           /j\   /                                                C
9140 C      \ /   \         /   \ /                                                 C
9141 C       o| o |         | o |o                                                  C
9142 C     \ j|/k\|      \  |/k\|l                                                  C
9143 C      \ /   \       \ /   \                                                   C
9144 C       o             o                                                        C
9145 C       i             i                                                        C
9146 C                                                                              C
9147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9148 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9149 C AL 7/4/01 s1 would occur in the sixth-order moment,
9150 C           but not in a cluster cumulant
9151 #ifdef MOMENT
9152       s1=dip(1,jj,i)*dip(1,kk,k)
9153 #endif
9154       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9155       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9156       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9157       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9158       call transpose2(EUg(1,1,k),auxmat(1,1))
9159       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9160       vv(1)=pizda(1,1)-pizda(2,2)
9161       vv(2)=pizda(1,2)+pizda(2,1)
9162       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9163 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9164 #ifdef MOMENT
9165       eello6_graph2=-(s1+s2+s3+s4)
9166 #else
9167       eello6_graph2=-(s2+s3+s4)
9168 #endif
9169 c      eello6_graph2=-s3
9170 C Derivatives in gamma(i-1)
9171       if (i.gt.1) then
9172 #ifdef MOMENT
9173         s1=dipderg(1,jj,i)*dip(1,kk,k)
9174 #endif
9175         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9176         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9177         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9178         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9179 #ifdef MOMENT
9180         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9181 #else
9182         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9183 #endif
9184 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9185       endif
9186 C Derivatives in gamma(k-1)
9187 #ifdef MOMENT
9188       s1=dip(1,jj,i)*dipderg(1,kk,k)
9189 #endif
9190       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9191       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9192       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9193       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9194       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9195       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9196       vv(1)=pizda(1,1)-pizda(2,2)
9197       vv(2)=pizda(1,2)+pizda(2,1)
9198       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9199 #ifdef MOMENT
9200       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9201 #else
9202       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9203 #endif
9204 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9205 C Derivatives in gamma(j-1) or gamma(l-1)
9206       if (j.gt.1) then
9207 #ifdef MOMENT
9208         s1=dipderg(3,jj,i)*dip(1,kk,k)
9209 #endif
9210         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9211         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9212         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9213         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9214         vv(1)=pizda(1,1)-pizda(2,2)
9215         vv(2)=pizda(1,2)+pizda(2,1)
9216         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9217 #ifdef MOMENT
9218         if (swap) then
9219           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9220         else
9221           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9222         endif
9223 #endif
9224         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9225 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9226       endif
9227 C Derivatives in gamma(l-1) or gamma(j-1)
9228       if (l.gt.1) then
9229 #ifdef MOMENT
9230         s1=dip(1,jj,i)*dipderg(3,kk,k)
9231 #endif
9232         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9233         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9234         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9235         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9236         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9237         vv(1)=pizda(1,1)-pizda(2,2)
9238         vv(2)=pizda(1,2)+pizda(2,1)
9239         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9240 #ifdef MOMENT
9241         if (swap) then
9242           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9243         else
9244           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9245         endif
9246 #endif
9247         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9248 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9249       endif
9250 C Cartesian derivatives.
9251       if (lprn) then
9252         write (2,*) 'In eello6_graph2'
9253         do iii=1,2
9254           write (2,*) 'iii=',iii
9255           do kkk=1,5
9256             write (2,*) 'kkk=',kkk
9257             do jjj=1,2
9258               write (2,'(3(2f10.5),5x)')
9259      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9260             enddo
9261           enddo
9262         enddo
9263       endif
9264       do iii=1,2
9265         do kkk=1,5
9266           do lll=1,3
9267 #ifdef MOMENT
9268             if (iii.eq.1) then
9269               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9270             else
9271               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9272             endif
9273 #endif
9274             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9275      &        auxvec(1))
9276             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9277             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9278      &        auxvec(1))
9279             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9280             call transpose2(EUg(1,1,k),auxmat(1,1))
9281             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9282      &        pizda(1,1))
9283             vv(1)=pizda(1,1)-pizda(2,2)
9284             vv(2)=pizda(1,2)+pizda(2,1)
9285             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9286 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9287 #ifdef MOMENT
9288             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9289 #else
9290             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9291 #endif
9292             if (swap) then
9293               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9294             else
9295               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9296             endif
9297           enddo
9298         enddo
9299       enddo
9300       return
9301       end
9302 c----------------------------------------------------------------------------
9303       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9304       implicit real*8 (a-h,o-z)
9305       include 'DIMENSIONS'
9306       include 'COMMON.IOUNITS'
9307       include 'COMMON.CHAIN'
9308       include 'COMMON.DERIV'
9309       include 'COMMON.INTERACT'
9310       include 'COMMON.CONTACTS'
9311       include 'COMMON.TORSION'
9312       include 'COMMON.VAR'
9313       include 'COMMON.GEO'
9314       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9315       logical swap
9316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9317 C                                                                              C
9318 C      Parallel       Antiparallel                                             C
9319 C                                                                              C
9320 C          o             o                                                     C
9321 C         /l\   /   \   /j\                                                    C
9322 C        /   \ /     \ /   \                                                   C
9323 C       /| o |o       o| o |\                                                  C
9324 C       j|/k\|  /      |/k\|l /                                                C
9325 C        /   \ /       /   \ /                                                 C
9326 C       /     o       /     o                                                  C
9327 C       i             i                                                        C
9328 C                                                                              C
9329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9330 C
9331 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9332 C           energy moment and not to the cluster cumulant.
9333       iti=itortyp(itype(i))
9334       if (j.lt.nres-1) then
9335         itj1=itortyp(itype(j+1))
9336       else
9337         itj1=ntortyp
9338       endif
9339       itk=itortyp(itype(k))
9340       itk1=itortyp(itype(k+1))
9341       if (l.lt.nres-1) then
9342         itl1=itortyp(itype(l+1))
9343       else
9344         itl1=ntortyp
9345       endif
9346 #ifdef MOMENT
9347       s1=dip(4,jj,i)*dip(4,kk,k)
9348 #endif
9349       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9350       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9351       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9352       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9353       call transpose2(EE(1,1,itk),auxmat(1,1))
9354       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9355       vv(1)=pizda(1,1)+pizda(2,2)
9356       vv(2)=pizda(2,1)-pizda(1,2)
9357       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9358 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9359 cd     & "sum",-(s2+s3+s4)
9360 #ifdef MOMENT
9361       eello6_graph3=-(s1+s2+s3+s4)
9362 #else
9363       eello6_graph3=-(s2+s3+s4)
9364 #endif
9365 c      eello6_graph3=-s4
9366 C Derivatives in gamma(k-1)
9367       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9368       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9369       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9370       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9371 C Derivatives in gamma(l-1)
9372       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9373       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9374       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9375       vv(1)=pizda(1,1)+pizda(2,2)
9376       vv(2)=pizda(2,1)-pizda(1,2)
9377       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9378       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9379 C Cartesian derivatives.
9380       do iii=1,2
9381         do kkk=1,5
9382           do lll=1,3
9383 #ifdef MOMENT
9384             if (iii.eq.1) then
9385               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9386             else
9387               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9388             endif
9389 #endif
9390             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9391      &        auxvec(1))
9392             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9393             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9394      &        auxvec(1))
9395             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9396             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9397      &        pizda(1,1))
9398             vv(1)=pizda(1,1)+pizda(2,2)
9399             vv(2)=pizda(2,1)-pizda(1,2)
9400             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9401 #ifdef MOMENT
9402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9403 #else
9404             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9405 #endif
9406             if (swap) then
9407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9408             else
9409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9410             endif
9411 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9412           enddo
9413         enddo
9414       enddo
9415       return
9416       end
9417 c----------------------------------------------------------------------------
9418       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9419       implicit real*8 (a-h,o-z)
9420       include 'DIMENSIONS'
9421       include 'COMMON.IOUNITS'
9422       include 'COMMON.CHAIN'
9423       include 'COMMON.DERIV'
9424       include 'COMMON.INTERACT'
9425       include 'COMMON.CONTACTS'
9426       include 'COMMON.TORSION'
9427       include 'COMMON.VAR'
9428       include 'COMMON.GEO'
9429       include 'COMMON.FFIELD'
9430       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9431      & auxvec1(2),auxmat1(2,2)
9432       logical swap
9433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9434 C                                                                              C
9435 C      Parallel       Antiparallel                                             C
9436 C                                                                              C
9437 C          o             o                                                     C
9438 C         /l\   /   \   /j\                                                    C
9439 C        /   \ /     \ /   \                                                   C
9440 C       /| o |o       o| o |\                                                  C
9441 C     \ j|/k\|      \  |/k\|l                                                  C
9442 C      \ /   \       \ /   \                                                   C
9443 C       o     \       o     \                                                  C
9444 C       i             i                                                        C
9445 C                                                                              C
9446 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9447 C
9448 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9449 C           energy moment and not to the cluster cumulant.
9450 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9451       iti=itortyp(itype(i))
9452       itj=itortyp(itype(j))
9453       if (j.lt.nres-1) then
9454         itj1=itortyp(itype(j+1))
9455       else
9456         itj1=ntortyp
9457       endif
9458       itk=itortyp(itype(k))
9459       if (k.lt.nres-1) then
9460         itk1=itortyp(itype(k+1))
9461       else
9462         itk1=ntortyp
9463       endif
9464       itl=itortyp(itype(l))
9465       if (l.lt.nres-1) then
9466         itl1=itortyp(itype(l+1))
9467       else
9468         itl1=ntortyp
9469       endif
9470 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9471 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9472 cd     & ' itl',itl,' itl1',itl1
9473 #ifdef MOMENT
9474       if (imat.eq.1) then
9475         s1=dip(3,jj,i)*dip(3,kk,k)
9476       else
9477         s1=dip(2,jj,j)*dip(2,kk,l)
9478       endif
9479 #endif
9480       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9481       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9482       if (j.eq.l+1) then
9483         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9484         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9485       else
9486         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9487         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9488       endif
9489       call transpose2(EUg(1,1,k),auxmat(1,1))
9490       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9491       vv(1)=pizda(1,1)-pizda(2,2)
9492       vv(2)=pizda(2,1)+pizda(1,2)
9493       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9494 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9495 #ifdef MOMENT
9496       eello6_graph4=-(s1+s2+s3+s4)
9497 #else
9498       eello6_graph4=-(s2+s3+s4)
9499 #endif
9500 C Derivatives in gamma(i-1)
9501       if (i.gt.1) then
9502 #ifdef MOMENT
9503         if (imat.eq.1) then
9504           s1=dipderg(2,jj,i)*dip(3,kk,k)
9505         else
9506           s1=dipderg(4,jj,j)*dip(2,kk,l)
9507         endif
9508 #endif
9509         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9510         if (j.eq.l+1) then
9511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9512           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9513         else
9514           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9515           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9516         endif
9517         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9518         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9519 cd          write (2,*) 'turn6 derivatives'
9520 #ifdef MOMENT
9521           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9522 #else
9523           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9524 #endif
9525         else
9526 #ifdef MOMENT
9527           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9528 #else
9529           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9530 #endif
9531         endif
9532       endif
9533 C Derivatives in gamma(k-1)
9534 #ifdef MOMENT
9535       if (imat.eq.1) then
9536         s1=dip(3,jj,i)*dipderg(2,kk,k)
9537       else
9538         s1=dip(2,jj,j)*dipderg(4,kk,l)
9539       endif
9540 #endif
9541       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9542       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9543       if (j.eq.l+1) then
9544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9545         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9546       else
9547         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9548         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9549       endif
9550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9551       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9552       vv(1)=pizda(1,1)-pizda(2,2)
9553       vv(2)=pizda(2,1)+pizda(1,2)
9554       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9555       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9556 #ifdef MOMENT
9557         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9558 #else
9559         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9560 #endif
9561       else
9562 #ifdef MOMENT
9563         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9564 #else
9565         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9566 #endif
9567       endif
9568 C Derivatives in gamma(j-1) or gamma(l-1)
9569       if (l.eq.j+1 .and. l.gt.1) then
9570         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9571         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9572         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9573         vv(1)=pizda(1,1)-pizda(2,2)
9574         vv(2)=pizda(2,1)+pizda(1,2)
9575         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9576         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9577       else if (j.gt.1) then
9578         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9579         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9580         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9581         vv(1)=pizda(1,1)-pizda(2,2)
9582         vv(2)=pizda(2,1)+pizda(1,2)
9583         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9584         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9585           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9586         else
9587           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9588         endif
9589       endif
9590 C Cartesian derivatives.
9591       do iii=1,2
9592         do kkk=1,5
9593           do lll=1,3
9594 #ifdef MOMENT
9595             if (iii.eq.1) then
9596               if (imat.eq.1) then
9597                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9598               else
9599                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9600               endif
9601             else
9602               if (imat.eq.1) then
9603                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9604               else
9605                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9606               endif
9607             endif
9608 #endif
9609             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9610      &        auxvec(1))
9611             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9612             if (j.eq.l+1) then
9613               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9614      &          b1(1,j+1),auxvec(1))
9615               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9616             else
9617               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9618      &          b1(1,l+1),auxvec(1))
9619               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9620             endif
9621             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9622      &        pizda(1,1))
9623             vv(1)=pizda(1,1)-pizda(2,2)
9624             vv(2)=pizda(2,1)+pizda(1,2)
9625             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9626             if (swap) then
9627               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9628 #ifdef MOMENT
9629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9630      &             -(s1+s2+s4)
9631 #else
9632                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9633      &             -(s2+s4)
9634 #endif
9635                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9636               else
9637 #ifdef MOMENT
9638                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9639 #else
9640                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9641 #endif
9642                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9643               endif
9644             else
9645 #ifdef MOMENT
9646               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9647 #else
9648               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9649 #endif
9650               if (l.eq.j+1) then
9651                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9652               else
9653                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9654               endif
9655             endif
9656           enddo
9657         enddo
9658       enddo
9659       return
9660       end
9661 c----------------------------------------------------------------------------
9662       double precision function eello_turn6(i,jj,kk)
9663       implicit real*8 (a-h,o-z)
9664       include 'DIMENSIONS'
9665       include 'COMMON.IOUNITS'
9666       include 'COMMON.CHAIN'
9667       include 'COMMON.DERIV'
9668       include 'COMMON.INTERACT'
9669       include 'COMMON.CONTACTS'
9670       include 'COMMON.TORSION'
9671       include 'COMMON.VAR'
9672       include 'COMMON.GEO'
9673       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9674      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9675      &  ggg1(3),ggg2(3)
9676       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9677      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9678 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9679 C           the respective energy moment and not to the cluster cumulant.
9680       s1=0.0d0
9681       s8=0.0d0
9682       s13=0.0d0
9683 c
9684       eello_turn6=0.0d0
9685       j=i+4
9686       k=i+1
9687       l=i+3
9688       iti=itortyp(itype(i))
9689       itk=itortyp(itype(k))
9690       itk1=itortyp(itype(k+1))
9691       itl=itortyp(itype(l))
9692       itj=itortyp(itype(j))
9693 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9694 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9695 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9696 cd        eello6=0.0d0
9697 cd        return
9698 cd      endif
9699 cd      write (iout,*)
9700 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9701 cd     &   ' and',k,l
9702 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9703       do iii=1,2
9704         do kkk=1,5
9705           do lll=1,3
9706             derx_turn(lll,kkk,iii)=0.0d0
9707           enddo
9708         enddo
9709       enddo
9710 cd      eij=1.0d0
9711 cd      ekl=1.0d0
9712 cd      ekont=1.0d0
9713       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9714 cd      eello6_5=0.0d0
9715 cd      write (2,*) 'eello6_5',eello6_5
9716 #ifdef MOMENT
9717       call transpose2(AEA(1,1,1),auxmat(1,1))
9718       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9719       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9720       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9721 #endif
9722       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9723       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9724       s2 = scalar2(b1(1,k),vtemp1(1))
9725 #ifdef MOMENT
9726       call transpose2(AEA(1,1,2),atemp(1,1))
9727       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9728       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9729       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9730 #endif
9731       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9732       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9733       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9734 #ifdef MOMENT
9735       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9736       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9737       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9738       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9739       ss13 = scalar2(b1(1,k),vtemp4(1))
9740       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9741 #endif
9742 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9743 c      s1=0.0d0
9744 c      s2=0.0d0
9745 c      s8=0.0d0
9746 c      s12=0.0d0
9747 c      s13=0.0d0
9748       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9749 C Derivatives in gamma(i+2)
9750       s1d =0.0d0
9751       s8d =0.0d0
9752 #ifdef MOMENT
9753       call transpose2(AEA(1,1,1),auxmatd(1,1))
9754       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9755       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9756       call transpose2(AEAderg(1,1,2),atempd(1,1))
9757       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9758       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9759 #endif
9760       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9761       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9762       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9763 c      s1d=0.0d0
9764 c      s2d=0.0d0
9765 c      s8d=0.0d0
9766 c      s12d=0.0d0
9767 c      s13d=0.0d0
9768       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9769 C Derivatives in gamma(i+3)
9770 #ifdef MOMENT
9771       call transpose2(AEA(1,1,1),auxmatd(1,1))
9772       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9773       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9774       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9775 #endif
9776       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9777       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9778       s2d = scalar2(b1(1,k),vtemp1d(1))
9779 #ifdef MOMENT
9780       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9781       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9782 #endif
9783       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9784 #ifdef MOMENT
9785       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9786       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9787       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9788 #endif
9789 c      s1d=0.0d0
9790 c      s2d=0.0d0
9791 c      s8d=0.0d0
9792 c      s12d=0.0d0
9793 c      s13d=0.0d0
9794 #ifdef MOMENT
9795       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9796      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9797 #else
9798       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9799      &               -0.5d0*ekont*(s2d+s12d)
9800 #endif
9801 C Derivatives in gamma(i+4)
9802       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9803       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9804       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9805 #ifdef MOMENT
9806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9807       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9808       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9809 #endif
9810 c      s1d=0.0d0
9811 c      s2d=0.0d0
9812 c      s8d=0.0d0
9813 C      s12d=0.0d0
9814 c      s13d=0.0d0
9815 #ifdef MOMENT
9816       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9817 #else
9818       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9819 #endif
9820 C Derivatives in gamma(i+5)
9821 #ifdef MOMENT
9822       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9823       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9824       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9825 #endif
9826       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9827       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9828       s2d = scalar2(b1(1,k),vtemp1d(1))
9829 #ifdef MOMENT
9830       call transpose2(AEA(1,1,2),atempd(1,1))
9831       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9832       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9833 #endif
9834       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9835       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9836 #ifdef MOMENT
9837       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9838       ss13d = scalar2(b1(1,k),vtemp4d(1))
9839       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9840 #endif
9841 c      s1d=0.0d0
9842 c      s2d=0.0d0
9843 c      s8d=0.0d0
9844 c      s12d=0.0d0
9845 c      s13d=0.0d0
9846 #ifdef MOMENT
9847       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9848      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9849 #else
9850       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9851      &               -0.5d0*ekont*(s2d+s12d)
9852 #endif
9853 C Cartesian derivatives
9854       do iii=1,2
9855         do kkk=1,5
9856           do lll=1,3
9857 #ifdef MOMENT
9858             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9859             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9860             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9861 #endif
9862             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9863             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9864      &          vtemp1d(1))
9865             s2d = scalar2(b1(1,k),vtemp1d(1))
9866 #ifdef MOMENT
9867             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9868             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9869             s8d = -(atempd(1,1)+atempd(2,2))*
9870      &           scalar2(cc(1,1,itl),vtemp2(1))
9871 #endif
9872             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9873      &           auxmatd(1,1))
9874             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9875             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9876 c      s1d=0.0d0
9877 c      s2d=0.0d0
9878 c      s8d=0.0d0
9879 c      s12d=0.0d0
9880 c      s13d=0.0d0
9881 #ifdef MOMENT
9882             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9883      &        - 0.5d0*(s1d+s2d)
9884 #else
9885             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9886      &        - 0.5d0*s2d
9887 #endif
9888 #ifdef MOMENT
9889             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9890      &        - 0.5d0*(s8d+s12d)
9891 #else
9892             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9893      &        - 0.5d0*s12d
9894 #endif
9895           enddo
9896         enddo
9897       enddo
9898 #ifdef MOMENT
9899       do kkk=1,5
9900         do lll=1,3
9901           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9902      &      achuj_tempd(1,1))
9903           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9904           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9905           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9906           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9907           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9908      &      vtemp4d(1))
9909           ss13d = scalar2(b1(1,k),vtemp4d(1))
9910           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9911           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9912         enddo
9913       enddo
9914 #endif
9915 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9916 cd     &  16*eel_turn6_num
9917 cd      goto 1112
9918       if (j.lt.nres-1) then
9919         j1=j+1
9920         j2=j-1
9921       else
9922         j1=j-1
9923         j2=j-2
9924       endif
9925       if (l.lt.nres-1) then
9926         l1=l+1
9927         l2=l-1
9928       else
9929         l1=l-1
9930         l2=l-2
9931       endif
9932       do ll=1,3
9933 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9934 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9935 cgrad        ghalf=0.5d0*ggg1(ll)
9936 cd        ghalf=0.0d0
9937         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9938         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9939         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9940      &    +ekont*derx_turn(ll,2,1)
9941         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9942         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9943      &    +ekont*derx_turn(ll,4,1)
9944         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9945         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9946         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9947 cgrad        ghalf=0.5d0*ggg2(ll)
9948 cd        ghalf=0.0d0
9949         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9950      &    +ekont*derx_turn(ll,2,2)
9951         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9952         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9953      &    +ekont*derx_turn(ll,4,2)
9954         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9955         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9956         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9957       enddo
9958 cd      goto 1112
9959 cgrad      do m=i+1,j-1
9960 cgrad        do ll=1,3
9961 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9962 cgrad        enddo
9963 cgrad      enddo
9964 cgrad      do m=k+1,l-1
9965 cgrad        do ll=1,3
9966 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9967 cgrad        enddo
9968 cgrad      enddo
9969 cgrad1112  continue
9970 cgrad      do m=i+2,j2
9971 cgrad        do ll=1,3
9972 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9973 cgrad        enddo
9974 cgrad      enddo
9975 cgrad      do m=k+2,l2
9976 cgrad        do ll=1,3
9977 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9978 cgrad        enddo
9979 cgrad      enddo
9980 cd      do iii=1,nres-3
9981 cd        write (2,*) iii,g_corr6_loc(iii)
9982 cd      enddo
9983       eello_turn6=ekont*eel_turn6
9984 cd      write (2,*) 'ekont',ekont
9985 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9986       return
9987       end
9988
9989 C-----------------------------------------------------------------------------
9990       double precision function scalar(u,v)
9991 !DIR$ INLINEALWAYS scalar
9992 #ifndef OSF
9993 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9994 #endif
9995       implicit none
9996       double precision u(3),v(3)
9997 cd      double precision sc
9998 cd      integer i
9999 cd      sc=0.0d0
10000 cd      do i=1,3
10001 cd        sc=sc+u(i)*v(i)
10002 cd      enddo
10003 cd      scalar=sc
10004
10005       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10006       return
10007       end
10008 crc-------------------------------------------------
10009       SUBROUTINE MATVEC2(A1,V1,V2)
10010 !DIR$ INLINEALWAYS MATVEC2
10011 #ifndef OSF
10012 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10013 #endif
10014       implicit real*8 (a-h,o-z)
10015       include 'DIMENSIONS'
10016       DIMENSION A1(2,2),V1(2),V2(2)
10017 c      DO 1 I=1,2
10018 c        VI=0.0
10019 c        DO 3 K=1,2
10020 c    3     VI=VI+A1(I,K)*V1(K)
10021 c        Vaux(I)=VI
10022 c    1 CONTINUE
10023
10024       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10025       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10026
10027       v2(1)=vaux1
10028       v2(2)=vaux2
10029       END
10030 C---------------------------------------
10031       SUBROUTINE MATMAT2(A1,A2,A3)
10032 #ifndef OSF
10033 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10034 #endif
10035       implicit real*8 (a-h,o-z)
10036       include 'DIMENSIONS'
10037       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10038 c      DIMENSION AI3(2,2)
10039 c        DO  J=1,2
10040 c          A3IJ=0.0
10041 c          DO K=1,2
10042 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10043 c          enddo
10044 c          A3(I,J)=A3IJ
10045 c       enddo
10046 c      enddo
10047
10048       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10049       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10050       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10051       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10052
10053       A3(1,1)=AI3_11
10054       A3(2,1)=AI3_21
10055       A3(1,2)=AI3_12
10056       A3(2,2)=AI3_22
10057       END
10058
10059 c-------------------------------------------------------------------------
10060       double precision function scalar2(u,v)
10061 !DIR$ INLINEALWAYS scalar2
10062       implicit none
10063       double precision u(2),v(2)
10064       double precision sc
10065       integer i
10066       scalar2=u(1)*v(1)+u(2)*v(2)
10067       return
10068       end
10069
10070 C-----------------------------------------------------------------------------
10071
10072       subroutine transpose2(a,at)
10073 !DIR$ INLINEALWAYS transpose2
10074 #ifndef OSF
10075 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10076 #endif
10077       implicit none
10078       double precision a(2,2),at(2,2)
10079       at(1,1)=a(1,1)
10080       at(1,2)=a(2,1)
10081       at(2,1)=a(1,2)
10082       at(2,2)=a(2,2)
10083       return
10084       end
10085 c--------------------------------------------------------------------------
10086       subroutine transpose(n,a,at)
10087       implicit none
10088       integer n,i,j
10089       double precision a(n,n),at(n,n)
10090       do i=1,n
10091         do j=1,n
10092           at(j,i)=a(i,j)
10093         enddo
10094       enddo
10095       return
10096       end
10097 C---------------------------------------------------------------------------
10098       subroutine prodmat3(a1,a2,kk,transp,prod)
10099 !DIR$ INLINEALWAYS prodmat3
10100 #ifndef OSF
10101 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10102 #endif
10103       implicit none
10104       integer i,j
10105       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10106       logical transp
10107 crc      double precision auxmat(2,2),prod_(2,2)
10108
10109       if (transp) then
10110 crc        call transpose2(kk(1,1),auxmat(1,1))
10111 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10112 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10113
10114            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10115      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10116            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10117      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10118            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10119      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10120            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10121      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10122
10123       else
10124 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10125 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10126
10127            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10128      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10129            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10130      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10131            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10132      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10133            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10134      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10135
10136       endif
10137 c      call transpose2(a2(1,1),a2t(1,1))
10138
10139 crc      print *,transp
10140 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10141 crc      print *,((prod(i,j),i=1,2),j=1,2)
10142
10143       return
10144       end
10145 CCC----------------------------------------------
10146       subroutine Eliptransfer(eliptran)
10147       implicit real*8 (a-h,o-z)
10148       include 'DIMENSIONS'
10149       include 'COMMON.GEO'
10150       include 'COMMON.VAR'
10151       include 'COMMON.LOCAL'
10152       include 'COMMON.CHAIN'
10153       include 'COMMON.DERIV'
10154       include 'COMMON.NAMES'
10155       include 'COMMON.INTERACT'
10156       include 'COMMON.IOUNITS'
10157       include 'COMMON.CALC'
10158       include 'COMMON.CONTROL'
10159       include 'COMMON.SPLITELE'
10160       include 'COMMON.SBRIDGE'
10161 C this is done by Adasko
10162 C      print *,"wchodze"
10163 C structure of box:
10164 C      water
10165 C--bordliptop-- buffore starts
10166 C--bufliptop--- here true lipid starts
10167 C      lipid
10168 C--buflipbot--- lipid ends buffore starts
10169 C--bordlipbot--buffore ends
10170       eliptran=0.0
10171       do i=ilip_start,ilip_end
10172 C       do i=1,1
10173         if (itype(i).eq.ntyp1) cycle
10174
10175         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10176         if (positi.le.0) positi=positi+boxzsize
10177 C        print *,i
10178 C first for peptide groups
10179 c for each residue check if it is in lipid or lipid water border area
10180        if ((positi.gt.bordlipbot)
10181      &.and.(positi.lt.bordliptop)) then
10182 C the energy transfer exist
10183         if (positi.lt.buflipbot) then
10184 C what fraction I am in
10185          fracinbuf=1.0d0-
10186      &        ((positi-bordlipbot)/lipbufthick)
10187 C lipbufthick is thickenes of lipid buffore
10188          sslip=sscalelip(fracinbuf)
10189          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10190          eliptran=eliptran+sslip*pepliptran
10191          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10192          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10193 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10194
10195 C        print *,"doing sccale for lower part"
10196 C         print *,i,sslip,fracinbuf,ssgradlip
10197         elseif (positi.gt.bufliptop) then
10198          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10199          sslip=sscalelip(fracinbuf)
10200          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10201          eliptran=eliptran+sslip*pepliptran
10202          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10203          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10204 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10205 C          print *, "doing sscalefor top part"
10206 C         print *,i,sslip,fracinbuf,ssgradlip
10207         else
10208          eliptran=eliptran+pepliptran
10209 C         print *,"I am in true lipid"
10210         endif
10211 C       else
10212 C       eliptran=elpitran+0.0 ! I am in water
10213        endif
10214        enddo
10215 C       print *, "nic nie bylo w lipidzie?"
10216 C now multiply all by the peptide group transfer factor
10217 C       eliptran=eliptran*pepliptran
10218 C now the same for side chains
10219 CV       do i=1,1
10220        do i=ilip_start,ilip_end
10221         if (itype(i).eq.ntyp1) cycle
10222         positi=(mod(c(3,i+nres),boxzsize))
10223         if (positi.le.0) positi=positi+boxzsize
10224 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10225 c for each residue check if it is in lipid or lipid water border area
10226 C       respos=mod(c(3,i+nres),boxzsize)
10227 C       print *,positi,bordlipbot,buflipbot
10228        if ((positi.gt.bordlipbot)
10229      & .and.(positi.lt.bordliptop)) then
10230 C the energy transfer exist
10231         if (positi.lt.buflipbot) then
10232          fracinbuf=1.0d0-
10233      &     ((positi-bordlipbot)/lipbufthick)
10234 C lipbufthick is thickenes of lipid buffore
10235          sslip=sscalelip(fracinbuf)
10236          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10237          eliptran=eliptran+sslip*liptranene(itype(i))
10238          gliptranx(3,i)=gliptranx(3,i)
10239      &+ssgradlip*liptranene(itype(i))
10240          gliptranc(3,i-1)= gliptranc(3,i-1)
10241      &+ssgradlip*liptranene(itype(i))
10242 C         print *,"doing sccale for lower part"
10243         elseif (positi.gt.bufliptop) then
10244          fracinbuf=1.0d0-
10245      &((bordliptop-positi)/lipbufthick)
10246          sslip=sscalelip(fracinbuf)
10247          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10248          eliptran=eliptran+sslip*liptranene(itype(i))
10249          gliptranx(3,i)=gliptranx(3,i)
10250      &+ssgradlip*liptranene(itype(i))
10251          gliptranc(3,i-1)= gliptranc(3,i-1)
10252      &+ssgradlip*liptranene(itype(i))
10253 C          print *, "doing sscalefor top part",sslip,fracinbuf
10254         else
10255          eliptran=eliptran+liptranene(itype(i))
10256 C         print *,"I am in true lipid"
10257         endif
10258         endif ! if in lipid or buffor
10259 C       else
10260 C       eliptran=elpitran+0.0 ! I am in water
10261        enddo
10262        return
10263        end
10264 C---------------------------------------------------------
10265 C AFM soubroutine for constant force
10266        subroutine AFMforce(Eafmforce)
10267        implicit real*8 (a-h,o-z)
10268       include 'DIMENSIONS'
10269       include 'COMMON.GEO'
10270       include 'COMMON.VAR'
10271       include 'COMMON.LOCAL'
10272       include 'COMMON.CHAIN'
10273       include 'COMMON.DERIV'
10274       include 'COMMON.NAMES'
10275       include 'COMMON.INTERACT'
10276       include 'COMMON.IOUNITS'
10277       include 'COMMON.CALC'
10278       include 'COMMON.CONTROL'
10279       include 'COMMON.SPLITELE'
10280       include 'COMMON.SBRIDGE'
10281       real*8 diffafm(3)
10282       dist=0.0d0
10283       Eafmforce=0.0d0
10284       do i=1,3
10285       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10286       dist=dist+diffafm(i)**2
10287       enddo
10288       dist=dsqrt(dist)
10289       Eafmforce=-forceAFMconst*(dist-distafminit)
10290       do i=1,3
10291       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10292       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10293       enddo
10294 C      print *,'AFM',Eafmforce
10295       return
10296       end
10297 C---------------------------------------------------------
10298 C AFM subroutine with pseudoconstant velocity
10299        subroutine AFMvel(Eafmforce)
10300        implicit real*8 (a-h,o-z)
10301       include 'DIMENSIONS'
10302       include 'COMMON.GEO'
10303       include 'COMMON.VAR'
10304       include 'COMMON.LOCAL'
10305       include 'COMMON.CHAIN'
10306       include 'COMMON.DERIV'
10307       include 'COMMON.NAMES'
10308       include 'COMMON.INTERACT'
10309       include 'COMMON.IOUNITS'
10310       include 'COMMON.CALC'
10311       include 'COMMON.CONTROL'
10312       include 'COMMON.SPLITELE'
10313       include 'COMMON.SBRIDGE'
10314       real*8 diffafm(3)
10315 C Only for check grad COMMENT if not used for checkgrad
10316 C      totT=3.0d0
10317 C--------------------------------------------------------
10318 C      print *,"wchodze"
10319       dist=0.0d0
10320       Eafmforce=0.0d0
10321       do i=1,3
10322       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10323       dist=dist+diffafm(i)**2
10324       enddo
10325       dist=dsqrt(dist)
10326       Eafmforce=0.5d0*forceAFMconst
10327      & *(distafminit+totTafm*velAFMconst-dist)**2
10328 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10329       do i=1,3
10330       gradafm(i,afmend-1)=-forceAFMconst*
10331      &(distafminit+totTafm*velAFMconst-dist)
10332      &*diffafm(i)/dist
10333       gradafm(i,afmbeg-1)=forceAFMconst*
10334      &(distafminit+totTafm*velAFMconst-dist)
10335      &*diffafm(i)/dist
10336       enddo
10337 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10338       return
10339       end
10340