source/unres/src_Eshel/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.ECOMPON"
  28       do i=1,ntyp
  29         vdw2compon(i)=0.0d0
  30         becompon(i)=0.0d0
  31         sccompon(i)=0.0d0
  32         tordcompon(i)=0.0d0
  33       enddo
  34       do i=1,ntyp
  35         do j=1,ntyp
  36           vdwcompon(i,j)=0.0d0
  37           torcompon(i,j)=0.0d0
  38           sccorcompon(i,j)=0.0d0
  39         enddo
  40       enddo
  41 #ifdef MPI
  42 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  43 c     & " nfgtasks",nfgtasks
  44       if (nfgtasks.gt.1) then
  45 #ifdef MPI
  46         time00=MPI_Wtime()
  47 #else
  48         time00=tcpu()
  49 #endif
  50 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  51         if (fg_rank.eq.0) then
  52           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  53 c          print *,"Processor",myrank," BROADCAST iorder"
  54 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  55 C FG slaves as WEIGHTS array.
  56           weights_(1)=wsc
  57           weights_(2)=wscp
  58           weights_(3)=welec
  59           weights_(4)=wcorr
  60           weights_(5)=wcorr5
  61           weights_(6)=wcorr6
  62           weights_(7)=wel_loc
  63           weights_(8)=wturn3
  64           weights_(9)=wturn4
  65           weights_(10)=wturn6
  66           weights_(11)=wang
  67           weights_(12)=wscloc
  68           weights_(13)=wtor
  69           weights_(14)=wtor_d
  70           weights_(15)=wstrain
  71           weights_(16)=wvdwpp
  72           weights_(17)=wbond
  73           weights_(18)=scal14
  74           weights_(21)=wsccor
  75           weights_(22)=wsct
  76 C FG Master broadcasts the WEIGHTS_ array
  77           call MPI_Bcast(weights_(1),n_ene,
  78      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  79         else
  80 C FG slaves receive the WEIGHTS array
  81           call MPI_Bcast(weights(1),n_ene,
  82      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  83           wsc=weights(1)
  84           wscp=weights(2)
  85           welec=weights(3)
  86           wcorr=weights(4)
  87           wcorr5=weights(5)
  88           wcorr6=weights(6)
  89           wel_loc=weights(7)
  90           wturn3=weights(8)
  91           wturn4=weights(9)
  92           wturn6=weights(10)
  93           wang=weights(11)
  94           wscloc=weights(12)
  95           wtor=weights(13)
  96           wtor_d=weights(14)
  97           wstrain=weights(15)
  98           wvdwpp=weights(16)
  99           wbond=weights(17)
 100           scal14=weights(18)
 101           wsccor=weights(21)
 102           wsct=weights(22)
 103         endif
 104         time_Bcast=time_Bcast+MPI_Wtime()-time00
 105         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 106 c        call chainbuild_cart
 107       endif
 108 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 109 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 110 #else
 111 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 112 c        call int_from_cart1(.false.)
 113 c      endif
 114 #endif
 115 #ifdef TIMING
 116 #ifdef MPI
 117       time00=MPI_Wtime()
 118 #else
 119       time00=tcpu()
 120 #endif
 121 #endif
 122 C
 123 C Compute the side-chain and electrostatic interaction energy
 124 C
 125       goto (101,102,103,104,105,106) ipot
 126 C Lennard-Jones potential.
 127   101 call elj(evdw,evdw_p,evdw_m)
 128 cd    print '(a)','Exit ELJ'
 129       goto 107
 130 C Lennard-Jones-Kihara potential (shifted).
 131   102 call eljk(evdw,evdw_p,evdw_m)
 132       goto 107
 133 C Berne-Pechukas potential (dilated LJ, angular dependence).
 134   103 call ebp(evdw,evdw_p,evdw_m)
 135       goto 107
 136 C Gay-Berne potential (shifted LJ, angular dependence).
 137   104 call egb(evdw,evdw_p,evdw_m)
 138       goto 107
 139 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 140   105 call egbv(evdw,evdw_p,evdw_m)
 141       goto 107
 142 C Soft-sphere potential
 143   106 call e_softsphere(evdw)
 144 C
 145 C Calculate electrostatic (H-bonding) energy of the main chain.
 146 C
 147   107 continue
 148 c      print *,"Processor",myrank," computed USCSC"
 149 #ifdef TIMING
 150 #ifdef MPI
 151       time01=MPI_Wtime()
 152 #else
 153       time00=tcpu()
 154 #endif
 155 #endif
 156       call vec_and_deriv
 157 #ifdef TIMING
 158 #ifdef MPI
 159       time_vec=time_vec+MPI_Wtime()-time01
 160 #else
 161       time_vec=time_vec+tcpu()-time01
 162 #endif
 163 #endif
 164 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 165       if (ipot.lt.6) then
 166 #ifdef SPLITELE
 167          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 168      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 169      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 170      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 171 #else
 172          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 173      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 174      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 175      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 176 #endif
 177             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 178          else
 179             ees=0.0d0
 180             evdw1=0.0d0
 181             eel_loc=0.0d0
 182             eello_turn3=0.0d0
 183             eello_turn4=0.0d0
 184          endif
 185       else
 186 c        write (iout,*) "Soft-spheer ELEC potential"
 187         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 188      &   eello_turn4)
 189       endif
 190 c      print *,"Processor",myrank," computed UELEC"
 191 C
 192 C Calculate excluded-volume interaction energy between peptide groups
 193 C and side chains.
 194 C
 195       if (ipot.lt.6) then
 196        if(wscp.gt.0d0) then
 197         call escp(evdw2,evdw2_14)
 198        else
 199         evdw2=0
 200         evdw2_14=0
 201        endif
 202       else
 203 c        write (iout,*) "Soft-sphere SCP potential"
 204         call escp_soft_sphere(evdw2,evdw2_14)
 205       endif
 206 c
 207 c Calculate the bond-stretching energy
 208 c
 209       call ebond(estr)
 210 C
 211 C Calculate the disulfide-bridge and other energy and the contributions
 212 C from other distance constraints.
 213 cd    print *,'Calling EHPB'
 214       call edis(ehpb)
 215 cd    print *,'EHPB exitted succesfully.'
 216 C
 217 C Calculate the virtual-bond-angle energy.
 218 C
 219       if (wang.gt.0d0) then
 220         call ebend(ebe)
 221       else
 222         ebe=0
 223       endif
 224 c      print *,"Processor",myrank," computed UB"
 225 C
 226 C Calculate the SC local energy.
 227 C
 228       call esc(escloc)
 229 c      print *,"Processor",myrank," computed USC"
 230 C
 231 C Calculate the virtual-bond torsional energy.
 232 C
 233 cd    print *,'nterm=',nterm
 234       if (wtor.gt.0) then
 235        call etor(etors,edihcnstr)
 236       else
 237        etors=0
 238        edihcnstr=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utor"
 241 C
 242 C 6/23/01 Calculate double-torsional energy
 243 C
 244       if (wtor_d.gt.0) then
 245        call etor_d(etors_d)
 246       else
 247        etors_d=0
 248       endif
 249 c      print *,"Processor",myrank," computed Utord"
 250 C
 251 C 21/5/07 Calculate local sicdechain correlation energy
 252 C
 253 c      if (wsccor.gt.0.0d0) then
 254         call eback_sc_corr(esccor)
 255 c      else
 256 c        esccor=0.0d0
 257 c      endif
 258 c      print *,"Processor",myrank," computed Usccorr"
 259 C
 260 C 12/1/95 Multi-body terms
 261 C
 262       n_corr=0
 263       n_corr1=0
 264       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 265      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 266          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 267 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 268 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 269       else
 270          ecorr=0.0d0
 271          ecorr5=0.0d0
 272          ecorr6=0.0d0
 273          eturn6=0.0d0
 274       endif
 275       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 276          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 277 cd         write (iout,*) "multibody_hb ecorr",ecorr
 278       endif
 279 c      print *,"Processor",myrank," computed Ucorr"
 280 C
 281 C If performing constraint dynamics, call the constraint energy
 282 C  after the equilibration time
 283 c      if(usampl.and.totT.gt.eq_time) then
 284 c         call EconstrQ
 285 c         call Econstr_back
 286 c      else
 287 c         Uconst=0.0d0
 288 c         Uconst_back=0.0d0
 289 c      endif
 290 #ifdef TIMING
 291 #ifdef MPI
 292       time_enecalc=time_enecalc+MPI_Wtime()-time00
 293 #else
 294       time_enecalc=time_enecalc+tcpu()-time00
 295 #endif
 296 #endif
 297 c      print *,"Processor",myrank," computed Uconstr"
 298 #ifdef TIMING
 299 #ifdef MPI
 300       time00=MPI_Wtime()
 301 #else
 302       time00=tcpu()
 303 #endif
 304 #endif
 305 c
 306 C Sum the energies
 307 C
 308       energia(1)=evdw
 309 #ifdef SCP14
 310       energia(2)=evdw2-evdw2_14
 311       energia(18)=evdw2_14
 312 #else
 313       energia(2)=evdw2
 314       energia(18)=0.0d0
 315 #endif
 316 #ifdef SPLITELE
 317       energia(3)=ees
 318       energia(16)=evdw1
 319 #else
 320       energia(3)=ees+evdw1
 321       energia(16)=0.0d0
 322 #endif
 323       energia(4)=ecorr
 324       energia(5)=ecorr5
 325       energia(6)=ecorr6
 326       energia(7)=eel_loc
 327       energia(8)=eello_turn3
 328       energia(9)=eello_turn4
 329       energia(10)=eturn6
 330       energia(11)=ebe
 331       energia(12)=escloc
 332       energia(13)=etors
 333       energia(14)=etors_d
 334       energia(15)=ehpb
 335       energia(19)=edihcnstr
 336       energia(17)=estr
 337       energia(20)=Uconst+Uconst_back
 338       energia(21)=esccor
 339       energia(22)=evdw_p
 340       energia(23)=evdw_m
 341 c      print *," Processor",myrank," calls SUM_ENERGY"
 342       call sum_energy(energia,.true.)
 343 c      print *," Processor",myrank," left SUM_ENERGY"
 344 #ifdef TIMING
 345 #ifdef MPI
 346       time_sumene=time_sumene+MPI_Wtime()-time00
 347 #else
 348       time_sumene=time_sumene+tcpu()-time00
 349 #endif
 350 #endif
 351       return
 352       end
 353 c-------------------------------------------------------------------------------
 354       subroutine sum_energy(energia,reduce)
 355       implicit real*8 (a-h,o-z)
 356       include 'DIMENSIONS'
 357 #ifndef ISNAN
 358       external proc_proc
 359 #ifdef WINPGI
 360 cMS$ATTRIBUTES C ::  proc_proc
 361 #endif
 362 #endif
 363 #ifdef MPI
 364       include "mpif.h"
 365 #endif
 366       include 'COMMON.SETUP'
 367       include 'COMMON.IOUNITS'
 368       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 369       include 'COMMON.FFIELD'
 370       include 'COMMON.DERIV'
 371       include 'COMMON.INTERACT'
 372       include 'COMMON.SBRIDGE'
 373       include 'COMMON.CHAIN'
 374       include 'COMMON.VAR'
 375       include 'COMMON.CONTROL'
 376       include 'COMMON.TIME1'
 377       logical reduce
 378 #ifdef MPI
 379       if (nfgtasks.gt.1 .and. reduce) then
 380 #ifdef DEBUG
 381         write (iout,*) "energies before REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         do i=0,n_ene
 386           enebuff(i)=energia(i)
 387         enddo
 388         time00=MPI_Wtime()
 389         call MPI_Barrier(FG_COMM,IERR)
 390         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 391         time00=MPI_Wtime()
 392         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 393      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 394 #ifdef DEBUG
 395         write (iout,*) "energies after REDUCE"
 396         call enerprint(energia)
 397         call flush(iout)
 398 #endif
 399         time_Reduce=time_Reduce+MPI_Wtime()-time00
 400       endif
 401       if (fg_rank.eq.0) then
 402 #endif
 403 #ifdef TSCSC
 404       evdw=energia(22)+wsct*energia(23)
 405 #else
 406       evdw=energia(1)
 407 #endif
 408 #ifdef SCP14
 409       evdw2=energia(2)+energia(18)
 410       evdw2_14=energia(18)
 411 #else
 412       evdw2=energia(2)
 413 #endif
 414 #ifdef SPLITELE
 415       ees=energia(3)
 416       evdw1=energia(16)
 417 #else
 418       ees=energia(3)
 419       evdw1=0.0d0
 420 #endif
 421       ecorr=energia(4)
 422       ecorr5=energia(5)
 423       ecorr6=energia(6)
 424       eel_loc=energia(7)
 425       eello_turn3=energia(8)
 426       eello_turn4=energia(9)
 427       eturn6=energia(10)
 428       ebe=energia(11)
 429       escloc=energia(12)
 430       etors=energia(13)
 431       etors_d=energia(14)
 432       ehpb=energia(15)
 433       edihcnstr=energia(19)
 434       estr=energia(17)
 435       Uconst=energia(20)
 436       esccor=energia(21)
 437 #ifdef SPLITELE
 438       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 439      & +wang*ebe+wtor*etors+wscloc*escloc
 440      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 441      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 442      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 443      & +wbond*estr+Uconst+wsccor*esccor
 444 #else
 445       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 446      & +wang*ebe+wtor*etors+wscloc*escloc
 447      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 448      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 449      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 450      & +wbond*estr+Uconst+wsccor*esccor
 451 #endif
 452       energia(0)=etot
 453 c detecting NaNQ
 454 #ifdef ISNAN
 455 #ifdef AIX
 456       if (isnan(etot).ne.0) energia(0)=1.0d+99
 457 #else
 458       if (isnan(etot)) energia(0)=1.0d+99
 459 #endif
 460 #else
 461       i=0
 462 #ifdef WINPGI
 463       idumm=proc_proc(etot,i)
 464 #else
 465       call proc_proc(etot,i)
 466 #endif
 467       if(i.eq.1)energia(0)=1.0d+99
 468 #endif
 469 #ifdef MPI
 470       endif
 471 #endif
 472       return
 473       end
 474 c-------------------------------------------------------------------------------
 475       subroutine sum_gradient
 476       implicit real*8 (a-h,o-z)
 477       include 'DIMENSIONS'
 478 #ifndef ISNAN
 479       external proc_proc
 480 #ifdef WINPGI
 481 cMS$ATTRIBUTES C ::  proc_proc
 482 #endif
 483 #endif
 484 #ifdef MPI
 485       include 'mpif.h'
 486 #endif
 487       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 488      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 489       include 'COMMON.SETUP'
 490       include 'COMMON.IOUNITS'
 491       include 'COMMON.FFIELD'
 492       include 'COMMON.DERIV'
 493       include 'COMMON.INTERACT'
 494       include 'COMMON.SBRIDGE'
 495       include 'COMMON.CHAIN'
 496       include 'COMMON.VAR'
 497       include 'COMMON.CONTROL'
 498       include 'COMMON.TIME1'
 499       include 'COMMON.MAXGRAD'
 500       include 'COMMON.SCCOR'
 501 #ifdef TIMING
 502 #ifdef MPI
 503       time01=MPI_Wtime()
 504 #else
 505       time01=tcpu()
 506 #endif
 507 #endif
 508 #ifdef DEBUG
 509       write (iout,*) "sum_gradient gvdwc, gvdwx"
 510       do i=1,nres
 511         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 512      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 513      &   (gvdwcT(j,i),j=1,3)
 514       enddo
 515       call flush(iout)
 516 #endif
 517 #ifdef MPI
 518 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 519         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 520      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 521 #endif
 522 C
 523 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 524 C            in virtual-bond-vector coordinates
 525 C
 526 #ifdef DEBUG
 527 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 528 c      do i=1,nres-1
 529 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 530 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 531 c      enddo
 532 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 533 c      do i=1,nres-1
 534 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 535 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 536 c      enddo
 537       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 538       do i=1,nres
 539         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 540      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 541      &   g_corr5_loc(i)
 542       enddo
 543       call flush(iout)
 544 #endif
 545 #ifdef SPLITELE
 546 #ifdef TSCSC
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #else
 561       do i=1,nct
 562         do j=1,3
 563           gradbufc(j,i)=wsc*gvdwc(j,i)+
 564      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 565      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 566      &                wel_loc*gel_loc_long(j,i)+
 567      &                wcorr*gradcorr_long(j,i)+
 568      &                wcorr5*gradcorr5_long(j,i)+
 569      &                wcorr6*gradcorr6_long(j,i)+
 570      &                wturn6*gcorr6_turn_long(j,i)+
 571      &                wstrain*ghpbc(j,i)
 572         enddo
 573       enddo
 574 #endif
 575 #else
 576       do i=1,nct
 577         do j=1,3
 578           gradbufc(j,i)=wsc*gvdwc(j,i)+
 579      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 580      &                welec*gelc_long(j,i)+
 581      &                wbond*gradb(j,i)+
 582      &                wel_loc*gel_loc_long(j,i)+
 583      &                wcorr*gradcorr_long(j,i)+
 584      &                wcorr5*gradcorr5_long(j,i)+
 585      &                wcorr6*gradcorr6_long(j,i)+
 586      &                wturn6*gcorr6_turn_long(j,i)+
 587      &                wstrain*ghpbc(j,i)
 588         enddo
 589       enddo
 590 #endif
 591 #ifdef MPI
 592       if (nfgtasks.gt.1) then
 593       time00=MPI_Wtime()
 594 #ifdef DEBUG
 595       write (iout,*) "gradbufc before allreduce"
 596       do i=1,nres
 597         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 598       enddo
 599       call flush(iout)
 600 #endif
 601       do i=1,nres
 602         do j=1,3
 603           gradbufc_sum(j,i)=gradbufc(j,i)
 604         enddo
 605       enddo
 606 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 607 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 608 c      time_reduce=time_reduce+MPI_Wtime()-time00
 609 #ifdef DEBUG
 610 c      write (iout,*) "gradbufc_sum after allreduce"
 611 c      do i=1,nres
 612 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 613 c      enddo
 614 c      call flush(iout)
 615 #endif
 616 #ifdef TIMING
 617 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 618 #endif
 619       do i=nnt,nres
 620         do k=1,3
 621           gradbufc(k,i)=0.0d0
 622         enddo
 623       enddo
 624 #ifdef DEBUG
 625       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 626       write (iout,*) (i," jgrad_start",jgrad_start(i),
 627      &                  " jgrad_end  ",jgrad_end(i),
 628      &                  i=igrad_start,igrad_end)
 629 #endif
 630 c
 631 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 632 c do not parallelize this part.
 633 c
 634 c      do i=igrad_start,igrad_end
 635 c        do j=jgrad_start(i),jgrad_end(i)
 636 c          do k=1,3
 637 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 638 c          enddo
 639 c        enddo
 640 c      enddo
 641       do j=1,3
 642         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 643       enddo
 644       do i=nres-2,nnt,-1
 645         do j=1,3
 646           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 647         enddo
 648       enddo
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc after summing"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       else
 657 #endif
 658 #ifdef DEBUG
 659       write (iout,*) "gradbufc"
 660       do i=1,nres
 661         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 662       enddo
 663       call flush(iout)
 664 #endif
 665       do i=1,nres
 666         do j=1,3
 667           gradbufc_sum(j,i)=gradbufc(j,i)
 668           gradbufc(j,i)=0.0d0
 669         enddo
 670       enddo
 671       do j=1,3
 672         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 673       enddo
 674       do i=nres-2,nnt,-1
 675         do j=1,3
 676           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 677         enddo
 678       enddo
 679 c      do i=nnt,nres-1
 680 c        do k=1,3
 681 c          gradbufc(k,i)=0.0d0
 682 c        enddo
 683 c        do j=i+1,nres
 684 c          do k=1,3
 685 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 686 c          enddo
 687 c        enddo
 688 c      enddo
 689 #ifdef DEBUG
 690       write (iout,*) "gradbufc after summing"
 691       do i=1,nres
 692         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 693       enddo
 694       call flush(iout)
 695 #endif
 696 #ifdef MPI
 697       endif
 698 #endif
 699       do k=1,3
 700         gradbufc(k,nres)=0.0d0
 701       enddo
 702       do i=1,nct
 703         do j=1,3
 704 #ifdef SPLITELE
 705           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 706      &                wel_loc*gel_loc(j,i)+
 707      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 708      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 709      &                wel_loc*gel_loc_long(j,i)+
 710      &                wcorr*gradcorr_long(j,i)+
 711      &                wcorr5*gradcorr5_long(j,i)+
 712      &                wcorr6*gradcorr6_long(j,i)+
 713      &                wturn6*gcorr6_turn_long(j,i))+
 714      &                wbond*gradb(j,i)+
 715      &                wcorr*gradcorr(j,i)+
 716      &                wturn3*gcorr3_turn(j,i)+
 717      &                wturn4*gcorr4_turn(j,i)+
 718      &                wcorr5*gradcorr5(j,i)+
 719      &                wcorr6*gradcorr6(j,i)+
 720      &                wturn6*gcorr6_turn(j,i)+
 721      &                wsccor*gsccorc(j,i)
 722      &               +wscloc*gscloc(j,i)
 723 #else
 724           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 725      &                wel_loc*gel_loc(j,i)+
 726      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 727      &                welec*gelc_long(j,i)+
 728      &                wel_loc*gel_loc_long(j,i)+
 729      &                wcorr*gcorr_long(j,i)+
 730      &                wcorr5*gradcorr5_long(j,i)+
 731      &                wcorr6*gradcorr6_long(j,i)+
 732      &                wturn6*gcorr6_turn_long(j,i))+
 733      &                wbond*gradb(j,i)+
 734      &                wcorr*gradcorr(j,i)+
 735      &                wturn3*gcorr3_turn(j,i)+
 736      &                wturn4*gcorr4_turn(j,i)+
 737      &                wcorr5*gradcorr5(j,i)+
 738      &                wcorr6*gradcorr6(j,i)+
 739      &                wturn6*gcorr6_turn(j,i)+
 740      &                wsccor*gsccorc(j,i)
 741      &               +wscloc*gscloc(j,i)
 742 #endif
 743 #ifdef TSCSC
 744           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 745      &                  wscp*gradx_scp(j,i)+
 746      &                  wbond*gradbx(j,i)+
 747      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 748      &                  wsccor*gsccorx(j,i)
 749      &                 +wscloc*gsclocx(j,i)
 750 #else
 751           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 752      &                  wbond*gradbx(j,i)+
 753      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 754      &                  wsccor*gsccorx(j,i)
 755      &                 +wscloc*gsclocx(j,i)
 756 #endif
 757         enddo
 758       enddo
 759 #ifdef DEBUG
 760       write (iout,*) "gloc before adding corr"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       do i=1,nres-3
 766         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 767      &   +wcorr5*g_corr5_loc(i)
 768      &   +wcorr6*g_corr6_loc(i)
 769      &   +wturn4*gel_loc_turn4(i)
 770      &   +wturn3*gel_loc_turn3(i)
 771      &   +wturn6*gel_loc_turn6(i)
 772      &   +wel_loc*gel_loc_loc(i)
 773       enddo
 774 #ifdef DEBUG
 775       write (iout,*) "gloc after adding corr"
 776       do i=1,4*nres
 777         write (iout,*) i,gloc(i,icg)
 778       enddo
 779 #endif
 780 #ifdef MPI
 781       if (nfgtasks.gt.1) then
 782         do j=1,3
 783           do i=1,nres
 784             gradbufc(j,i)=gradc(j,i,icg)
 785             gradbufx(j,i)=gradx(j,i,icg)
 786           enddo
 787         enddo
 788         do i=1,4*nres
 789           glocbuf(i)=gloc(i,icg)
 790         enddo
 791 #ifdef DEBUG
 792       write (iout,*) "gloc_sc before reduce"
 793       do i=1,nres
 794        do j=1,3
 795         write (iout,*) i,j,gloc_sc(j,i,icg)
 796        enddo
 797       enddo
 798 #endif
 799         do i=1,nres
 800          do j=1,3
 801           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 802          enddo
 803         enddo
 804         time00=MPI_Wtime()
 805         call MPI_Barrier(FG_COMM,IERR)
 806         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 807         time00=MPI_Wtime()
 808         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 809      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 810         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 811      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 812         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 813      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 814         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 815      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 816         time_reduce=time_reduce+MPI_Wtime()-time00
 817 #ifdef DEBUG
 818       write (iout,*) "gloc_sc after reduce"
 819       do i=1,nres
 820        do j=1,3
 821         write (iout,*) i,j,gloc_sc(j,i,icg)
 822        enddo
 823       enddo
 824 #endif
 825 #ifdef DEBUG
 826       write (iout,*) "gloc after reduce"
 827       do i=1,4*nres
 828         write (iout,*) i,gloc(i,icg)
 829       enddo
 830 #endif
 831       endif
 832 #endif
 833       if (gnorm_check) then
 834 c
 835 c Compute the maximum elements of the gradient
 836 c
 837       gvdwc_max=0.0d0
 838       gvdwc_scp_max=0.0d0
 839       gelc_max=0.0d0
 840       gvdwpp_max=0.0d0
 841       gradb_max=0.0d0
 842       ghpbc_max=0.0d0
 843       gradcorr_max=0.0d0
 844       gel_loc_max=0.0d0
 845       gcorr3_turn_max=0.0d0
 846       gcorr4_turn_max=0.0d0
 847       gradcorr5_max=0.0d0
 848       gradcorr6_max=0.0d0
 849       gcorr6_turn_max=0.0d0
 850       gsccorc_max=0.0d0
 851       gscloc_max=0.0d0
 852       gvdwx_max=0.0d0
 853       gradx_scp_max=0.0d0
 854       ghpbx_max=0.0d0
 855       gradxorr_max=0.0d0
 856       gsccorx_max=0.0d0
 857       gsclocx_max=0.0d0
 858       do i=1,nct
 859         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 860         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 861 #ifdef TSCSC
 862         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 863         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 864 #endif
 865         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 866         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 867      &   gvdwc_scp_max=gvdwc_scp_norm
 868         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 869         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 870         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 871         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 872         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 873         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 874         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 875         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 876         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 877         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 878         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 879         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 880         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 881      &    gcorr3_turn(1,i)))
 882         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 883      &    gcorr3_turn_max=gcorr3_turn_norm
 884         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 885      &    gcorr4_turn(1,i)))
 886         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 887      &    gcorr4_turn_max=gcorr4_turn_norm
 888         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 889         if (gradcorr5_norm.gt.gradcorr5_max)
 890      &    gradcorr5_max=gradcorr5_norm
 891         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 892         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 893         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 894      &    gcorr6_turn(1,i)))
 895         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 896      &    gcorr6_turn_max=gcorr6_turn_norm
 897         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 898         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 899         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 900         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 901         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 902         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 903 #ifdef TSCSC
 904         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 905         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 906 #endif
 907         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 908         if (gradx_scp_norm.gt.gradx_scp_max)
 909      &    gradx_scp_max=gradx_scp_norm
 910         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 911         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 912         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 913         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 914         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 915         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 916         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 917         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 918       enddo
 919       if (gradout) then
 920 #ifdef AIX
 921         open(istat,file=statname,position="append")
 922 #else
 923         open(istat,file=statname,access="append")
 924 #endif
 925         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 926      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 927      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 928      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 929      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 930      &     gsccorx_max,gsclocx_max
 931         close(istat)
 932         if (gvdwc_max.gt.1.0d4) then
 933           write (iout,*) "gvdwc gvdwx gradb gradbx"
 934           do i=nnt,nct
 935             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 936      &        gradb(j,i),gradbx(j,i),j=1,3)
 937           enddo
 938           call pdbout(0.0d0,'cipiszcze',iout)
 939           call flush(iout)
 940         endif
 941       endif
 942       endif
 943 #ifdef DEBUG
 944       write (iout,*) "gradc gradx gloc"
 945       do i=1,nres
 946         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 947      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 948       enddo
 949 #endif
 950 #ifdef TIMING
 951 #ifdef MPI
 952       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 953 #else
 954       time_sumgradient=time_sumgradient+tcpu()-time01
 955 #endif
 956 #endif
 957       return
 958       end
 959 c-------------------------------------------------------------------------------
 960       subroutine rescale_weights(t_bath)
 961       implicit real*8 (a-h,o-z)
 962       include 'DIMENSIONS'
 963       include 'COMMON.IOUNITS'
 964       include 'COMMON.FFIELD'
 965       include 'COMMON.SBRIDGE'
 966       double precision kfac /2.4d0/
 967       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 968 c      facT=temp0/t_bath
 969 c      facT=2*temp0/(t_bath+temp0)
 970       if (rescale_mode.eq.0) then
 971         facT=1.0d0
 972         facT2=1.0d0
 973         facT3=1.0d0
 974         facT4=1.0d0
 975         facT5=1.0d0
 976       else if (rescale_mode.eq.1) then
 977         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 978         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 979         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 980         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 981         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 982       else if (rescale_mode.eq.2) then
 983         x=t_bath/temp0
 984         x2=x*x
 985         x3=x2*x
 986         x4=x3*x
 987         x5=x4*x
 988         facT=licznik/dlog(dexp(x)+dexp(-x))
 989         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 990         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 991         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 992         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 993       else
 994         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 995         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 996 #ifdef MPI
 997        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 998 #endif
 999        stop 555
1000       endif
1001       welec=weights(3)*fact
1002       wcorr=weights(4)*fact3
1003       wcorr5=weights(5)*fact4
1004       wcorr6=weights(6)*fact5
1005       wel_loc=weights(7)*fact2
1006       wturn3=weights(8)*fact2
1007       wturn4=weights(9)*fact3
1008       wturn6=weights(10)*fact5
1009       wtor=weights(13)*fact
1010       wtor_d=weights(14)*fact2
1011       wsccor=weights(21)*fact
1012 #ifdef TSCSC
1013 c      wsct=t_bath/temp0
1014       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1015 #endif
1016       return
1017       end
1018 C------------------------------------------------------------------------
1019       subroutine enerprint(energia)
1020       implicit real*8 (a-h,o-z)
1021       include 'DIMENSIONS'
1022       include 'COMMON.IOUNITS'
1023       include 'COMMON.FFIELD'
1024       include 'COMMON.SBRIDGE'
1025       include 'COMMON.MD'
1026       double precision energia(0:n_ene)
1027       etot=energia(0)
1028 #ifdef TSCSC
1029       evdw=energia(22)+wsct*energia(23)
1030 #else
1031       evdw=energia(1)
1032 #endif
1033       evdw2=energia(2)
1034 #ifdef SCP14
1035       evdw2=energia(2)+energia(18)
1036 #else
1037       evdw2=energia(2)
1038 #endif
1039       ees=energia(3)
1040 #ifdef SPLITELE
1041       evdw1=energia(16)
1042 #endif
1043       ecorr=energia(4)
1044       ecorr5=energia(5)
1045       ecorr6=energia(6)
1046       eel_loc=energia(7)
1047       eello_turn3=energia(8)
1048       eello_turn4=energia(9)
1049       eello_turn6=energia(10)
1050       ebe=energia(11)
1051       escloc=energia(12)
1052       etors=energia(13)
1053       etors_d=energia(14)
1054       ehpb=energia(15)
1055       edihcnstr=energia(19)
1056       estr=energia(17)
1057       Uconst=energia(20)
1058       esccor=energia(21)
1059 #ifdef SPLITELE
1060       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1061      &  estr,wbond,ebe,wang,
1062      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1063      &  ecorr,wcorr,
1064      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1065      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1066      &  edihcnstr,ebr*nss,
1067      &  Uconst,etot
1068    10 format (/'Virtual-chain energies:'//
1069      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1070      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1071      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1072      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1073      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1074      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1075      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1076      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1077      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1078      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1079      & ' (SS bridges & dist. cnstr.)'/
1080      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1081      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1082      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1083      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1084      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1085      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1086      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1087      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1088      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1089      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1090      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1091      & 'ETOT=  ',1pE16.6,' (total)')
1092 #else
1093       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1094      &  estr,wbond,ebe,wang,
1095      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1096      &  ecorr,wcorr,
1097      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1098      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1099      &  ebr*nss,Uconst,etot
1100    10 format (/'Virtual-chain energies:'//
1101      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1102      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1103      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1104      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1105      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1106      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1107      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1108      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1109      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1110      & ' (SS bridges & dist. cnstr.)'/
1111      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1112      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1113      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1114      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1115      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1116      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1117      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1118      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1119      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1120      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1121      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1122      & 'ETOT=  ',1pE16.6,' (total)')
1123 #endif
1124       return
1125       end
1126 C-----------------------------------------------------------------------
1127       subroutine elj(evdw,evdw_p,evdw_m)
1128 C
1129 C This subroutine calculates the interaction energy of nonbonded side chains
1130 C assuming the LJ potential of interaction.
1131 C
1132       implicit real*8 (a-h,o-z)
1133       include 'DIMENSIONS'
1134       parameter (accur=1.0d-10)
1135       include 'COMMON.GEO'
1136       include 'COMMON.VAR'
1137       include 'COMMON.LOCAL'
1138       include 'COMMON.CHAIN'
1139       include 'COMMON.DERIV'
1140       include 'COMMON.INTERACT'
1141       include 'COMMON.TORSION'
1142       include 'COMMON.SBRIDGE'
1143       include 'COMMON.NAMES'
1144       include 'COMMON.IOUNITS'
1145       include 'COMMON.CONTACTS'
1146       include "COMMON.ECOMPON"
1147       dimension gg(3)
1148 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1149       evdw=0.0D0
1150       do i=iatsc_s,iatsc_e
1151         itypi=itype(i)
1152         itypi1=itype(i+1)
1153         xi=c(1,nres+i)
1154         yi=c(2,nres+i)
1155         zi=c(3,nres+i)
1156         if (itypi.eq.ntyp1) cycle
1157 C Change 12/1/95
1158         num_conti=0
1159 C
1160 C Calculate SC interaction energy.
1161 C
1162         do iint=1,nint_gr(i)
1163 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1164 cd   &                  'iend=',iend(i,iint)
1165           do j=istart(i,iint),iend(i,iint)
1166             itypj=itype(j)
1167             if (itypj.eq.ntyp1) cycle
1168             xj=c(1,nres+j)-xi
1169             yj=c(2,nres+j)-yi
1170             zj=c(3,nres+j)-zi
1171 C Change 12/1/95 to calculate four-body interactions
1172             rij=xj*xj+yj*yj+zj*zj
1173             rrij=1.0D0/rij
1174 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1175             eps0ij=eps(itypi,itypj)
1176             fac=rrij**expon2
1177             e1=fac*fac*aa(itypi,itypj)
1178             e2=fac*bb(itypi,itypj)
1179             evdwij=e1+e2
1180 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1181 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1182 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1183 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1184 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1185 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1186             vdwcompon(itypi,itypj)=vdwcompon(itypi,itypj)+evdwij
1187 #ifdef TSCSC
1188             if (bb(itypi,itypj).gt.0) then
1189                evdw_p=evdw_p+evdwij
1190             else
1191                evdw_m=evdw_m+evdwij
1192             endif
1193 #else
1194             evdw=evdw+evdwij
1195 #endif
1196 C
1197 C Calculate the components of the gradient in DC and X
1198 C
1199             fac=-rrij*(e1+evdwij)
1200             gg(1)=xj*fac
1201             gg(2)=yj*fac
1202             gg(3)=zj*fac
1203 #ifdef TSCSC
1204             if (bb(itypi,itypj).gt.0.0d0) then
1205               do k=1,3
1206                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1207                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1208                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1209                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1210               enddo
1211             else
1212               do k=1,3
1213                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1214                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1215                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1216                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1217               enddo
1218             endif
1219 #else
1220             do k=1,3
1221               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1222               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1223               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1224               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1225             enddo
1226 #endif
1227 cgrad            do k=i,j-1
1228 cgrad              do l=1,3
1229 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1230 cgrad              enddo
1231 cgrad            enddo
1232 C
1233 C 12/1/95, revised on 5/20/97
1234 C
1235 C Calculate the contact function. The ith column of the array JCONT will
1236 C contain the numbers of atoms that make contacts with the atom I (of numbers
1237 C greater than I). The arrays FACONT and GACONT will contain the values of
1238 C the contact function and its derivative.
1239 C
1240 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1241 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1242 C Uncomment next line, if the correlation interactions are contact function only
1243             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1244               rij=dsqrt(rij)
1245               sigij=sigma(itypi,itypj)
1246               r0ij=rs0(itypi,itypj)
1247 C
1248 C Check whether the SC's are not too far to make a contact.
1249 C
1250               rcut=1.5d0*r0ij
1251               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1252 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1253 C
1254               if (fcont.gt.0.0D0) then
1255 C If the SC-SC distance if close to sigma, apply spline.
1256 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1257 cAdam &             fcont1,fprimcont1)
1258 cAdam           fcont1=1.0d0-fcont1
1259 cAdam           if (fcont1.gt.0.0d0) then
1260 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1261 cAdam             fcont=fcont*fcont1
1262 cAdam           endif
1263 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1264 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1265 cga             do k=1,3
1266 cga               gg(k)=gg(k)*eps0ij
1267 cga             enddo
1268 cga             eps0ij=-evdwij*eps0ij
1269 C Uncomment for AL's type of SC correlation interactions.
1270 cadam           eps0ij=-evdwij
1271                 num_conti=num_conti+1
1272                 jcont(num_conti,i)=j
1273                 facont(num_conti,i)=fcont*eps0ij
1274                 fprimcont=eps0ij*fprimcont/rij
1275                 fcont=expon*fcont
1276 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1277 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1278 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1279 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1280                 gacont(1,num_conti,i)=-fprimcont*xj
1281                 gacont(2,num_conti,i)=-fprimcont*yj
1282                 gacont(3,num_conti,i)=-fprimcont*zj
1283 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1284 cd              write (iout,'(2i3,3f10.5)')
1285 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1286               endif
1287             endif
1288           enddo      ! j
1289         enddo        ! iint
1290 C Change 12/1/95
1291         num_cont(i)=num_conti
1292       enddo          ! i
1293       do i=1,nct
1294         do j=1,3
1295           gvdwc(j,i)=expon*gvdwc(j,i)
1296           gvdwx(j,i)=expon*gvdwx(j,i)
1297         enddo
1298       enddo
1299 C******************************************************************************
1300 C
1301 C                              N O T E !!!
1302 C
1303 C To save time, the factor of EXPON has been extracted from ALL components
1304 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1305 C use!
1306 C
1307 C******************************************************************************
1308       return
1309       end
1310 C-----------------------------------------------------------------------------
1311       subroutine eljk(evdw,evdw_p,evdw_m)
1312 C
1313 C This subroutine calculates the interaction energy of nonbonded side chains
1314 C assuming the LJK potential of interaction.
1315 C
1316       implicit real*8 (a-h,o-z)
1317       include 'DIMENSIONS'
1318       include 'COMMON.GEO'
1319       include 'COMMON.VAR'
1320       include 'COMMON.LOCAL'
1321       include 'COMMON.CHAIN'
1322       include 'COMMON.DERIV'
1323       include 'COMMON.INTERACT'
1324       include 'COMMON.IOUNITS'
1325       include 'COMMON.NAMES'
1326       include "COMMON.ECOMPON"
1327       dimension gg(3)
1328       logical scheck
1329 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1330       evdw=0.0D0
1331       do i=iatsc_s,iatsc_e
1332         itypi=itype(i)
1333         itypi1=itype(i+1)
1334         xi=c(1,nres+i)
1335         yi=c(2,nres+i)
1336         zi=c(3,nres+i)
1337         if (itypi.eq.ntyp1) cycle
1338 C
1339 C Calculate SC interaction energy.
1340 C
1341         do iint=1,nint_gr(i)
1342           do j=istart(i,iint),iend(i,iint)
1343             itypj=itype(j)
1344             if (itypj.eq.ntyp1) cycle
1345             xj=c(1,nres+j)-xi
1346             yj=c(2,nres+j)-yi
1347             zj=c(3,nres+j)-zi
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349             fac_augm=rrij**expon
1350             e_augm=augm(itypi,itypj)*fac_augm
1351             r_inv_ij=dsqrt(rrij)
1352             rij=1.0D0/r_inv_ij
1353             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1354             fac=r_shift_inv**expon
1355             e1=fac*fac*aa(itypi,itypj)
1356             e2=fac*bb(itypi,itypj)
1357             evdwij=e_augm+e1+e2
1358 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1359 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1360 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1361 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1362 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1363 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1364 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1365             vdwcompon(itypi,itypj)=vdwcompon(itypi,itypj)+evdwij
1366 #ifdef TSCSC
1367             if (bb(itypi,itypj).gt.0) then
1368                evdw_p=evdw_p+evdwij
1369             else
1370                evdw_m=evdw_m+evdwij
1371             endif
1372 #else
1373             evdw=evdw+evdwij
1374 #endif
1375 C
1376 C Calculate the components of the gradient in DC and X
1377 C
1378             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1379             gg(1)=xj*fac
1380             gg(2)=yj*fac
1381             gg(3)=zj*fac
1382 #ifdef TSCSC
1383             if (bb(itypi,itypj).gt.0.0d0) then
1384               do k=1,3
1385                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1386                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1387                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1388                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1389               enddo
1390             else
1391               do k=1,3
1392                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1393                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1394                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1395                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1396               enddo
1397             endif
1398 #else
1399             do k=1,3
1400               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1401               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1402               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1403               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1404             enddo
1405 #endif
1406 cgrad            do k=i,j-1
1407 cgrad              do l=1,3
1408 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1409 cgrad              enddo
1410 cgrad            enddo
1411           enddo      ! j
1412         enddo        ! iint
1413       enddo          ! i
1414       do i=1,nct
1415         do j=1,3
1416           gvdwc(j,i)=expon*gvdwc(j,i)
1417           gvdwx(j,i)=expon*gvdwx(j,i)
1418         enddo
1419       enddo
1420       return
1421       end
1422 C-----------------------------------------------------------------------------
1423       subroutine ebp(evdw,evdw_p,evdw_m)
1424 C
1425 C This subroutine calculates the interaction energy of nonbonded side chains
1426 C assuming the Berne-Pechukas potential of interaction.
1427 C
1428       implicit real*8 (a-h,o-z)
1429       include 'DIMENSIONS'
1430       include 'COMMON.GEO'
1431       include 'COMMON.VAR'
1432       include 'COMMON.LOCAL'
1433       include 'COMMON.CHAIN'
1434       include 'COMMON.DERIV'
1435       include 'COMMON.NAMES'
1436       include 'COMMON.INTERACT'
1437       include 'COMMON.IOUNITS'
1438       include 'COMMON.CALC'
1439       include "COMMON.ECOMPON"
1440       common /srutu/ icall
1441 c     double precision rrsave(maxdim)
1442       logical lprn
1443       evdw=0.0D0
1444 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1445       evdw=0.0D0
1446 c     if (icall.eq.0) then
1447 c       lprn=.true.
1448 c     else
1449         lprn=.false.
1450 c     endif
1451       ind=0
1452       do i=iatsc_s,iatsc_e
1453         itypi=itype(i)
1454         itypi1=itype(i+1)
1455         xi=c(1,nres+i)
1456         yi=c(2,nres+i)
1457         zi=c(3,nres+i)
1458         if (itypi.eq.ntyp1) cycle
1459         dxi=dc_norm(1,nres+i)
1460         dyi=dc_norm(2,nres+i)
1461         dzi=dc_norm(3,nres+i)
1462 c        dsci_inv=dsc_inv(itypi)
1463         dsci_inv=vbld_inv(i+nres)
1464 C
1465 C Calculate SC interaction energy.
1466 C
1467         do iint=1,nint_gr(i)
1468           do j=istart(i,iint),iend(i,iint)
1469             ind=ind+1
1470             itypj=itype(j)
1471             if (itypj.eq.ntyp1) cycle
1472 c            dscj_inv=dsc_inv(itypj)
1473             dscj_inv=vbld_inv(j+nres)
1474             chi1=chi(itypi,itypj)
1475             chi2=chi(itypj,itypi)
1476             chi12=chi1*chi2
1477             chip1=chip(itypi)
1478             chip2=chip(itypj)
1479             chip12=chip1*chip2
1480             alf1=alp(itypi)
1481             alf2=alp(itypj)
1482             alf12=0.5D0*(alf1+alf2)
1483 C For diagnostics only!!!
1484 c           chi1=0.0D0
1485 c           chi2=0.0D0
1486 c           chi12=0.0D0
1487 c           chip1=0.0D0
1488 c           chip2=0.0D0
1489 c           chip12=0.0D0
1490 c           alf1=0.0D0
1491 c           alf2=0.0D0
1492 c           alf12=0.0D0
1493             xj=c(1,nres+j)-xi
1494             yj=c(2,nres+j)-yi
1495             zj=c(3,nres+j)-zi
1496             dxj=dc_norm(1,nres+j)
1497             dyj=dc_norm(2,nres+j)
1498             dzj=dc_norm(3,nres+j)
1499             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1500 cd          if (icall.eq.0) then
1501 cd            rrsave(ind)=rrij
1502 cd          else
1503 cd            rrij=rrsave(ind)
1504 cd          endif
1505             rij=dsqrt(rrij)
1506 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1507             call sc_angular
1508 C Calculate whole angle-dependent part of epsilon and contributions
1509 C to its derivatives
1510             fac=(rrij*sigsq)**expon2
1511             e1=fac*fac*aa(itypi,itypj)
1512             e2=fac*bb(itypi,itypj)
1513             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1514             eps2der=evdwij*eps3rt
1515             eps3der=evdwij*eps2rt
1516             evdwij=evdwij*eps2rt*eps3rt
1517             vdwcompon(itypi,itypj)=vdwcompon(itypi,itypj)+evdwij
1518 #ifdef TSCSC
1519             if (bb(itypi,itypj).gt.0) then
1520                evdw_p=evdw_p+evdwij
1521             else
1522                evdw_m=evdw_m+evdwij
1523             endif
1524 #else
1525             evdw=evdw+evdwij
1526 #endif
1527             if (lprn) then
1528             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1529             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1530 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1531 cd     &        restyp(itypi),i,restyp(itypj),j,
1532 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1533 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1534 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1535 cd     &        evdwij
1536             endif
1537 C Calculate gradient components.
1538             e1=e1*eps1*eps2rt**2*eps3rt**2
1539             fac=-expon*(e1+evdwij)
1540             sigder=fac/sigsq
1541             fac=rrij*fac
1542 C Calculate radial part of the gradient
1543             gg(1)=xj*fac
1544             gg(2)=yj*fac
1545             gg(3)=zj*fac
1546 C Calculate the angular part of the gradient and sum add the contributions
1547 C to the appropriate components of the Cartesian gradient.
1548 #ifdef TSCSC
1549             if (bb(itypi,itypj).gt.0) then
1550                call sc_grad
1551             else
1552                call sc_grad_T
1553             endif
1554 #else
1555             call sc_grad
1556 #endif
1557           enddo      ! j
1558         enddo        ! iint
1559       enddo          ! i
1560 c     stop
1561       return
1562       end
1563 C-----------------------------------------------------------------------------
1564       subroutine egb(evdw,evdw_p,evdw_m)
1565 C
1566 C This subroutine calculates the interaction energy of nonbonded side chains
1567 C assuming the Gay-Berne potential of interaction.
1568 C
1569       implicit real*8 (a-h,o-z)
1570       include 'DIMENSIONS'
1571       include 'COMMON.GEO'
1572       include 'COMMON.VAR'
1573       include 'COMMON.LOCAL'
1574       include 'COMMON.CHAIN'
1575       include 'COMMON.DERIV'
1576       include 'COMMON.NAMES'
1577       include 'COMMON.INTERACT'
1578       include 'COMMON.IOUNITS'
1579       include 'COMMON.CALC'
1580       include 'COMMON.CONTROL'
1581       include "COMMON.ECOMPON"
1582       logical lprn
1583       evdw=0.0D0
1584 ccccc      energy_dec=.false.
1585 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1586       evdw=0.0D0
1587       evdw_p=0.0D0
1588       evdw_m=0.0D0
1589       lprn=.false.
1590 c     if (icall.eq.0) lprn=.false.
1591       ind=0
1592       do i=iatsc_s,iatsc_e
1593         itypi=itype(i)
1594         if (itypi.eq.ntyp1) cycle
1595         itypi1=itype(i+1)
1596         xi=c(1,nres+i)
1597         yi=c(2,nres+i)
1598         zi=c(3,nres+i)
1599         dxi=dc_norm(1,nres+i)
1600         dyi=dc_norm(2,nres+i)
1601         dzi=dc_norm(3,nres+i)
1602 c        dsci_inv=dsc_inv(itypi)
1603         dsci_inv=vbld_inv(i+nres)
1604 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1605 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1606 C
1607 C Calculate SC interaction energy.
1608 C
1609         do iint=1,nint_gr(i)
1610           do j=istart(i,iint),iend(i,iint)
1611             ind=ind+1
1612             itypj=itype(j)
1613             if (itypj.eq.ntyp1) cycle
1614 c            dscj_inv=dsc_inv(itypj)
1615             dscj_inv=vbld_inv(j+nres)
1616 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1617 c     &       1.0d0/vbld(j+nres)
1618 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1619             sig0ij=sigma(itypi,itypj)
1620             chi1=chi(itypi,itypj)
1621             chi2=chi(itypj,itypi)
1622             chi12=chi1*chi2
1623             chip1=chip(itypi)
1624             chip2=chip(itypj)
1625             chip12=chip1*chip2
1626             alf1=alp(itypi)
1627             alf2=alp(itypj)
1628             alf12=0.5D0*(alf1+alf2)
1629 C For diagnostics only!!!
1630 c           chi1=0.0D0
1631 c           chi2=0.0D0
1632 c           chi12=0.0D0
1633 c           chip1=0.0D0
1634 c           chip2=0.0D0
1635 c           chip12=0.0D0
1636 c           alf1=0.0D0
1637 c           alf2=0.0D0
1638 c           alf12=0.0D0
1639             xj=c(1,nres+j)-xi
1640             yj=c(2,nres+j)-yi
1641             zj=c(3,nres+j)-zi
1642             dxj=dc_norm(1,nres+j)
1643             dyj=dc_norm(2,nres+j)
1644             dzj=dc_norm(3,nres+j)
1645 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1646 c            write (iout,*) "j",j," dc_norm",
1647 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1648             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1649             rij=dsqrt(rrij)
1650 C Calculate angle-dependent terms of energy and contributions to their
1651 C derivatives.
1652             call sc_angular
1653             sigsq=1.0D0/sigsq
1654             sig=sig0ij*dsqrt(sigsq)
1655             rij_shift=1.0D0/rij-sig+sig0ij
1656 c for diagnostics; uncomment
1657 c            rij_shift=1.2*sig0ij
1658 C I hate to put IF's in the loops, but here don't have another choice!!!!
1659             if (rij_shift.le.0.0D0) then
1660               evdw=1.0D20
1661 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1662 cd     &        restyp(itypi),i,restyp(itypj),j,
1663 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1664               return
1665             endif
1666             sigder=-sig*sigsq
1667 c---------------------------------------------------------------
1668             rij_shift=1.0D0/rij_shift
1669             fac=rij_shift**expon
1670             e1=fac*fac*aa(itypi,itypj)
1671             e2=fac*bb(itypi,itypj)
1672             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1673             eps2der=evdwij*eps3rt
1674             eps3der=evdwij*eps2rt
1675 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1676 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1677             evdwij=evdwij*eps2rt*eps3rt
1678             vdwcompon(itypi,itypj)=vdwcompon(itypi,itypj)+evdwij
1679 #ifdef TSCSC
1680             if (bb(itypi,itypj).gt.0) then
1681                evdw_p=evdw_p+evdwij
1682             else
1683                evdw_m=evdw_m+evdwij
1684             endif
1685 #else
1686             evdw=evdw+evdwij
1687 #endif
1688             if (lprn) then
1689             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1690             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1691             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1692      &        restyp(itypi),i,restyp(itypj),j,
1693      &        epsi,sigm,chi1,chi2,chip1,chip2,
1694      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1695      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1696      &        evdwij
1697             endif
1698
1699             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1700      &                        'evdw',i,j,evdwij
1701
1702 C Calculate gradient components.
1703             e1=e1*eps1*eps2rt**2*eps3rt**2
1704             fac=-expon*(e1+evdwij)*rij_shift
1705             sigder=fac*sigder
1706             fac=rij*fac
1707 c            fac=0.0d0
1708 C Calculate the radial part of the gradient
1709             gg(1)=xj*fac
1710             gg(2)=yj*fac
1711             gg(3)=zj*fac
1712 C Calculate angular part of the gradient.
1713 #ifdef TSCSC
1714             if (bb(itypi,itypj).gt.0) then
1715                call sc_grad
1716             else
1717                call sc_grad_T
1718             endif
1719 #else
1720             call sc_grad
1721 #endif
1722           enddo      ! j
1723         enddo        ! iint
1724       enddo          ! i
1725 c      write (iout,*) "Number of loop steps in EGB:",ind
1726 cccc      energy_dec=.false.
1727       return
1728       end
1729 C-----------------------------------------------------------------------------
1730       subroutine egbv(evdw,evdw_p,evdw_m)
1731 C
1732 C This subroutine calculates the interaction energy of nonbonded side chains
1733 C assuming the Gay-Berne-Vorobjev potential of interaction.
1734 C
1735       implicit real*8 (a-h,o-z)
1736       include 'DIMENSIONS'
1737       include 'COMMON.GEO'
1738       include 'COMMON.VAR'
1739       include 'COMMON.LOCAL'
1740       include 'COMMON.CHAIN'
1741       include 'COMMON.DERIV'
1742       include 'COMMON.NAMES'
1743       include 'COMMON.INTERACT'
1744       include 'COMMON.IOUNITS'
1745       include 'COMMON.CALC'
1746       include "COMMON.ECOMPON"
1747       common /srutu/ icall
1748       logical lprn
1749       evdw=0.0D0
1750 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1751       evdw=0.0D0
1752       lprn=.false.
1753 c     if (icall.eq.0) lprn=.true.
1754       ind=0
1755       do i=iatsc_s,iatsc_e
1756         itypi=itype(i)
1757         itypi1=itype(i+1)
1758         xi=c(1,nres+i)
1759         yi=c(2,nres+i)
1760         zi=c(3,nres+i)
1761         if (itypi.eq.ntyp1) cycle
1762         dxi=dc_norm(1,nres+i)
1763         dyi=dc_norm(2,nres+i)
1764         dzi=dc_norm(3,nres+i)
1765 c        dsci_inv=dsc_inv(itypi)
1766         dsci_inv=vbld_inv(i+nres)
1767 C
1768 C Calculate SC interaction energy.
1769 C
1770         do iint=1,nint_gr(i)
1771           do j=istart(i,iint),iend(i,iint)
1772             ind=ind+1
1773             itypj=itype(j)
1774             if (itypj.eq.ntyp1) cycle
1775 c            dscj_inv=dsc_inv(itypj)
1776             dscj_inv=vbld_inv(j+nres)
1777             sig0ij=sigma(itypi,itypj)
1778             r0ij=r0(itypi,itypj)
1779             chi1=chi(itypi,itypj)
1780             chi2=chi(itypj,itypi)
1781             chi12=chi1*chi2
1782             chip1=chip(itypi)
1783             chip2=chip(itypj)
1784             chip12=chip1*chip2
1785             alf1=alp(itypi)
1786             alf2=alp(itypj)
1787             alf12=0.5D0*(alf1+alf2)
1788 C For diagnostics only!!!
1789 c           chi1=0.0D0
1790 c           chi2=0.0D0
1791 c           chi12=0.0D0
1792 c           chip1=0.0D0
1793 c           chip2=0.0D0
1794 c           chip12=0.0D0
1795 c           alf1=0.0D0
1796 c           alf2=0.0D0
1797 c           alf12=0.0D0
1798             xj=c(1,nres+j)-xi
1799             yj=c(2,nres+j)-yi
1800             zj=c(3,nres+j)-zi
1801             dxj=dc_norm(1,nres+j)
1802             dyj=dc_norm(2,nres+j)
1803             dzj=dc_norm(3,nres+j)
1804             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1805             rij=dsqrt(rrij)
1806 C Calculate angle-dependent terms of energy and contributions to their
1807 C derivatives.
1808             call sc_angular
1809             sigsq=1.0D0/sigsq
1810             sig=sig0ij*dsqrt(sigsq)
1811             rij_shift=1.0D0/rij-sig+r0ij
1812 C I hate to put IF's in the loops, but here don't have another choice!!!!
1813             if (rij_shift.le.0.0D0) then
1814               evdw=1.0D20
1815               return
1816             endif
1817             sigder=-sig*sigsq
1818 c---------------------------------------------------------------
1819             rij_shift=1.0D0/rij_shift
1820             fac=rij_shift**expon
1821             e1=fac*fac*aa(itypi,itypj)
1822             e2=fac*bb(itypi,itypj)
1823             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1824             eps2der=evdwij*eps3rt
1825             eps3der=evdwij*eps2rt
1826             fac_augm=rrij**expon
1827             e_augm=augm(itypi,itypj)*fac_augm
1828             evdwij=evdwij*eps2rt*eps3rt
1829             vdwcompon(itypi,itypj)=vdwcompon(itypi,itypj)+evdwij
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                evdw_p=evdw_p+evdwij+e_augm
1833             else
1834                evdw_m=evdw_m+evdwij+e_augm
1835             endif
1836 #else
1837             evdw=evdw+evdwij+e_augm
1838 #endif
1839             if (lprn) then
1840             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1841             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1842             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1843      &        restyp(itypi),i,restyp(itypj),j,
1844      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1845      &        chi1,chi2,chip1,chip2,
1846      &        eps1,eps2rt**2,eps3rt**2,
1847      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1848      &        evdwij+e_augm
1849             endif
1850 C Calculate gradient components.
1851             e1=e1*eps1*eps2rt**2*eps3rt**2
1852             fac=-expon*(e1+evdwij)*rij_shift
1853             sigder=fac*sigder
1854             fac=rij*fac-2*expon*rrij*e_augm
1855 C Calculate the radial part of the gradient
1856             gg(1)=xj*fac
1857             gg(2)=yj*fac
1858             gg(3)=zj*fac
1859 C Calculate angular part of the gradient.
1860 #ifdef TSCSC
1861             if (bb(itypi,itypj).gt.0) then
1862                call sc_grad
1863             else
1864                call sc_grad_T
1865             endif
1866 #else
1867             call sc_grad
1868 #endif
1869           enddo      ! j
1870         enddo        ! iint
1871       enddo          ! i
1872       end
1873 C-----------------------------------------------------------------------------
1874       subroutine sc_angular
1875 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1876 C om12. Called by ebp, egb, and egbv.
1877       implicit none
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       erij(1)=xj*rij
1881       erij(2)=yj*rij
1882       erij(3)=zj*rij
1883       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1884       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1885       om12=dxi*dxj+dyi*dyj+dzi*dzj
1886       chiom12=chi12*om12
1887 C Calculate eps1(om12) and its derivative in om12
1888       faceps1=1.0D0-om12*chiom12
1889       faceps1_inv=1.0D0/faceps1
1890       eps1=dsqrt(faceps1_inv)
1891 C Following variable is eps1*deps1/dom12
1892       eps1_om12=faceps1_inv*chiom12
1893 c diagnostics only
1894 c      faceps1_inv=om12
1895 c      eps1=om12
1896 c      eps1_om12=1.0d0
1897 c      write (iout,*) "om12",om12," eps1",eps1
1898 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1899 C and om12.
1900       om1om2=om1*om2
1901       chiom1=chi1*om1
1902       chiom2=chi2*om2
1903       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1904       sigsq=1.0D0-facsig*faceps1_inv
1905       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1906       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1907       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1908 c diagnostics only
1909 c      sigsq=1.0d0
1910 c      sigsq_om1=0.0d0
1911 c      sigsq_om2=0.0d0
1912 c      sigsq_om12=0.0d0
1913 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1914 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1915 c     &    " eps1",eps1
1916 C Calculate eps2 and its derivatives in om1, om2, and om12.
1917       chipom1=chip1*om1
1918       chipom2=chip2*om2
1919       chipom12=chip12*om12
1920       facp=1.0D0-om12*chipom12
1921       facp_inv=1.0D0/facp
1922       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1923 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1924 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1925 C Following variable is the square root of eps2
1926       eps2rt=1.0D0-facp1*facp_inv
1927 C Following three variables are the derivatives of the square root of eps
1928 C in om1, om2, and om12.
1929       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1930       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1931       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1932 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1933       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1934 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1935 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1936 c     &  " eps2rt_om12",eps2rt_om12
1937 C Calculate whole angle-dependent part of epsilon and contributions
1938 C to its derivatives
1939       return
1940       end
1941
1942 C----------------------------------------------------------------------------
1943       subroutine sc_grad_T
1944       implicit real*8 (a-h,o-z)
1945       include 'DIMENSIONS'
1946       include 'COMMON.CHAIN'
1947       include 'COMMON.DERIV'
1948       include 'COMMON.CALC'
1949       include 'COMMON.IOUNITS'
1950       double precision dcosom1(3),dcosom2(3)
1951       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1952       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1953       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1954      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1955 c diagnostics only
1956 c      eom1=0.0d0
1957 c      eom2=0.0d0
1958 c      eom12=evdwij*eps1_om12
1959 c end diagnostics
1960 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1961 c     &  " sigder",sigder
1962 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1963 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1964       do k=1,3
1965         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1966         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1967       enddo
1968       do k=1,3
1969         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1970       enddo
1971 c      write (iout,*) "gg",(gg(k),k=1,3)
1972       do k=1,3
1973         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1974      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1975      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1976         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1977      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1978      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1979 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1980 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1981 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1982 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1983       enddo
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987 cgrad      do k=i,j-1
1988 cgrad        do l=1,3
1989 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1990 cgrad        enddo
1991 cgrad      enddo
1992       do l=1,3
1993         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1994         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1995       enddo
1996       return
1997       end
1998
1999 C----------------------------------------------------------------------------
2000       subroutine sc_grad
2001       implicit real*8 (a-h,o-z)
2002       include 'DIMENSIONS'
2003       include 'COMMON.CHAIN'
2004       include 'COMMON.DERIV'
2005       include 'COMMON.CALC'
2006       include 'COMMON.IOUNITS'
2007       double precision dcosom1(3),dcosom2(3)
2008       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2009       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2010       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2011      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2012 c diagnostics only
2013 c      eom1=0.0d0
2014 c      eom2=0.0d0
2015 c      eom12=evdwij*eps1_om12
2016 c end diagnostics
2017 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2018 c     &  " sigder",sigder
2019 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2020 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2021       do k=1,3
2022         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2023         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2024       enddo
2025       do k=1,3
2026         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2027       enddo
2028 c      write (iout,*) "gg",(gg(k),k=1,3)
2029       do k=1,3
2030         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2031      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2032      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2033         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2034      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2035      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2036 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2037 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2038 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2039 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2040       enddo
2041 C
2042 C Calculate the components of the gradient in DC and X
2043 C
2044 cgrad      do k=i,j-1
2045 cgrad        do l=1,3
2046 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2047 cgrad        enddo
2048 cgrad      enddo
2049       do l=1,3
2050         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2051         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2052       enddo
2053       return
2054       end
2055 C-----------------------------------------------------------------------
2056       subroutine e_softsphere(evdw)
2057 C
2058 C This subroutine calculates the interaction energy of nonbonded side chains
2059 C assuming the LJ potential of interaction.
2060 C
2061       implicit real*8 (a-h,o-z)
2062       include 'DIMENSIONS'
2063       parameter (accur=1.0d-10)
2064       include 'COMMON.GEO'
2065       include 'COMMON.VAR'
2066       include 'COMMON.LOCAL'
2067       include 'COMMON.CHAIN'
2068       include 'COMMON.DERIV'
2069       include 'COMMON.INTERACT'
2070       include 'COMMON.TORSION'
2071       include 'COMMON.SBRIDGE'
2072       include 'COMMON.NAMES'
2073       include 'COMMON.IOUNITS'
2074       include 'COMMON.CONTACTS'
2075       dimension gg(3)
2076 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2077       evdw=0.0D0
2078       do i=iatsc_s,iatsc_e
2079         itypi=itype(i)
2080         itypi1=itype(i+1)
2081         xi=c(1,nres+i)
2082         yi=c(2,nres+i)
2083         zi=c(3,nres+i)
2084         if (itypi.eq.ntyp1) cycle
2085 C
2086 C Calculate SC interaction energy.
2087 C
2088         do iint=1,nint_gr(i)
2089 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2090 cd   &                  'iend=',iend(i,iint)
2091           do j=istart(i,iint),iend(i,iint)
2092             if (itypj.eq.ntyp1) cycle
2093             itypj=itype(j)
2094             xj=c(1,nres+j)-xi
2095             yj=c(2,nres+j)-yi
2096             zj=c(3,nres+j)-zi
2097             rij=xj*xj+yj*yj+zj*zj
2098 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2099             r0ij=r0(itypi,itypj)
2100             r0ijsq=r0ij*r0ij
2101 c            print *,i,j,r0ij,dsqrt(rij)
2102             if (rij.lt.r0ijsq) then
2103               evdwij=0.25d0*(rij-r0ijsq)**2
2104               fac=rij-r0ijsq
2105             else
2106               evdwij=0.0d0
2107               fac=0.0d0
2108             endif
2109             evdw=evdw+evdwij
2110 C
2111 C Calculate the components of the gradient in DC and X
2112 C
2113             gg(1)=xj*fac
2114             gg(2)=yj*fac
2115             gg(3)=zj*fac
2116             do k=1,3
2117               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2118               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2119               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2120               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2121             enddo
2122 cgrad            do k=i,j-1
2123 cgrad              do l=1,3
2124 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2125 cgrad              enddo
2126 cgrad            enddo
2127           enddo ! j
2128         enddo ! iint
2129       enddo ! i
2130       return
2131       end
2132 C--------------------------------------------------------------------------
2133       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2134      &              eello_turn4)
2135 C
2136 C Soft-sphere potential of p-p interaction
2137 C
2138       implicit real*8 (a-h,o-z)
2139       include 'DIMENSIONS'
2140       include 'COMMON.CONTROL'
2141       include 'COMMON.IOUNITS'
2142       include 'COMMON.GEO'
2143       include 'COMMON.VAR'
2144       include 'COMMON.LOCAL'
2145       include 'COMMON.CHAIN'
2146       include 'COMMON.DERIV'
2147       include 'COMMON.INTERACT'
2148       include 'COMMON.CONTACTS'
2149       include 'COMMON.TORSION'
2150       include 'COMMON.VECTORS'
2151       include 'COMMON.FFIELD'
2152       dimension ggg(3)
2153 cd      write(iout,*) 'In EELEC_soft_sphere'
2154       ees=0.0D0
2155       evdw1=0.0D0
2156       eel_loc=0.0d0
2157       eello_turn3=0.0d0
2158       eello_turn4=0.0d0
2159       ind=0
2160       do i=iatel_s,iatel_e
2161         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2162         dxi=dc(1,i)
2163         dyi=dc(2,i)
2164         dzi=dc(3,i)
2165         xmedi=c(1,i)+0.5d0*dxi
2166         ymedi=c(2,i)+0.5d0*dyi
2167         zmedi=c(3,i)+0.5d0*dzi
2168         num_conti=0
2169 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2170         do j=ielstart(i),ielend(i)
2171           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2172           ind=ind+1
2173         if (c(1,j).eq.1.0d10 .or. c(1,j+1).eq.1.0d10 .or.
2174      &      c(2,j).eq.1.0d10 .or. c(2,j+1).eq.1.0d10 .or.
2175      &      c(3,j).eq.1.0d10 .or. c(3,j+1).eq.1.0d10) cycle
2176           iteli=itel(i)
2177           itelj=itel(j)
2178           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2179           r0ij=rpp(iteli,itelj)
2180           r0ijsq=r0ij*r0ij
2181           dxj=dc(1,j)
2182           dyj=dc(2,j)
2183           dzj=dc(3,j)
2184           xj=c(1,j)+0.5D0*dxj-xmedi
2185           yj=c(2,j)+0.5D0*dyj-ymedi
2186           zj=c(3,j)+0.5D0*dzj-zmedi
2187           rij=xj*xj+yj*yj+zj*zj
2188           if (rij.lt.r0ijsq) then
2189             evdw1ij=0.25d0*(rij-r0ijsq)**2
2190             fac=rij-r0ijsq
2191           else
2192             evdw1ij=0.0d0
2193             fac=0.0d0
2194           endif
2195           evdw1=evdw1+evdw1ij
2196 C
2197 C Calculate contributions to the Cartesian gradient.
2198 C
2199           ggg(1)=fac*xj
2200           ggg(2)=fac*yj
2201           ggg(3)=fac*zj
2202           do k=1,3
2203             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2204             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2205           enddo
2206 *
2207 * Loop over residues i+1 thru j-1.
2208 *
2209 cgrad          do k=i+1,j-1
2210 cgrad            do l=1,3
2211 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2212 cgrad            enddo
2213 cgrad          enddo
2214         enddo ! j
2215       enddo   ! i
2216 cgrad      do i=nnt,nct-1
2217 cgrad        do k=1,3
2218 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2219 cgrad        enddo
2220 cgrad        do j=i+1,nct-1
2221 cgrad          do k=1,3
2222 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2223 cgrad          enddo
2224 cgrad        enddo
2225 cgrad      enddo
2226       return
2227       end
2228 c------------------------------------------------------------------------------
2229       subroutine vec_and_deriv
2230       implicit real*8 (a-h,o-z)
2231       include 'DIMENSIONS'
2232 #ifdef MPI
2233       include 'mpif.h'
2234 #endif
2235       include 'COMMON.IOUNITS'
2236       include 'COMMON.GEO'
2237       include 'COMMON.VAR'
2238       include 'COMMON.LOCAL'
2239       include 'COMMON.CHAIN'
2240       include 'COMMON.VECTORS'
2241       include 'COMMON.SETUP'
2242       include 'COMMON.TIME1'
2243       include 'COMMON.INTERACT'
2244       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2245 C Compute the local reference systems. For reference system (i), the
2246 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2247 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2248 #ifdef PARVEC
2249       do i=ivec_start,ivec_end
2250 #else
2251       do i=1,nres-1
2252 #endif
2253           if (itype(i).eq.ntyp1 .or.
2254      &        itype(i+1).eq.ntyp1) cycle
2255           if (i.eq.nres-1) then
2256 C Case of the last full residue
2257 C Compute the Z-axis
2258             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2259             costh=dcos(pi-theta(nres))
2260             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2261             do k=1,3
2262               uz(k,i)=fac*uz(k,i)
2263             enddo
2264 C Compute the derivatives of uz
2265             uzder(1,1,1)= 0.0d0
2266             uzder(2,1,1)=-dc_norm(3,i-1)
2267             uzder(3,1,1)= dc_norm(2,i-1)
2268             uzder(1,2,1)= dc_norm(3,i-1)
2269             uzder(2,2,1)= 0.0d0
2270             uzder(3,2,1)=-dc_norm(1,i-1)
2271             uzder(1,3,1)=-dc_norm(2,i-1)
2272             uzder(2,3,1)= dc_norm(1,i-1)
2273             uzder(3,3,1)= 0.0d0
2274             uzder(1,1,2)= 0.0d0
2275             uzder(2,1,2)= dc_norm(3,i)
2276             uzder(3,1,2)=-dc_norm(2,i)
2277             uzder(1,2,2)=-dc_norm(3,i)
2278             uzder(2,2,2)= 0.0d0
2279             uzder(3,2,2)= dc_norm(1,i)
2280             uzder(1,3,2)= dc_norm(2,i)
2281             uzder(2,3,2)=-dc_norm(1,i)
2282             uzder(3,3,2)= 0.0d0
2283 C Compute the Y-axis
2284             facy=fac
2285             do k=1,3
2286               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2287             enddo
2288 C Compute the derivatives of uy
2289             do j=1,3
2290               do k=1,3
2291                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2292      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2293                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2294               enddo
2295               uyder(j,j,1)=uyder(j,j,1)-costh
2296               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2297             enddo
2298             do j=1,2
2299               do k=1,3
2300                 do l=1,3
2301                   uygrad(l,k,j,i)=uyder(l,k,j)
2302                   uzgrad(l,k,j,i)=uzder(l,k,j)
2303                 enddo
2304               enddo
2305             enddo
2306             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2307             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2308             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2309             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2310           else
2311 C Other residues
2312 C Compute the Z-axis
2313             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2314             costh=dcos(pi-theta(i+2))
2315             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2316             do k=1,3
2317               uz(k,i)=fac*uz(k,i)
2318             enddo
2319 C Compute the derivatives of uz
2320             uzder(1,1,1)= 0.0d0
2321             uzder(2,1,1)=-dc_norm(3,i+1)
2322             uzder(3,1,1)= dc_norm(2,i+1)
2323             uzder(1,2,1)= dc_norm(3,i+1)
2324             uzder(2,2,1)= 0.0d0
2325             uzder(3,2,1)=-dc_norm(1,i+1)
2326             uzder(1,3,1)=-dc_norm(2,i+1)
2327             uzder(2,3,1)= dc_norm(1,i+1)
2328             uzder(3,3,1)= 0.0d0
2329             uzder(1,1,2)= 0.0d0
2330             uzder(2,1,2)= dc_norm(3,i)
2331             uzder(3,1,2)=-dc_norm(2,i)
2332             uzder(1,2,2)=-dc_norm(3,i)
2333             uzder(2,2,2)= 0.0d0
2334             uzder(3,2,2)= dc_norm(1,i)
2335             uzder(1,3,2)= dc_norm(2,i)
2336             uzder(2,3,2)=-dc_norm(1,i)
2337             uzder(3,3,2)= 0.0d0
2338 C Compute the Y-axis
2339             facy=fac
2340             do k=1,3
2341               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2342             enddo
2343 C Compute the derivatives of uy
2344             do j=1,3
2345               do k=1,3
2346                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2347      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2348                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2349               enddo
2350               uyder(j,j,1)=uyder(j,j,1)-costh
2351               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2352             enddo
2353             do j=1,2
2354               do k=1,3
2355                 do l=1,3
2356                   uygrad(l,k,j,i)=uyder(l,k,j)
2357                   uzgrad(l,k,j,i)=uzder(l,k,j)
2358                 enddo
2359               enddo
2360             enddo
2361             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2362             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2363             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2364             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2365           endif
2366       enddo
2367       do i=1,nres-1
2368         vbld_inv_temp(1)=vbld_inv(i+1)
2369         if (i.lt.nres-1) then
2370           vbld_inv_temp(2)=vbld_inv(i+2)
2371           else
2372           vbld_inv_temp(2)=vbld_inv(i)
2373           endif
2374         do j=1,2
2375           do k=1,3
2376             do l=1,3
2377               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2378               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2379             enddo
2380           enddo
2381         enddo
2382       enddo
2383 #if defined(PARVEC) && defined(MPI)
2384       if (nfgtasks1.gt.1) then
2385         time00=MPI_Wtime()
2386 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2387 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2388 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2389         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2390      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2391      &   FG_COMM1,IERR)
2392         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2393      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2394      &   FG_COMM1,IERR)
2395         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2396      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2397      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2398         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2399      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2400      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2401         time_gather=time_gather+MPI_Wtime()-time00
2402       endif
2403 c      if (fg_rank.eq.0) then
2404 c        write (iout,*) "Arrays UY and UZ"
2405 c        do i=1,nres-1
2406 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2407 c     &     (uz(k,i),k=1,3)
2408 c        enddo
2409 c      endif
2410 #endif
2411       return
2412       end
2413 C-----------------------------------------------------------------------------
2414       subroutine check_vecgrad
2415       implicit real*8 (a-h,o-z)
2416       include 'DIMENSIONS'
2417       include 'COMMON.IOUNITS'
2418       include 'COMMON.GEO'
2419       include 'COMMON.VAR'
2420       include 'COMMON.LOCAL'
2421       include 'COMMON.CHAIN'
2422       include 'COMMON.VECTORS'
2423       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2424       dimension uyt(3,maxres),uzt(3,maxres)
2425       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2426       double precision delta /1.0d-7/
2427       call vec_and_deriv
2428 cd      do i=1,nres
2429 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2430 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2431 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2432 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2433 cd     &     (dc_norm(if90,i),if90=1,3)
2434 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2435 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2436 cd          write(iout,'(a)')
2437 cd      enddo
2438       do i=1,nres
2439         do j=1,2
2440           do k=1,3
2441             do l=1,3
2442               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2443               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2444             enddo
2445           enddo
2446         enddo
2447       enddo
2448       call vec_and_deriv
2449       do i=1,nres
2450         do j=1,3
2451           uyt(j,i)=uy(j,i)
2452           uzt(j,i)=uz(j,i)
2453         enddo
2454       enddo
2455       do i=1,nres
2456 cd        write (iout,*) 'i=',i
2457         do k=1,3
2458           erij(k)=dc_norm(k,i)
2459         enddo
2460         do j=1,3
2461           do k=1,3
2462             dc_norm(k,i)=erij(k)
2463           enddo
2464           dc_norm(j,i)=dc_norm(j,i)+delta
2465 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2466 c          do k=1,3
2467 c            dc_norm(k,i)=dc_norm(k,i)/fac
2468 c          enddo
2469 c          write (iout,*) (dc_norm(k,i),k=1,3)
2470 c          write (iout,*) (erij(k),k=1,3)
2471           call vec_and_deriv
2472           do k=1,3
2473             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2474             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2475             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2476             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2477           enddo
2478 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2479 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2480 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2481         enddo
2482         do k=1,3
2483           dc_norm(k,i)=erij(k)
2484         enddo
2485 cd        do k=1,3
2486 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2487 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2488 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2489 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2490 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2491 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2492 cd          write (iout,'(a)')
2493 cd        enddo
2494       enddo
2495       return
2496       end
2497 C--------------------------------------------------------------------------
2498       subroutine set_matrices
2499       implicit real*8 (a-h,o-z)
2500       include 'DIMENSIONS'
2501 #ifdef MPI
2502       include "mpif.h"
2503       include "COMMON.SETUP"
2504       integer IERR
2505       integer status(MPI_STATUS_SIZE)
2506 #endif
2507       include 'COMMON.IOUNITS'
2508       include 'COMMON.GEO'
2509       include 'COMMON.VAR'
2510       include 'COMMON.LOCAL'
2511       include 'COMMON.CHAIN'
2512       include 'COMMON.DERIV'
2513       include 'COMMON.INTERACT'
2514       include 'COMMON.CONTACTS'
2515       include 'COMMON.TORSION'
2516       include 'COMMON.VECTORS'
2517       include 'COMMON.FFIELD'
2518       double precision auxvec(2),auxmat(2,2)
2519 C
2520 C Compute the virtual-bond-torsional-angle dependent quantities needed
2521 C to calculate the el-loc multibody terms of various order.
2522 C
2523 #ifdef PARMAT
2524       do i=ivec_start+2,ivec_end+2
2525 #else
2526       do i=3,nres+1
2527 #endif
2528         if (itype(i-1).eq.ntyp1 .or.
2529      &      itype(i-2).eq.ntyp1) cycle
2530         if (i .lt. nres+1) then
2531           sin1=dsin(phi(i))
2532           cos1=dcos(phi(i))
2533           sintab(i-2)=sin1
2534           costab(i-2)=cos1
2535           obrot(1,i-2)=cos1
2536           obrot(2,i-2)=sin1
2537           sin2=dsin(2*phi(i))
2538           cos2=dcos(2*phi(i))
2539           sintab2(i-2)=sin2
2540           costab2(i-2)=cos2
2541           obrot2(1,i-2)=cos2
2542           obrot2(2,i-2)=sin2
2543           Ug(1,1,i-2)=-cos1
2544           Ug(1,2,i-2)=-sin1
2545           Ug(2,1,i-2)=-sin1
2546           Ug(2,2,i-2)= cos1
2547           Ug2(1,1,i-2)=-cos2
2548           Ug2(1,2,i-2)=-sin2
2549           Ug2(2,1,i-2)=-sin2
2550           Ug2(2,2,i-2)= cos2
2551         else
2552           costab(i-2)=1.0d0
2553           sintab(i-2)=0.0d0
2554           obrot(1,i-2)=1.0d0
2555           obrot(2,i-2)=0.0d0
2556           obrot2(1,i-2)=0.0d0
2557           obrot2(2,i-2)=0.0d0
2558           Ug(1,1,i-2)=1.0d0
2559           Ug(1,2,i-2)=0.0d0
2560           Ug(2,1,i-2)=0.0d0
2561           Ug(2,2,i-2)=1.0d0
2562           Ug2(1,1,i-2)=0.0d0
2563           Ug2(1,2,i-2)=0.0d0
2564           Ug2(2,1,i-2)=0.0d0
2565           Ug2(2,2,i-2)=0.0d0
2566         endif
2567         if (i .gt. 3 .and. i .lt. nres+1) then
2568           obrot_der(1,i-2)=-sin1
2569           obrot_der(2,i-2)= cos1
2570           Ugder(1,1,i-2)= sin1
2571           Ugder(1,2,i-2)=-cos1
2572           Ugder(2,1,i-2)=-cos1
2573           Ugder(2,2,i-2)=-sin1
2574           dwacos2=cos2+cos2
2575           dwasin2=sin2+sin2
2576           obrot2_der(1,i-2)=-dwasin2
2577           obrot2_der(2,i-2)= dwacos2
2578           Ug2der(1,1,i-2)= dwasin2
2579           Ug2der(1,2,i-2)=-dwacos2
2580           Ug2der(2,1,i-2)=-dwacos2
2581           Ug2der(2,2,i-2)=-dwasin2
2582         else
2583           obrot_der(1,i-2)=0.0d0
2584           obrot_der(2,i-2)=0.0d0
2585           Ugder(1,1,i-2)=0.0d0
2586           Ugder(1,2,i-2)=0.0d0
2587           Ugder(2,1,i-2)=0.0d0
2588           Ugder(2,2,i-2)=0.0d0
2589           obrot2_der(1,i-2)=0.0d0
2590           obrot2_der(2,i-2)=0.0d0
2591           Ug2der(1,1,i-2)=0.0d0
2592           Ug2der(1,2,i-2)=0.0d0
2593           Ug2der(2,1,i-2)=0.0d0
2594           Ug2der(2,2,i-2)=0.0d0
2595         endif
2596 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2597         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2598           iti = itortyp(itype(i-2))
2599         else
2600           iti=ntortyp+1
2601         endif
2602 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2603         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2604           iti1 = itortyp(itype(i-1))
2605         else
2606           iti1=ntortyp+1
2607         endif
2608 cd        write (iout,*) '*******i',i,' iti1',iti
2609 cd        write (iout,*) 'b1',b1(:,iti)
2610 cd        write (iout,*) 'b2',b2(:,iti)
2611 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2612 c        if (i .gt. iatel_s+2) then
2613         if (i .gt. nnt+2) then
2614           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2615           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2616           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2617      &    then
2618           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2619           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2620           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2621           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2622           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2623           endif
2624         else
2625           do k=1,2
2626             Ub2(k,i-2)=0.0d0
2627             Ctobr(k,i-2)=0.0d0
2628             Dtobr2(k,i-2)=0.0d0
2629             do l=1,2
2630               EUg(l,k,i-2)=0.0d0
2631               CUg(l,k,i-2)=0.0d0
2632               DUg(l,k,i-2)=0.0d0
2633               DtUg2(l,k,i-2)=0.0d0
2634             enddo
2635           enddo
2636         endif
2637         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2638         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2639         do k=1,2
2640           muder(k,i-2)=Ub2der(k,i-2)
2641         enddo
2642 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2643         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2644           iti1 = itortyp(itype(i-1))
2645         else
2646           iti1=ntortyp+1
2647         endif
2648         do k=1,2
2649           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2650         enddo
2651 cd        write (iout,*) 'mu ',mu(:,i-2)
2652 cd        write (iout,*) 'mu1',mu1(:,i-2)
2653 cd        write (iout,*) 'mu2',mu2(:,i-2)
2654         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2655      &  then
2656         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2657         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2658         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2659         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2660         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2661 C Vectors and matrices dependent on a single virtual-bond dihedral.
2662         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2663         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2664         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2665         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2666         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2667         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2668         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2669         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2670         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2671         endif
2672       enddo
2673 C Matrices dependent on two consecutive virtual-bond dihedrals.
2674 C The order of matrices is from left to right.
2675       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2676      &then
2677 c      do i=max0(ivec_start,2),ivec_end
2678       do i=2,nres-1
2679         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2680         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2681         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2682         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2683         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2684         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2685         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2686         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2687       enddo
2688       endif
2689 #if defined(MPI) && defined(PARMAT)
2690 #ifdef DEBUG
2691 c      if (fg_rank.eq.0) then
2692         write (iout,*) "Arrays UG and UGDER before GATHER"
2693         do i=1,nres-1
2694           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2695      &     ((ug(l,k,i),l=1,2),k=1,2),
2696      &     ((ugder(l,k,i),l=1,2),k=1,2)
2697         enddo
2698         write (iout,*) "Arrays UG2 and UG2DER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2701      &     ((ug2(l,k,i),l=1,2),k=1,2),
2702      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2707      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2708      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2713      &     costab(i),sintab(i),costab2(i),sintab2(i)
2714         enddo
2715         write (iout,*) "Array MUDER"
2716         do i=1,nres-1
2717           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2718         enddo
2719 c      endif
2720 #endif
2721       if (nfgtasks.gt.1) then
2722         time00=MPI_Wtime()
2723 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2724 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2725 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2726 #ifdef MATGATHER
2727         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2746      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2747      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2748         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2749      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2750      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2758      &  then
2759         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2775      &   ivec_count(fg_rank1),
2776      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2800      &   ivec_count(fg_rank1),
2801      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2802      &   FG_COMM1,IERR)
2803         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2804      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2807      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2816      &   ivec_count(fg_rank1),
2817      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2818      &   FG_COMM1,IERR)
2819         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2820      &   ivec_count(fg_rank1),
2821      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2822      &   FG_COMM1,IERR)
2823         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2824      &   ivec_count(fg_rank1),
2825      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2826      &   MPI_MAT2,FG_COMM1,IERR)
2827         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2828      &   ivec_count(fg_rank1),
2829      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2830      &   MPI_MAT2,FG_COMM1,IERR)
2831         endif
2832 #else
2833 c Passes matrix info through the ring
2834       isend=fg_rank1
2835       irecv=fg_rank1-1
2836       if (irecv.lt.0) irecv=nfgtasks1-1
2837       iprev=irecv
2838       inext=fg_rank1+1
2839       if (inext.ge.nfgtasks1) inext=0
2840       do i=1,nfgtasks1-1
2841 c        write (iout,*) "isend",isend," irecv",irecv
2842 c        call flush(iout)
2843         lensend=lentyp(isend)
2844         lenrecv=lentyp(irecv)
2845 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2846 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2847 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2848 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2849 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2850 c        write (iout,*) "Gather ROTAT1"
2851 c        call flush(iout)
2852 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2853 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2854 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2855 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather ROTAT2"
2857 c        call flush(iout)
2858         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2859      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2860      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2861      &   iprev,4400+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather ROTAT_OLD"
2863 c        call flush(iout)
2864         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2865      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2866      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2867      &   iprev,5500+irecv,FG_COMM,status,IERR)
2868 c        write (iout,*) "Gather PRECOMP11"
2869 c        call flush(iout)
2870         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2871      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2872      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2873      &   iprev,6600+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP12"
2875 c        call flush(iout)
2876         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2877      &  then
2878         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2879      &   MPI_ROTAT2(lensend),inext,7700+isend,
2880      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2881      &   iprev,7700+irecv,FG_COMM,status,IERR)
2882 c        write (iout,*) "Gather PRECOMP21"
2883 c        call flush(iout)
2884         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2885      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2886      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2887      &   iprev,8800+irecv,FG_COMM,status,IERR)
2888 c        write (iout,*) "Gather PRECOMP22"
2889 c        call flush(iout)
2890         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2891      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2892      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2893      &   MPI_PRECOMP23(lenrecv),
2894      &   iprev,9900+irecv,FG_COMM,status,IERR)
2895 c        write (iout,*) "Gather PRECOMP23"
2896 c        call flush(iout)
2897         endif
2898         isend=irecv
2899         irecv=irecv-1
2900         if (irecv.lt.0) irecv=nfgtasks1-1
2901       enddo
2902 #endif
2903         time_gather=time_gather+MPI_Wtime()-time00
2904       endif
2905 #ifdef DEBUG
2906 c      if (fg_rank.eq.0) then
2907         write (iout,*) "Arrays UG and UGDER"
2908         do i=1,nres-1
2909           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2910      &     ((ug(l,k,i),l=1,2),k=1,2),
2911      &     ((ugder(l,k,i),l=1,2),k=1,2)
2912         enddo
2913         write (iout,*) "Arrays UG2 and UG2DER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2916      &     ((ug2(l,k,i),l=1,2),k=1,2),
2917      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2922      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2923      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2928      &     costab(i),sintab(i),costab2(i),sintab2(i)
2929         enddo
2930         write (iout,*) "Array MUDER"
2931         do i=1,nres-1
2932           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2933         enddo
2934 c      endif
2935 #endif
2936 #endif
2937 cd      do i=1,nres
2938 cd        iti = itortyp(itype(i))
2939 cd        write (iout,*) i
2940 cd        do j=1,2
2941 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2942 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2943 cd        enddo
2944 cd      enddo
2945       return
2946       end
2947 C--------------------------------------------------------------------------
2948       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2949 C
2950 C This subroutine calculates the average interaction energy and its gradient
2951 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2952 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2953 C The potential depends both on the distance of peptide-group centers and on
2954 C the orientation of the CA-CA virtual bonds.
2955 C
2956       implicit real*8 (a-h,o-z)
2957 #ifdef MPI
2958       include 'mpif.h'
2959 #endif
2960       include 'DIMENSIONS'
2961       include 'COMMON.CONTROL'
2962       include 'COMMON.SETUP'
2963       include 'COMMON.IOUNITS'
2964       include 'COMMON.GEO'
2965       include 'COMMON.VAR'
2966       include 'COMMON.LOCAL'
2967       include 'COMMON.CHAIN'
2968       include 'COMMON.DERIV'
2969       include 'COMMON.INTERACT'
2970       include 'COMMON.CONTACTS'
2971       include 'COMMON.TORSION'
2972       include 'COMMON.VECTORS'
2973       include 'COMMON.FFIELD'
2974       include 'COMMON.TIME1'
2975       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2976      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2977       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2978      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2979       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2980      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2981      &    num_conti,j1,j2
2982 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2983 #ifdef MOMENT
2984       double precision scal_el /1.0d0/
2985 #else
2986       double precision scal_el /0.5d0/
2987 #endif
2988 C 12/13/98
2989 C 13-go grudnia roku pamietnego...
2990       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2991      &                   0.0d0,1.0d0,0.0d0,
2992      &                   0.0d0,0.0d0,1.0d0/
2993 cd      write(iout,*) 'In EELEC'
2994 cd      do i=1,nloctyp
2995 cd        write(iout,*) 'Type',i
2996 cd        write(iout,*) 'B1',B1(:,i)
2997 cd        write(iout,*) 'B2',B2(:,i)
2998 cd        write(iout,*) 'CC',CC(:,:,i)
2999 cd        write(iout,*) 'DD',DD(:,:,i)
3000 cd        write(iout,*) 'EE',EE(:,:,i)
3001 cd      enddo
3002 cd      call check_vecgrad
3003 cd      stop
3004       if (icheckgrad.eq.1) then
3005         do i=1,nres-1
3006           if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp+1)  cycle
3007           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3008           do k=1,3
3009             dc_norm(k,i)=dc(k,i)*fac
3010           enddo
3011 c          write (iout,*) 'i',i,' fac',fac
3012         enddo
3013       endif
3014       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3015      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3016      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3017 c        call vec_and_deriv
3018 #ifdef TIMING
3019         time01=MPI_Wtime()
3020 #endif
3021         call set_matrices
3022 #ifdef TIMING
3023         time_mat=time_mat+MPI_Wtime()-time01
3024 #endif
3025       endif
3026 cd      do i=1,nres-1
3027 cd        write (iout,*) 'i=',i
3028 cd        do k=1,3
3029 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3030 cd        enddo
3031 cd        do k=1,3
3032 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3033 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3034 cd        enddo
3035 cd      enddo
3036       t_eelecij=0.0d0
3037       ees=0.0D0
3038       evdw1=0.0D0
3039       eel_loc=0.0d0
3040       eello_turn3=0.0d0
3041       eello_turn4=0.0d0
3042       ind=0
3043       do i=1,nres
3044         num_cont_hb(i)=0
3045       enddo
3046 cd      print '(a)','Enter EELEC'
3047 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3048       do i=1,nres
3049         gel_loc_loc(i)=0.0d0
3050         gcorr_loc(i)=0.0d0
3051       enddo
3052 c
3053 c
3054 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3055 C
3056 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3057 C
3058       do i=iturn3_start,iturn3_end
3059         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 .or.
3060      &      itype(i+2).eq.ntyp1 .or. itype(i+3).eq. ntyp1) cycle
3061         dxi=dc(1,i)
3062         dyi=dc(2,i)
3063         dzi=dc(3,i)
3064         dx_normi=dc_norm(1,i)
3065         dy_normi=dc_norm(2,i)
3066         dz_normi=dc_norm(3,i)
3067         xmedi=c(1,i)+0.5d0*dxi
3068         ymedi=c(2,i)+0.5d0*dyi
3069         zmedi=c(3,i)+0.5d0*dzi
3070         num_conti=0
3071         call eelecij(i,i+2,ees,evdw1,eel_loc)
3072         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3073         num_cont_hb(i)=num_conti
3074       enddo
3075       do i=iturn4_start,iturn4_end
3076         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 .or.
3077      &      itype(i+2).eq.ntyp1 .or. itype(i+3).eq. ntyp1 .or.
3078      &      itype(i+4).eq.ntyp1) cycle
3079         dxi=dc(1,i)
3080         dyi=dc(2,i)
3081         dzi=dc(3,i)
3082         dx_normi=dc_norm(1,i)
3083         dy_normi=dc_norm(2,i)
3084         dz_normi=dc_norm(3,i)
3085         xmedi=c(1,i)+0.5d0*dxi
3086         ymedi=c(2,i)+0.5d0*dyi
3087         zmedi=c(3,i)+0.5d0*dzi
3088         num_conti=num_cont_hb(i)
3089         call eelecij(i,i+3,ees,evdw1,eel_loc)
3090         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3091         num_cont_hb(i)=num_conti
3092       enddo   ! i
3093 c
3094 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3095 c
3096       do i=iatel_s,iatel_e
3097         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3098         dxi=dc(1,i)
3099         dyi=dc(2,i)
3100         dzi=dc(3,i)
3101         dx_normi=dc_norm(1,i)
3102         dy_normi=dc_norm(2,i)
3103         dz_normi=dc_norm(3,i)
3104         xmedi=c(1,i)+0.5d0*dxi
3105         ymedi=c(2,i)+0.5d0*dyi
3106         zmedi=c(3,i)+0.5d0*dzi
3107 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3108         num_conti=num_cont_hb(i)
3109         do j=ielstart(i),ielend(i)
3110           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
3111           call eelecij(i,j,ees,evdw1,eel_loc)
3112         enddo ! j
3113         num_cont_hb(i)=num_conti
3114       enddo   ! i
3115 c      write (iout,*) "Number of loop steps in EELEC:",ind
3116 cd      do i=1,nres
3117 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3118 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3119 cd      enddo
3120 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3121 ccc      eel_loc=eel_loc+eello_turn3
3122 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3123       return
3124       end
3125 C-------------------------------------------------------------------------------
3126       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3127       implicit real*8 (a-h,o-z)
3128       include 'DIMENSIONS'
3129 #ifdef MPI
3130       include "mpif.h"
3131 #endif
3132       include 'COMMON.CONTROL'
3133       include 'COMMON.IOUNITS'
3134       include 'COMMON.GEO'
3135       include 'COMMON.VAR'
3136       include 'COMMON.LOCAL'
3137       include 'COMMON.CHAIN'
3138       include 'COMMON.DERIV'
3139       include 'COMMON.INTERACT'
3140       include 'COMMON.CONTACTS'
3141       include 'COMMON.TORSION'
3142       include 'COMMON.VECTORS'
3143       include 'COMMON.FFIELD'
3144       include 'COMMON.TIME1'
3145       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3146      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3147       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3148      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3149       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3150      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3151      &    num_conti,j1,j2
3152 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3153 #ifdef MOMENT
3154       double precision scal_el /1.0d0/
3155 #else
3156       double precision scal_el /0.5d0/
3157 #endif
3158 C 12/13/98
3159 C 13-go grudnia roku pamietnego...
3160       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3161      &                   0.0d0,1.0d0,0.0d0,
3162      &                   0.0d0,0.0d0,1.0d0/
3163 c          time00=MPI_Wtime()
3164 cd      write (iout,*) "eelecij",i,j
3165 c          ind=ind+1
3166           iteli=itel(i)
3167           itelj=itel(j)
3168           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3169           aaa=app(iteli,itelj)
3170           bbb=bpp(iteli,itelj)
3171           ael6i=ael6(iteli,itelj)
3172           ael3i=ael3(iteli,itelj)
3173           dxj=dc(1,j)
3174           dyj=dc(2,j)
3175           dzj=dc(3,j)
3176           dx_normj=dc_norm(1,j)
3177           dy_normj=dc_norm(2,j)
3178           dz_normj=dc_norm(3,j)
3179           xj=c(1,j)+0.5D0*dxj-xmedi
3180           yj=c(2,j)+0.5D0*dyj-ymedi
3181           zj=c(3,j)+0.5D0*dzj-zmedi
3182           rij=xj*xj+yj*yj+zj*zj
3183           rrmij=1.0D0/rij
3184           rij=dsqrt(rij)
3185           rmij=1.0D0/rij
3186           r3ij=rrmij*rmij
3187           r6ij=r3ij*r3ij
3188           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3189           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3190           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3191           fac=cosa-3.0D0*cosb*cosg
3192           ev1=aaa*r6ij*r6ij
3193 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3194           if (j.eq.i+2) ev1=scal_el*ev1
3195           ev2=bbb*r6ij
3196           fac3=ael6i*r6ij
3197           fac4=ael3i*r3ij
3198           evdwij=ev1+ev2
3199           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3200           el2=fac4*fac
3201           eesij=el1+el2
3202 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3203           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3204           ees=ees+eesij
3205           evdw1=evdw1+evdwij
3206 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3207 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3208 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3209 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3210
3211           if (energy_dec) then
3212               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3213               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3214           endif
3215
3216 C
3217 C Calculate contributions to the Cartesian gradient.
3218 C
3219 #ifdef SPLITELE
3220           facvdw=-6*rrmij*(ev1+evdwij)
3221           facel=-3*rrmij*(el1+eesij)
3222           fac1=fac
3223           erij(1)=xj*rmij
3224           erij(2)=yj*rmij
3225           erij(3)=zj*rmij
3226 *
3227 * Radial derivatives. First process both termini of the fragment (i,j)
3228 *
3229           ggg(1)=facel*xj
3230           ggg(2)=facel*yj
3231           ggg(3)=facel*zj
3232 c          do k=1,3
3233 c            ghalf=0.5D0*ggg(k)
3234 c            gelc(k,i)=gelc(k,i)+ghalf
3235 c            gelc(k,j)=gelc(k,j)+ghalf
3236 c          enddo
3237 c 9/28/08 AL Gradient compotents will be summed only at the end
3238           do k=1,3
3239             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3240             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3241           enddo
3242 *
3243 * Loop over residues i+1 thru j-1.
3244 *
3245 cgrad          do k=i+1,j-1
3246 cgrad            do l=1,3
3247 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3248 cgrad            enddo
3249 cgrad          enddo
3250           ggg(1)=facvdw*xj
3251           ggg(2)=facvdw*yj
3252           ggg(3)=facvdw*zj
3253 c          do k=1,3
3254 c            ghalf=0.5D0*ggg(k)
3255 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3256 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3257 c          enddo
3258 c 9/28/08 AL Gradient compotents will be summed only at the end
3259           do k=1,3
3260             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3261             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3262           enddo
3263 *
3264 * Loop over residues i+1 thru j-1.
3265 *
3266 cgrad          do k=i+1,j-1
3267 cgrad            do l=1,3
3268 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3269 cgrad            enddo
3270 cgrad          enddo
3271 #else
3272           facvdw=ev1+evdwij
3273           facel=el1+eesij
3274           fac1=fac
3275           fac=-3*rrmij*(facvdw+facvdw+facel)
3276           erij(1)=xj*rmij
3277           erij(2)=yj*rmij
3278           erij(3)=zj*rmij
3279 *
3280 * Radial derivatives. First process both termini of the fragment (i,j)
3281 *
3282           ggg(1)=fac*xj
3283           ggg(2)=fac*yj
3284           ggg(3)=fac*zj
3285 c          do k=1,3
3286 c            ghalf=0.5D0*ggg(k)
3287 c            gelc(k,i)=gelc(k,i)+ghalf
3288 c            gelc(k,j)=gelc(k,j)+ghalf
3289 c          enddo
3290 c 9/28/08 AL Gradient compotents will be summed only at the end
3291           do k=1,3
3292             gelc_long(k,j)=gelc(k,j)+ggg(k)
3293             gelc_long(k,i)=gelc(k,i)-ggg(k)
3294           enddo
3295 *
3296 * Loop over residues i+1 thru j-1.
3297 *
3298 cgrad          do k=i+1,j-1
3299 cgrad            do l=1,3
3300 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3301 cgrad            enddo
3302 cgrad          enddo
3303 c 9/28/08 AL Gradient compotents will be summed only at the end
3304           ggg(1)=facvdw*xj
3305           ggg(2)=facvdw*yj
3306           ggg(3)=facvdw*zj
3307           do k=1,3
3308             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3309             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3310           enddo
3311 #endif
3312 *
3313 * Angular part
3314 *
3315           ecosa=2.0D0*fac3*fac1+fac4
3316           fac4=-3.0D0*fac4
3317           fac3=-6.0D0*fac3
3318           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3319           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3320           do k=1,3
3321             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3322             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3323           enddo
3324 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3325 cd   &          (dcosg(k),k=1,3)
3326           do k=1,3
3327             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3328           enddo
3329 c          do k=1,3
3330 c            ghalf=0.5D0*ggg(k)
3331 c            gelc(k,i)=gelc(k,i)+ghalf
3332 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3333 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3334 c            gelc(k,j)=gelc(k,j)+ghalf
3335 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3336 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3337 c          enddo
3338 cgrad          do k=i+1,j-1
3339 cgrad            do l=1,3
3340 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3341 cgrad            enddo
3342 cgrad          enddo
3343           do k=1,3
3344             gelc(k,i)=gelc(k,i)
3345      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3346      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3347             gelc(k,j)=gelc(k,j)
3348      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3349      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3350             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3351             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3352           enddo
3353           IF ((wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0.or.wcorr5.gt.0.0d0
3354      &       .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3355      &       .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0)
3356      &        .and. itype(i+2).ne.ntyp1 .and.
3357      &        (j.lt.nres-1.and.itype(j+2).ne.ntyp1 .or. j.eq.nres-1
3358      &        .and.itype(j-2).ne.ntyp1)
3359      &        ) THEN
3360 C
3361 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3362 C   energy of a peptide unit is assumed in the form of a second-order
3363 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3364 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3365 C   are computed for EVERY pair of non-contiguous peptide groups.
3366 C
3367           if (j.lt.nres-1) then
3368             j1=j+1
3369             j2=j-1
3370           else
3371             j1=j-1
3372             j2=j-2
3373           endif
3374           kkk=0
3375           do k=1,2
3376             do l=1,2
3377               kkk=kkk+1
3378               muij(kkk)=mu(k,i)*mu(l,j)
3379             enddo
3380           enddo
3381 cd         write (iout,*) 'EELEC: i',i,' j',j
3382 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3383 cd          write(iout,*) 'muij',muij
3384           ury=scalar(uy(1,i),erij)
3385           urz=scalar(uz(1,i),erij)
3386           vry=scalar(uy(1,j),erij)
3387           vrz=scalar(uz(1,j),erij)
3388           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3389           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3390           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3391           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3392           fac=dsqrt(-ael6i)*r3ij
3393           a22=a22*fac
3394           a23=a23*fac
3395           a32=a32*fac
3396           a33=a33*fac
3397 cd          write (iout,'(4i5,4f10.5)')
3398 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3399 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3400 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3401 cd     &      uy(:,j),uz(:,j)
3402 cd          write (iout,'(4f10.5)')
3403 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3404 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3405 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3406 cd           write (iout,'(9f10.5/)')
3407 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3408 C Derivatives of the elements of A in virtual-bond vectors
3409           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3410           do k=1,3
3411             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3412             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3413             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3414             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3415             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3416             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3417             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3418             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3419             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3420             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3421             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3422             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3423           enddo
3424 C Compute radial contributions to the gradient
3425           facr=-3.0d0*rrmij
3426           a22der=a22*facr
3427           a23der=a23*facr
3428           a32der=a32*facr
3429           a33der=a33*facr
3430           agg(1,1)=a22der*xj
3431           agg(2,1)=a22der*yj
3432           agg(3,1)=a22der*zj
3433           agg(1,2)=a23der*xj
3434           agg(2,2)=a23der*yj
3435           agg(3,2)=a23der*zj
3436           agg(1,3)=a32der*xj
3437           agg(2,3)=a32der*yj
3438           agg(3,3)=a32der*zj
3439           agg(1,4)=a33der*xj
3440           agg(2,4)=a33der*yj
3441           agg(3,4)=a33der*zj
3442 C Add the contributions coming from er
3443           fac3=-3.0d0*fac
3444           do k=1,3
3445             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3446             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3447             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3448             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3449           enddo
3450           do k=1,3
3451 C Derivatives in DC(i)
3452 cgrad            ghalf1=0.5d0*agg(k,1)
3453 cgrad            ghalf2=0.5d0*agg(k,2)
3454 cgrad            ghalf3=0.5d0*agg(k,3)
3455 cgrad            ghalf4=0.5d0*agg(k,4)
3456             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3457      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3458             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3459      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3460             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3461      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3462             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3463      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3464 C Derivatives in DC(i+1)
3465             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3466      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3467             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3468      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3469             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3470      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3471             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3472      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3473 C Derivatives in DC(j)
3474             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3475      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3476             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3477      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3478             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3479      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3480             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3481      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3482 C Derivatives in DC(j+1) or DC(nres-1)
3483             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3484      &      -3.0d0*vryg(k,3)*ury)
3485             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3486      &      -3.0d0*vrzg(k,3)*ury)
3487             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3488      &      -3.0d0*vryg(k,3)*urz)
3489             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3490      &      -3.0d0*vrzg(k,3)*urz)
3491 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3492 cgrad              do l=1,4
3493 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3494 cgrad              enddo
3495 cgrad            endif
3496           enddo
3497           acipa(1,1)=a22
3498           acipa(1,2)=a23
3499           acipa(2,1)=a32
3500           acipa(2,2)=a33
3501           a22=-a22
3502           a23=-a23
3503           do l=1,2
3504             do k=1,3
3505               agg(k,l)=-agg(k,l)
3506               aggi(k,l)=-aggi(k,l)
3507               aggi1(k,l)=-aggi1(k,l)
3508               aggj(k,l)=-aggj(k,l)
3509               aggj1(k,l)=-aggj1(k,l)
3510             enddo
3511           enddo
3512           if (j.lt.nres-1) then
3513             a22=-a22
3514             a32=-a32
3515             do l=1,3,2
3516               do k=1,3
3517                 agg(k,l)=-agg(k,l)
3518                 aggi(k,l)=-aggi(k,l)
3519                 aggi1(k,l)=-aggi1(k,l)
3520                 aggj(k,l)=-aggj(k,l)
3521                 aggj1(k,l)=-aggj1(k,l)
3522               enddo
3523             enddo
3524           else
3525             a22=-a22
3526             a23=-a23
3527             a32=-a32
3528             a33=-a33
3529             do l=1,4
3530               do k=1,3
3531                 agg(k,l)=-agg(k,l)
3532                 aggi(k,l)=-aggi(k,l)
3533                 aggi1(k,l)=-aggi1(k,l)
3534                 aggj(k,l)=-aggj(k,l)
3535                 aggj1(k,l)=-aggj1(k,l)
3536               enddo
3537             enddo
3538           endif
3539           ENDIF ! WCORR
3540           IF (wel_loc.gt.0.0d0) THEN
3541 C Contribution to the local-electrostatic energy coming from the i-j pair
3542           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3543      &     +a33*muij(4)
3544 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3545
3546           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3547      &            'eelloc',i,j,eel_loc_ij
3548
3549           eel_loc=eel_loc+eel_loc_ij
3550 C Partial derivatives in virtual-bond dihedral angles gamma
3551           if (i.gt.1)
3552      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3553      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3554      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3555           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3556      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3557      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3558 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3559           do l=1,3
3560             ggg(l)=agg(l,1)*muij(1)+
3561      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3562             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3563             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3564 cgrad            ghalf=0.5d0*ggg(l)
3565 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3566 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3567           enddo
3568 cgrad          do k=i+1,j2
3569 cgrad            do l=1,3
3570 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3571 cgrad            enddo
3572 cgrad          enddo
3573 C Remaining derivatives of eello
3574           do l=1,3
3575             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3576      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3577             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3578      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3579             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3580      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3581             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3582      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3583           enddo
3584           ENDIF
3585 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3586 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3587           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3588      &       .and. num_conti.le.maxconts) then
3589 c            write (iout,*) i,j," entered corr"
3590 C
3591 C Calculate the contact function. The ith column of the array JCONT will
3592 C contain the numbers of atoms that make contacts with the atom I (of numbers
3593 C greater than I). The arrays FACONT and GACONT will contain the values of
3594 C the contact function and its derivative.
3595 c           r0ij=1.02D0*rpp(iteli,itelj)
3596 c           r0ij=1.11D0*rpp(iteli,itelj)
3597             r0ij=2.20D0*rpp(iteli,itelj)
3598 c           r0ij=1.55D0*rpp(iteli,itelj)
3599             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3600             if (fcont.gt.0.0D0) then
3601               num_conti=num_conti+1
3602               if (num_conti.gt.maxconts) then
3603                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3604      &                         ' will skip next contacts for this conf.'
3605               else
3606                 jcont_hb(num_conti,i)=j
3607 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3608 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3609                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3610      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3611 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3612 C  terms.
3613                 d_cont(num_conti,i)=rij
3614 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3615 C     --- Electrostatic-interaction matrix ---
3616                 a_chuj(1,1,num_conti,i)=a22
3617                 a_chuj(1,2,num_conti,i)=a23
3618                 a_chuj(2,1,num_conti,i)=a32
3619                 a_chuj(2,2,num_conti,i)=a33
3620 C     --- Gradient of rij
3621                 do kkk=1,3
3622                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3623                 enddo
3624                 kkll=0
3625                 do k=1,2
3626                   do l=1,2
3627                     kkll=kkll+1
3628                     do m=1,3
3629                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3630                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3631                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3632                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3633                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3634                     enddo
3635                   enddo
3636                 enddo
3637                 ENDIF
3638                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3639 C Calculate contact energies
3640                 cosa4=4.0D0*cosa
3641                 wij=cosa-3.0D0*cosb*cosg
3642                 cosbg1=cosb+cosg
3643                 cosbg2=cosb-cosg
3644 c               fac3=dsqrt(-ael6i)/r0ij**3
3645                 fac3=dsqrt(-ael6i)*r3ij
3646 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3647                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3648                 if (ees0tmp.gt.0) then
3649                   ees0pij=dsqrt(ees0tmp)
3650                 else
3651                   ees0pij=0
3652                 endif
3653 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3654                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3655                 if (ees0tmp.gt.0) then
3656                   ees0mij=dsqrt(ees0tmp)
3657                 else
3658                   ees0mij=0
3659                 endif
3660 c               ees0mij=0.0D0
3661                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3662                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3663 C Diagnostics. Comment out or remove after debugging!
3664 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3665 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3666 c               ees0m(num_conti,i)=0.0D0
3667 C End diagnostics.
3668 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3669 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3670 C Angular derivatives of the contact function
3671                 ees0pij1=fac3/ees0pij
3672                 ees0mij1=fac3/ees0mij
3673                 fac3p=-3.0D0*fac3*rrmij
3674                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3675                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3676 c               ees0mij1=0.0D0
3677                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3678                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3679                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3680                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3681                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3682                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3683                 ecosap=ecosa1+ecosa2
3684                 ecosbp=ecosb1+ecosb2
3685                 ecosgp=ecosg1+ecosg2
3686                 ecosam=ecosa1-ecosa2
3687                 ecosbm=ecosb1-ecosb2
3688                 ecosgm=ecosg1-ecosg2
3689 C Diagnostics
3690 c               ecosap=ecosa1
3691 c               ecosbp=ecosb1
3692 c               ecosgp=ecosg1
3693 c               ecosam=0.0D0
3694 c               ecosbm=0.0D0
3695 c               ecosgm=0.0D0
3696 C End diagnostics
3697                 facont_hb(num_conti,i)=fcont
3698                 fprimcont=fprimcont/rij
3699 cd              facont_hb(num_conti,i)=1.0D0
3700 C Following line is for diagnostics.
3701 cd              fprimcont=0.0D0
3702                 do k=1,3
3703                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3704                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3705                 enddo
3706                 do k=1,3
3707                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3708                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3709                 enddo
3710                 gggp(1)=gggp(1)+ees0pijp*xj
3711                 gggp(2)=gggp(2)+ees0pijp*yj
3712                 gggp(3)=gggp(3)+ees0pijp*zj
3713                 gggm(1)=gggm(1)+ees0mijp*xj
3714                 gggm(2)=gggm(2)+ees0mijp*yj
3715                 gggm(3)=gggm(3)+ees0mijp*zj
3716 C Derivatives due to the contact function
3717                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3718                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3719                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3720                 do k=1,3
3721 c
3722 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3723 c          following the change of gradient-summation algorithm.
3724 c
3725 cgrad                  ghalfp=0.5D0*gggp(k)
3726 cgrad                  ghalfm=0.5D0*gggm(k)
3727                   gacontp_hb1(k,num_conti,i)=!ghalfp
3728      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3729      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3730                   gacontp_hb2(k,num_conti,i)=!ghalfp
3731      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3732      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3733                   gacontp_hb3(k,num_conti,i)=gggp(k)
3734                   gacontm_hb1(k,num_conti,i)=!ghalfm
3735      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3736      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3737                   gacontm_hb2(k,num_conti,i)=!ghalfm
3738      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3739      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3740                   gacontm_hb3(k,num_conti,i)=gggm(k)
3741                 enddo
3742 C Diagnostics. Comment out or remove after debugging!
3743 cdiag           do k=1,3
3744 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3745 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3746 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3747 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3748 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3749 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3750 cdiag           enddo
3751               ENDIF ! wcorr
3752               endif  ! num_conti.le.maxconts
3753             endif  ! fcont.gt.0
3754           endif    ! j.gt.i+1
3755           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3756             do k=1,4
3757               do l=1,3
3758                 ghalf=0.5d0*agg(l,k)
3759                 aggi(l,k)=aggi(l,k)+ghalf
3760                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3761                 aggj(l,k)=aggj(l,k)+ghalf
3762               enddo
3763             enddo
3764             if (j.eq.nres-1 .and. i.lt.j-2) then
3765               do k=1,4
3766                 do l=1,3
3767                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3768                 enddo
3769               enddo
3770             endif
3771           endif
3772 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3773       return
3774       end
3775 C-----------------------------------------------------------------------------
3776       subroutine eturn3(i,eello_turn3)
3777 C Third- and fourth-order contributions from turns
3778       implicit real*8 (a-h,o-z)
3779       include 'DIMENSIONS'
3780       include 'COMMON.IOUNITS'
3781       include 'COMMON.GEO'
3782       include 'COMMON.VAR'
3783       include 'COMMON.LOCAL'
3784       include 'COMMON.CHAIN'
3785       include 'COMMON.DERIV'
3786       include 'COMMON.INTERACT'
3787       include 'COMMON.CONTACTS'
3788       include 'COMMON.TORSION'
3789       include 'COMMON.VECTORS'
3790       include 'COMMON.FFIELD'
3791       include 'COMMON.CONTROL'
3792       dimension ggg(3)
3793       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3794      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3795      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3796       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3797      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3798       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3799      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3800      &    num_conti,j1,j2
3801       j=i+2
3802 c      write (iout,*) "eturn3",i,j,j1,j2
3803       a_temp(1,1)=a22
3804       a_temp(1,2)=a23
3805       a_temp(2,1)=a32
3806       a_temp(2,2)=a33
3807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3808 C
3809 C               Third-order contributions
3810 C
3811 C                 (i+2)o----(i+3)
3812 C                      | |
3813 C                      | |
3814 C                 (i+1)o----i
3815 C
3816 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3817 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3818         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3819         call transpose2(auxmat(1,1),auxmat1(1,1))
3820         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3821         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3822         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3823      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3824 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3825 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3826 cd     &    ' eello_turn3_num',4*eello_turn3_num
3827 C Derivatives in gamma(i)
3828         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3829         call transpose2(auxmat2(1,1),auxmat3(1,1))
3830         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3831         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3832 C Derivatives in gamma(i+1)
3833         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3834         call transpose2(auxmat2(1,1),auxmat3(1,1))
3835         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3836         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3837      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3838 C Cartesian derivatives
3839         do l=1,3
3840 c            ghalf1=0.5d0*agg(l,1)
3841 c            ghalf2=0.5d0*agg(l,2)
3842 c            ghalf3=0.5d0*agg(l,3)
3843 c            ghalf4=0.5d0*agg(l,4)
3844           a_temp(1,1)=aggi(l,1)!+ghalf1
3845           a_temp(1,2)=aggi(l,2)!+ghalf2
3846           a_temp(2,1)=aggi(l,3)!+ghalf3
3847           a_temp(2,2)=aggi(l,4)!+ghalf4
3848           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3849           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3850      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3851           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3852           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3853           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3854           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3855           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3856           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3857      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3858           a_temp(1,1)=aggj(l,1)!+ghalf1
3859           a_temp(1,2)=aggj(l,2)!+ghalf2
3860           a_temp(2,1)=aggj(l,3)!+ghalf3
3861           a_temp(2,2)=aggj(l,4)!+ghalf4
3862           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3863           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3864      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3865           a_temp(1,1)=aggj1(l,1)
3866           a_temp(1,2)=aggj1(l,2)
3867           a_temp(2,1)=aggj1(l,3)
3868           a_temp(2,2)=aggj1(l,4)
3869           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3870           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3871      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3872         enddo
3873       return
3874       end
3875 C-------------------------------------------------------------------------------
3876       subroutine eturn4(i,eello_turn4)
3877 C Third- and fourth-order contributions from turns
3878       implicit real*8 (a-h,o-z)
3879       include 'DIMENSIONS'
3880       include 'COMMON.IOUNITS'
3881       include 'COMMON.GEO'
3882       include 'COMMON.VAR'
3883       include 'COMMON.LOCAL'
3884       include 'COMMON.CHAIN'
3885       include 'COMMON.DERIV'
3886       include 'COMMON.INTERACT'
3887       include 'COMMON.CONTACTS'
3888       include 'COMMON.TORSION'
3889       include 'COMMON.VECTORS'
3890       include 'COMMON.FFIELD'
3891       include 'COMMON.CONTROL'
3892       dimension ggg(3)
3893       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3894      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3895      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3896       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3897      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3898       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3899      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3900      &    num_conti,j1,j2
3901       j=i+3
3902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3903 C
3904 C               Fourth-order contributions
3905 C
3906 C                 (i+3)o----(i+4)
3907 C                     /  |
3908 C               (i+2)o   |
3909 C                     \  |
3910 C                 (i+1)o----i
3911 C
3912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3913 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3914 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3915         a_temp(1,1)=a22
3916         a_temp(1,2)=a23
3917         a_temp(2,1)=a32
3918         a_temp(2,2)=a33
3919         iti1=itortyp(itype(i+1))
3920         iti2=itortyp(itype(i+2))
3921         iti3=itortyp(itype(i+3))
3922 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3923         call transpose2(EUg(1,1,i+1),e1t(1,1))
3924         call transpose2(Eug(1,1,i+2),e2t(1,1))
3925         call transpose2(Eug(1,1,i+3),e3t(1,1))
3926         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3927         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3928         s1=scalar2(b1(1,iti2),auxvec(1))
3929         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3930         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3931         s2=scalar2(b1(1,iti1),auxvec(1))
3932         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3933         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3934         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3935         eello_turn4=eello_turn4-(s1+s2+s3)
3936         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3937      &      'eturn4',i,j,-(s1+s2+s3)
3938 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3939 cd     &    ' eello_turn4_num',8*eello_turn4_num
3940 C Derivatives in gamma(i)
3941         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3942         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3943         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3944         s1=scalar2(b1(1,iti2),auxvec(1))
3945         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3946         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3947         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3948 C Derivatives in gamma(i+1)
3949         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3950         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3951         s2=scalar2(b1(1,iti1),auxvec(1))
3952         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3953         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3954         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3955         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3956 C Derivatives in gamma(i+2)
3957         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3958         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3959         s1=scalar2(b1(1,iti2),auxvec(1))
3960         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3961         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3962         s2=scalar2(b1(1,iti1),auxvec(1))
3963         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3964         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3965         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3966         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3967 C Cartesian derivatives
3968 C Derivatives of this turn contributions in DC(i+2)
3969         if (j.lt.nres-1) then
3970           do l=1,3
3971             a_temp(1,1)=agg(l,1)
3972             a_temp(1,2)=agg(l,2)
3973             a_temp(2,1)=agg(l,3)
3974             a_temp(2,2)=agg(l,4)
3975             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977             s1=scalar2(b1(1,iti2),auxvec(1))
3978             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980             s2=scalar2(b1(1,iti1),auxvec(1))
3981             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984             ggg(l)=-(s1+s2+s3)
3985             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3986           enddo
3987         endif
3988 C Remaining derivatives of this turn contribution
3989         do l=1,3
3990           a_temp(1,1)=aggi(l,1)
3991           a_temp(1,2)=aggi(l,2)
3992           a_temp(2,1)=aggi(l,3)
3993           a_temp(2,2)=aggi(l,4)
3994           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3995           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3996           s1=scalar2(b1(1,iti2),auxvec(1))
3997           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3998           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3999           s2=scalar2(b1(1,iti1),auxvec(1))
4000           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4001           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4002           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4003           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4004           a_temp(1,1)=aggi1(l,1)
4005           a_temp(1,2)=aggi1(l,2)
4006           a_temp(2,1)=aggi1(l,3)
4007           a_temp(2,2)=aggi1(l,4)
4008           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4009           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4010           s1=scalar2(b1(1,iti2),auxvec(1))
4011           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4012           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4013           s2=scalar2(b1(1,iti1),auxvec(1))
4014           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4015           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4016           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4017           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4018           a_temp(1,1)=aggj(l,1)
4019           a_temp(1,2)=aggj(l,2)
4020           a_temp(2,1)=aggj(l,3)
4021           a_temp(2,2)=aggj(l,4)
4022           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4023           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4024           s1=scalar2(b1(1,iti2),auxvec(1))
4025           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4026           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4027           s2=scalar2(b1(1,iti1),auxvec(1))
4028           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4029           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4030           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4031           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4032           a_temp(1,1)=aggj1(l,1)
4033           a_temp(1,2)=aggj1(l,2)
4034           a_temp(2,1)=aggj1(l,3)
4035           a_temp(2,2)=aggj1(l,4)
4036           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4037           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4038           s1=scalar2(b1(1,iti2),auxvec(1))
4039           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4040           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4041           s2=scalar2(b1(1,iti1),auxvec(1))
4042           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4043           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4044           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4045 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4046           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4047         enddo
4048       return
4049       end
4050 C-----------------------------------------------------------------------------
4051       subroutine vecpr(u,v,w)
4052       implicit real*8(a-h,o-z)
4053       dimension u(3),v(3),w(3)
4054       w(1)=u(2)*v(3)-u(3)*v(2)
4055       w(2)=-u(1)*v(3)+u(3)*v(1)
4056       w(3)=u(1)*v(2)-u(2)*v(1)
4057       return
4058       end
4059 C-----------------------------------------------------------------------------
4060       subroutine unormderiv(u,ugrad,unorm,ungrad)
4061 C This subroutine computes the derivatives of a normalized vector u, given
4062 C the derivatives computed without normalization conditions, ugrad. Returns
4063 C ungrad.
4064       implicit none
4065       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4066       double precision vec(3)
4067       double precision scalar
4068       integer i,j
4069 c      write (2,*) 'ugrad',ugrad
4070 c      write (2,*) 'u',u
4071       do i=1,3
4072         vec(i)=scalar(ugrad(1,i),u(1))
4073       enddo
4074 c      write (2,*) 'vec',vec
4075       do i=1,3
4076         do j=1,3
4077           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4078         enddo
4079       enddo
4080 c      write (2,*) 'ungrad',ungrad
4081       return
4082       end
4083 C-----------------------------------------------------------------------------
4084       subroutine escp_soft_sphere(evdw2,evdw2_14)
4085 C
4086 C This subroutine calculates the excluded-volume interaction energy between
4087 C peptide-group centers and side chains and its gradient in virtual-bond and
4088 C side-chain vectors.
4089 C
4090       implicit real*8 (a-h,o-z)
4091       include 'DIMENSIONS'
4092       include 'COMMON.GEO'
4093       include 'COMMON.VAR'
4094       include 'COMMON.LOCAL'
4095       include 'COMMON.CHAIN'
4096       include 'COMMON.DERIV'
4097       include 'COMMON.INTERACT'
4098       include 'COMMON.FFIELD'
4099       include 'COMMON.IOUNITS'
4100       include 'COMMON.CONTROL'
4101       dimension ggg(3)
4102       evdw2=0.0D0
4103       evdw2_14=0.0d0
4104       r0_scp=4.5d0
4105 cd    print '(a)','Enter ESCP'
4106 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4107       do i=iatscp_s,iatscp_e
4108         iteli=itel(i)
4109         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4110
4111         xi=0.5D0*(c(1,i)+c(1,i+1))
4112         yi=0.5D0*(c(2,i)+c(2,i+1))
4113         zi=0.5D0*(c(3,i)+c(3,i+1))
4114
4115         do iint=1,nscp_gr(i)
4116
4117         do j=iscpstart(i,iint),iscpend(i,iint)
4118           itypj=itype(j)
4119 C Uncomment following three lines for SC-p interactions
4120 c         xj=c(1,nres+j)-xi
4121 c         yj=c(2,nres+j)-yi
4122 c         zj=c(3,nres+j)-zi
4123 C Uncomment following three lines for Ca-p interactions
4124           if (itype(j).eq.ntyp1) cycle
4125           xj=c(1,j)-xi
4126           yj=c(2,j)-yi
4127           zj=c(3,j)-zi
4128           rij=xj*xj+yj*yj+zj*zj
4129           r0ij=r0_scp
4130           r0ijsq=r0ij*r0ij
4131           if (rij.lt.r0ijsq) then
4132             evdwij=0.25d0*(rij-r0ijsq)**2
4133             fac=rij-r0ijsq
4134           else
4135             evdwij=0.0d0
4136             fac=0.0d0
4137           endif
4138           evdw2=evdw2+evdwij
4139 C
4140 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4141 C
4142           ggg(1)=xj*fac
4143           ggg(2)=yj*fac
4144           ggg(3)=zj*fac
4145 cgrad          if (j.lt.i) then
4146 cd          write (iout,*) 'j<i'
4147 C Uncomment following three lines for SC-p interactions
4148 c           do k=1,3
4149 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4150 c           enddo
4151 cgrad          else
4152 cd          write (iout,*) 'j>i'
4153 cgrad            do k=1,3
4154 cgrad              ggg(k)=-ggg(k)
4155 C Uncomment following line for SC-p interactions
4156 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4157 cgrad            enddo
4158 cgrad          endif
4159 cgrad          do k=1,3
4160 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4161 cgrad          enddo
4162 cgrad          kstart=min0(i+1,j)
4163 cgrad          kend=max0(i-1,j-1)
4164 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4165 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4166 cgrad          do k=kstart,kend
4167 cgrad            do l=1,3
4168 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4169 cgrad            enddo
4170 cgrad          enddo
4171           do k=1,3
4172             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4173             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4174           enddo
4175         enddo
4176
4177         enddo ! iint
4178       enddo ! i
4179       return
4180       end
4181 C-----------------------------------------------------------------------------
4182       subroutine escp(evdw2,evdw2_14)
4183 C
4184 C This subroutine calculates the excluded-volume interaction energy between
4185 C peptide-group centers and side chains and its gradient in virtual-bond and
4186 C side-chain vectors.
4187 C
4188       implicit real*8 (a-h,o-z)
4189       include 'DIMENSIONS'
4190       include 'COMMON.GEO'
4191       include 'COMMON.VAR'
4192       include 'COMMON.LOCAL'
4193       include 'COMMON.CHAIN'
4194       include 'COMMON.DERIV'
4195       include 'COMMON.INTERACT'
4196       include 'COMMON.FFIELD'
4197       include 'COMMON.IOUNITS'
4198       include 'COMMON.CONTROL'
4199       include "COMMON.ECOMPON"
4200       dimension ggg(3)
4201       evdw2=0.0D0
4202       evdw2_14=0.0d0
4203 cd    print '(a)','Enter ESCP'
4204 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4205       do i=iatscp_s,iatscp_e
4206         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4207         iteli=itel(i)
4208         xi=0.5D0*(c(1,i)+c(1,i+1))
4209         yi=0.5D0*(c(2,i)+c(2,i+1))
4210         zi=0.5D0*(c(3,i)+c(3,i+1))
4211
4212         do iint=1,nscp_gr(i)
4213
4214         do j=iscpstart(i,iint),iscpend(i,iint)
4215           if (itype(j).eq.ntyp1) cycle
4216           itypj=itype(j)
4217 C Uncomment following three lines for SC-p interactions
4218 c         xj=c(1,nres+j)-xi
4219 c         yj=c(2,nres+j)-yi
4220 c         zj=c(3,nres+j)-zi
4221 C Uncomment following three lines for Ca-p interactions
4222           xj=c(1,j)-xi
4223           yj=c(2,j)-yi
4224           zj=c(3,j)-zi
4225           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4226           fac=rrij**expon2
4227           e1=fac*fac*aad(itypj,iteli)
4228           e2=fac*bad(itypj,iteli)
4229           if (iabs(j-i) .le. 2) then
4230             e1=scal14*e1
4231             e2=scal14*e2
4232             evdw2_14=evdw2_14+e1+e2
4233           endif
4234           evdwij=e1+e2
4235           vdw2compon(itypj)=vdw2compon(itypj)+evdwij
4236           evdw2=evdw2+evdwij
4237           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4238      &        'evdw2',i,j,evdwij
4239 C
4240 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4241 C
4242           fac=-(evdwij+e1)*rrij
4243           ggg(1)=xj*fac
4244           ggg(2)=yj*fac
4245           ggg(3)=zj*fac
4246 cgrad          if (j.lt.i) then
4247 cd          write (iout,*) 'j<i'
4248 C Uncomment following three lines for SC-p interactions
4249 c           do k=1,3
4250 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4251 c           enddo
4252 cgrad          else
4253 cd          write (iout,*) 'j>i'
4254 cgrad            do k=1,3
4255 cgrad              ggg(k)=-ggg(k)
4256 C Uncomment following line for SC-p interactions
4257 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4258 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4259 cgrad            enddo
4260 cgrad          endif
4261 cgrad          do k=1,3
4262 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4263 cgrad          enddo
4264 cgrad          kstart=min0(i+1,j)
4265 cgrad          kend=max0(i-1,j-1)
4266 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4267 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4268 cgrad          do k=kstart,kend
4269 cgrad            do l=1,3
4270 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4271 cgrad            enddo
4272 cgrad          enddo
4273           do k=1,3
4274             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4275             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4276           enddo
4277         enddo
4278
4279         enddo ! iint
4280       enddo ! i
4281       do i=1,nct
4282         do j=1,3
4283           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4284           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4285           gradx_scp(j,i)=expon*gradx_scp(j,i)
4286         enddo
4287       enddo
4288 C******************************************************************************
4289 C
4290 C                              N O T E !!!
4291 C
4292 C To save time the factor EXPON has been extracted from ALL components
4293 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4294 C use!
4295 C
4296 C******************************************************************************
4297       return
4298       end
4299 C--------------------------------------------------------------------------
4300       subroutine edis(ehpb)
4301 C
4302 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4303 C
4304       implicit real*8 (a-h,o-z)
4305       include 'DIMENSIONS'
4306       include 'COMMON.SBRIDGE'
4307       include 'COMMON.CHAIN'
4308       include 'COMMON.DERIV'
4309       include 'COMMON.VAR'
4310       include 'COMMON.INTERACT'
4311       include 'COMMON.IOUNITS'
4312       dimension ggg(3)
4313       ehpb=0.0D0
4314 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4315 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4316       if (link_end.eq.0) return
4317       do i=link_start,link_end
4318 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4319 C CA-CA distance used in regularization of structure.
4320         ii=ihpb(i)
4321         jj=jhpb(i)
4322         if (itype(ii).eq.ntyp1 .or. itype(jj).eq.ntyp1) cycle
4323 C iii and jjj point to the residues for which the distance is assigned.
4324         if (ii.gt.nres) then
4325           iii=ii-nres
4326           jjj=jj-nres
4327         else
4328           iii=ii
4329           jjj=jj
4330         endif
4331 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4332 c     &    dhpb(i),dhpb1(i),forcon(i)
4333 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4334 C    distance and angle dependent SS bond potential.
4335         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4336           call ssbond_ene(iii,jjj,eij)
4337           ehpb=ehpb+2*eij
4338 cd          write (iout,*) "eij",eij
4339         else if (ii.gt.nres .and. jj.gt.nres) then
4340 c Restraints from contact prediction
4341           dd=dist(ii,jj)
4342           if (dhpb1(i).gt.0.0d0) then
4343             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4344             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4345 c            write (iout,*) "beta nmr",
4346 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4347           else
4348             dd=dist(ii,jj)
4349             rdis=dd-dhpb(i)
4350 C Get the force constant corresponding to this distance.
4351             waga=forcon(i)
4352 C Calculate the contribution to energy.
4353             ehpb=ehpb+waga*rdis*rdis
4354 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4355 C
4356 C Evaluate gradient.
4357 C
4358             fac=waga*rdis/dd
4359           endif
4360           do j=1,3
4361             ggg(j)=fac*(c(j,jj)-c(j,ii))
4362           enddo
4363           do j=1,3
4364             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4365             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4366           enddo
4367           do k=1,3
4368             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4369             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4370           enddo
4371         else
4372 C Calculate the distance between the two points and its difference from the
4373 C target distance.
4374           dd=dist(ii,jj)
4375           if (dhpb1(i).gt.0.0d0) then
4376             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4377             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4378 c            write (iout,*) "alph nmr",
4379 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4380           else
4381             rdis=dd-dhpb(i)
4382 C Get the force constant corresponding to this distance.
4383             waga=forcon(i)
4384 C Calculate the contribution to energy.
4385             ehpb=ehpb+waga*rdis*rdis
4386 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4387 C
4388 C Evaluate gradient.
4389 C
4390             fac=waga*rdis/dd
4391           endif
4392 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4393 cd   &   ' waga=',waga,' fac=',fac
4394             do j=1,3
4395               ggg(j)=fac*(c(j,jj)-c(j,ii))
4396             enddo
4397 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4398 C If this is a SC-SC distance, we need to calculate the contributions to the
4399 C Cartesian gradient in the SC vectors (ghpbx).
4400           if (iii.lt.ii) then
4401           do j=1,3
4402             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4403             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4404           enddo
4405           endif
4406 cgrad        do j=iii,jjj-1
4407 cgrad          do k=1,3
4408 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4409 cgrad          enddo
4410 cgrad        enddo
4411           do k=1,3
4412             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4413             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4414           enddo
4415         endif
4416       enddo
4417       ehpb=0.5D0*ehpb
4418       return
4419       end
4420 C--------------------------------------------------------------------------
4421       subroutine ssbond_ene(i,j,eij)
4422 C
4423 C Calculate the distance and angle dependent SS-bond potential energy
4424 C using a free-energy function derived based on RHF/6-31G** ab initio
4425 C calculations of diethyl disulfide.
4426 C
4427 C A. Liwo and U. Kozlowska, 11/24/03
4428 C
4429       implicit real*8 (a-h,o-z)
4430       include 'DIMENSIONS'
4431       include 'COMMON.SBRIDGE'
4432       include 'COMMON.CHAIN'
4433       include 'COMMON.DERIV'
4434       include 'COMMON.LOCAL'
4435       include 'COMMON.INTERACT'
4436       include 'COMMON.VAR'
4437       include 'COMMON.IOUNITS'
4438       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4439       itypi=itype(i)
4440       xi=c(1,nres+i)
4441       yi=c(2,nres+i)
4442       zi=c(3,nres+i)
4443       dxi=dc_norm(1,nres+i)
4444       dyi=dc_norm(2,nres+i)
4445       dzi=dc_norm(3,nres+i)
4446 c      dsci_inv=dsc_inv(itypi)
4447       dsci_inv=vbld_inv(nres+i)
4448       itypj=itype(j)
4449 c      dscj_inv=dsc_inv(itypj)
4450       dscj_inv=vbld_inv(nres+j)
4451       xj=c(1,nres+j)-xi
4452       yj=c(2,nres+j)-yi
4453       zj=c(3,nres+j)-zi
4454       dxj=dc_norm(1,nres+j)
4455       dyj=dc_norm(2,nres+j)
4456       dzj=dc_norm(3,nres+j)
4457       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4458       rij=dsqrt(rrij)
4459       erij(1)=xj*rij
4460       erij(2)=yj*rij
4461       erij(3)=zj*rij
4462       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4463       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4464       om12=dxi*dxj+dyi*dyj+dzi*dzj
4465       do k=1,3
4466         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4467         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4468       enddo
4469       rij=1.0d0/rij
4470       deltad=rij-d0cm
4471       deltat1=1.0d0-om1
4472       deltat2=1.0d0+om2
4473       deltat12=om2-om1+2.0d0
4474       cosphi=om12-om1*om2
4475       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4476      &  +akct*deltad*deltat12+ebr
4477      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4478 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4479 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4480 c     &  " deltat12",deltat12," eij",eij
4481       ed=2*akcm*deltad+akct*deltat12
4482       pom1=akct*deltad
4483       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4484       eom1=-2*akth*deltat1-pom1-om2*pom2
4485       eom2= 2*akth*deltat2+pom1-om1*pom2
4486       eom12=pom2
4487       do k=1,3
4488         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4489         ghpbx(k,i)=ghpbx(k,i)-ggk
4490      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4491      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4492         ghpbx(k,j)=ghpbx(k,j)+ggk
4493      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4494      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4495         ghpbc(k,i)=ghpbc(k,i)-ggk
4496         ghpbc(k,j)=ghpbc(k,j)+ggk
4497       enddo
4498 C
4499 C Calculate the components of the gradient in DC and X
4500 C
4501 cgrad      do k=i,j-1
4502 cgrad        do l=1,3
4503 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4504 cgrad        enddo
4505 cgrad      enddo
4506       return
4507       end
4508 C--------------------------------------------------------------------------
4509       subroutine ebond(estr)
4510 c
4511 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4512 c
4513       implicit real*8 (a-h,o-z)
4514       include 'DIMENSIONS'
4515       include 'COMMON.LOCAL'
4516       include 'COMMON.GEO'
4517       include 'COMMON.INTERACT'
4518       include 'COMMON.DERIV'
4519       include 'COMMON.VAR'
4520       include 'COMMON.CHAIN'
4521       include 'COMMON.IOUNITS'
4522       include 'COMMON.NAMES'
4523       include 'COMMON.FFIELD'
4524       include 'COMMON.CONTROL'
4525       include 'COMMON.SETUP'
4526       double precision u(3),ud(3)
4527       estr=0.0d0
4528       do i=ibondp_start,ibondp_end
4529         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4530         diff = vbld(i)-vbldp0
4531         if (energy_dec) write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4532         estr=estr+diff*diff
4533         do j=1,3
4534           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4535         enddo
4536 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4537       enddo
4538       estr=0.5d0*AKP*estr
4539 c
4540 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4541 c
4542       do i=ibond_start,ibond_end
4543         iti=itype(i)
4544         if (iti.ne.10 .and. iti.ne.ntyp1) then
4545           nbi=nbondterm(iti)
4546           if (nbi.eq.1) then
4547             diff=vbld(i+nres)-vbldsc0(1,iti)
4548             if (energy_dec) write (iout,*) i,iti,vbld(i+nres),
4549      &         vbldsc0(1,iti),diff,
4550      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4551             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4552             do j=1,3
4553               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4554             enddo
4555           else
4556             do j=1,nbi
4557               diff=vbld(i+nres)-vbldsc0(j,iti)
4558               ud(j)=aksc(j,iti)*diff
4559               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4560             enddo
4561             uprod=u(1)
4562             do j=2,nbi
4563               uprod=uprod*u(j)
4564             enddo
4565             usum=0.0d0
4566             usumsqder=0.0d0
4567             do j=1,nbi
4568               uprod1=1.0d0
4569               uprod2=1.0d0
4570               do k=1,nbi
4571                 if (k.ne.j) then
4572                   uprod1=uprod1*u(k)
4573                   uprod2=uprod2*u(k)*u(k)
4574                 endif
4575               enddo
4576               usum=usum+uprod1
4577               usumsqder=usumsqder+ud(j)*uprod2
4578             enddo
4579             estr=estr+uprod/usum
4580             do j=1,3
4581              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4582             enddo
4583           endif
4584         endif
4585       enddo
4586       return
4587       end
4588 #ifdef CRYST_THETA
4589 C--------------------------------------------------------------------------
4590       subroutine ebend(etheta)
4591 C
4592 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4593 C angles gamma and its derivatives in consecutive thetas and gammas.
4594 C
4595       implicit real*8 (a-h,o-z)
4596       include 'DIMENSIONS'
4597       include 'COMMON.LOCAL'
4598       include 'COMMON.GEO'
4599       include 'COMMON.INTERACT'
4600       include 'COMMON.DERIV'
4601       include 'COMMON.VAR'
4602       include 'COMMON.CHAIN'
4603       include 'COMMON.IOUNITS'
4604       include 'COMMON.NAMES'
4605       include 'COMMON.FFIELD'
4606       include 'COMMON.CONTROL'
4607       include "COMMON.ECOMPON"
4608       common /calcthet/ term1,term2,termm,diffak,ratak,
4609      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4610      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4611       double precision y(2),z(2)
4612       delta=0.02d0*pi
4613 c      time11=dexp(-2*time)
4614 c      time12=1.0d0
4615       etheta=0.0D0
4616 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4617       do i=ithet_start,ithet_end
4618         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 .or.
4619      &    itype(i).eq.ntyp1) cycle
4620 C Zero the energy function and its derivative at 0 or pi.
4621         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4622         it=itype(i-1)
4623         if (i.gt.3) then
4624 #ifdef OSF
4625           phii=phi(i)
4626           if (phii.ne.phii) phii=150.0
4627 #else
4628           phii=phi(i)
4629 #endif
4630           y(1)=dcos(phii)
4631           y(2)=dsin(phii)
4632         else
4633           y(1)=0.0D0
4634           y(2)=0.0D0
4635         endif
4636         if (i.lt.nres) then
4637 #ifdef OSF
4638           phii1=phi(i+1)
4639           if (phii1.ne.phii1) phii1=150.0
4640           phii1=pinorm(phii1)
4641           z(1)=cos(phii1)
4642 #else
4643           phii1=phi(i+1)
4644           z(1)=dcos(phii1)
4645 #endif
4646           z(2)=dsin(phii1)
4647         else
4648           z(1)=0.0D0
4649           z(2)=0.0D0
4650         endif
4651 C Calculate the "mean" value of theta from the part of the distribution
4652 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4653 C In following comments this theta will be referred to as t_c.
4654         thet_pred_mean=0.0d0
4655         do k=1,2
4656           athetk=athet(k,it)
4657           bthetk=bthet(k,it)
4658           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4659         enddo
4660         dthett=thet_pred_mean*ssd
4661         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4662 C Derivatives of the "mean" values in gamma1 and gamma2.
4663         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4664         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4665         if (theta(i).gt.pi-delta) then
4666           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4667      &         E_tc0)
4668           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4669           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4670           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4671      &        E_theta)
4672           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4673      &        E_tc)
4674         else if (theta(i).lt.delta) then
4675           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4676           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4677           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4678      &        E_theta)
4679           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4680           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4681      &        E_tc)
4682         else
4683           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4684      &        E_theta,E_tc)
4685         endif
4686         becompon(it)=becompon(it)+ethetai
4687         etheta=etheta+ethetai
4688         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4689      &      'ebend',i,ethetai
4690         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4691         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4692         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4693       enddo
4694 C Ufff.... We've done all this!!!
4695       return
4696       end
4697 C---------------------------------------------------------------------------
4698       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4699      &     E_tc)
4700       implicit real*8 (a-h,o-z)
4701       include 'DIMENSIONS'
4702       include 'COMMON.LOCAL'
4703       include 'COMMON.IOUNITS'
4704       common /calcthet/ term1,term2,termm,diffak,ratak,
4705      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4706      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4707 C Calculate the contributions to both Gaussian lobes.
4708 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4709 C The "polynomial part" of the "standard deviation" of this part of
4710 C the distribution.
4711         sig=polthet(3,it)
4712         do j=2,0,-1
4713           sig=sig*thet_pred_mean+polthet(j,it)
4714         enddo
4715 C Derivative of the "interior part" of the "standard deviation of the"
4716 C gamma-dependent Gaussian lobe in t_c.
4717         sigtc=3*polthet(3,it)
4718         do j=2,1,-1
4719           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4720         enddo
4721         sigtc=sig*sigtc
4722 C Set the parameters of both Gaussian lobes of the distribution.
4723 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4724         fac=sig*sig+sigc0(it)
4725         sigcsq=fac+fac
4726         sigc=1.0D0/sigcsq
4727 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4728         sigsqtc=-4.0D0*sigcsq*sigtc
4729 c       print *,i,sig,sigtc,sigsqtc
4730 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4731         sigtc=-sigtc/(fac*fac)
4732 C Following variable is sigma(t_c)**(-2)
4733         sigcsq=sigcsq*sigcsq
4734         sig0i=sig0(it)
4735         sig0inv=1.0D0/sig0i**2
4736         delthec=thetai-thet_pred_mean
4737         delthe0=thetai-theta0i
4738         term1=-0.5D0*sigcsq*delthec*delthec
4739         term2=-0.5D0*sig0inv*delthe0*delthe0
4740 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4741 C NaNs in taking the logarithm. We extract the largest exponent which is added
4742 C to the energy (this being the log of the distribution) at the end of energy
4743 C term evaluation for this virtual-bond angle.
4744         if (term1.gt.term2) then
4745           termm=term1
4746           term2=dexp(term2-termm)
4747           term1=1.0d0
4748         else
4749           termm=term2
4750           term1=dexp(term1-termm)
4751           term2=1.0d0
4752         endif
4753 C The ratio between the gamma-independent and gamma-dependent lobes of
4754 C the distribution is a Gaussian function of thet_pred_mean too.
4755         diffak=gthet(2,it)-thet_pred_mean
4756         ratak=diffak/gthet(3,it)**2
4757         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4758 C Let's differentiate it in thet_pred_mean NOW.
4759         aktc=ak*ratak
4760 C Now put together the distribution terms to make complete distribution.
4761         termexp=term1+ak*term2
4762         termpre=sigc+ak*sig0i
4763 C Contribution of the bending energy from this theta is just the -log of
4764 C the sum of the contributions from the two lobes and the pre-exponential
4765 C factor. Simple enough, isn't it?
4766         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4767 C NOW the derivatives!!!
4768 C 6/6/97 Take into account the deformation.
4769         E_theta=(delthec*sigcsq*term1
4770      &       +ak*delthe0*sig0inv*term2)/termexp
4771         E_tc=((sigtc+aktc*sig0i)/termpre
4772      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4773      &       aktc*term2)/termexp)
4774       return
4775       end
4776 c-----------------------------------------------------------------------------
4777       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.LOCAL'
4781       include 'COMMON.IOUNITS'
4782       common /calcthet/ term1,term2,termm,diffak,ratak,
4783      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4784      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4785       delthec=thetai-thet_pred_mean
4786       delthe0=thetai-theta0i
4787 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4788       t3 = thetai-thet_pred_mean
4789       t6 = t3**2
4790       t9 = term1
4791       t12 = t3*sigcsq
4792       t14 = t12+t6*sigsqtc
4793       t16 = 1.0d0
4794       t21 = thetai-theta0i
4795       t23 = t21**2
4796       t26 = term2
4797       t27 = t21*t26
4798       t32 = termexp
4799       t40 = t32**2
4800       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4801      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4802      & *(-t12*t9-ak*sig0inv*t27)
4803       return
4804       end
4805 #else
4806 C--------------------------------------------------------------------------
4807       subroutine ebend(etheta)
4808 C
4809 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4810 C angles gamma and its derivatives in consecutive thetas and gammas.
4811 C ab initio-derived potentials from
4812 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4813 C
4814       implicit real*8 (a-h,o-z)
4815       include 'DIMENSIONS'
4816       include 'COMMON.LOCAL'
4817       include 'COMMON.GEO'
4818       include 'COMMON.INTERACT'
4819       include 'COMMON.DERIV'
4820       include 'COMMON.VAR'
4821       include 'COMMON.CHAIN'
4822       include 'COMMON.IOUNITS'
4823       include 'COMMON.NAMES'
4824       include 'COMMON.FFIELD'
4825       include 'COMMON.CONTROL'
4826       include "COMMON.ECOMPON"
4827       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4828      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4829      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4830      & sinph1ph2(maxdouble,maxdouble)
4831       logical lprn /.false./, lprn1 /.false./
4832       etheta=0.0D0
4833       do i=ithet_start,ithet_end
4834         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 .or.
4835      &      itype(i).eq.ntyp1) cycle
4836         dethetai=0.0d0
4837         dephii=0.0d0
4838         dephii1=0.0d0
4839         theti2=0.5d0*theta(i)
4840         ityp2=ithetyp(itype(i-1))
4841         do k=1,nntheterm
4842           coskt(k)=dcos(k*theti2)
4843           sinkt(k)=dsin(k*theti2)
4844         enddo
4845         if (i.gt.3) then
4846 #ifdef OSF
4847           phii=phi(i)
4848           if (phii.ne.phii) phii=150.0
4849 #else
4850           phii=phi(i)
4851 #endif
4852           ityp1=ithetyp(itype(i-2))
4853           do k=1,nsingle
4854             cosph1(k)=dcos(k*phii)
4855             sinph1(k)=dsin(k*phii)
4856           enddo
4857         else
4858           phii=0.0d0
4859           ityp1=nthetyp+1
4860           do k=1,nsingle
4861             cosph1(k)=0.0d0
4862             sinph1(k)=0.0d0
4863           enddo
4864         endif
4865         if (i.lt.nres) then
4866 #ifdef OSF
4867           phii1=phi(i+1)
4868           if (phii1.ne.phii1) phii1=150.0
4869           phii1=pinorm(phii1)
4870 #else
4871           phii1=phi(i+1)
4872 #endif
4873           ityp3=ithetyp(itype(i))
4874           do k=1,nsingle
4875             cosph2(k)=dcos(k*phii1)
4876             sinph2(k)=dsin(k*phii1)
4877           enddo
4878         else
4879           phii1=0.0d0
4880           ityp3=nthetyp+1
4881           do k=1,nsingle
4882             cosph2(k)=0.0d0
4883             sinph2(k)=0.0d0
4884           enddo
4885         endif
4886         ethetai=aa0thet(ityp1,ityp2,ityp3)
4887         do k=1,ndouble
4888           do l=1,k-1
4889             ccl=cosph1(l)*cosph2(k-l)
4890             ssl=sinph1(l)*sinph2(k-l)
4891             scl=sinph1(l)*cosph2(k-l)
4892             csl=cosph1(l)*sinph2(k-l)
4893             cosph1ph2(l,k)=ccl-ssl
4894             cosph1ph2(k,l)=ccl+ssl
4895             sinph1ph2(l,k)=scl+csl
4896             sinph1ph2(k,l)=scl-csl
4897           enddo
4898         enddo
4899         if (lprn) then
4900         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4901      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4902         write (iout,*) "coskt and sinkt"
4903         do k=1,nntheterm
4904           write (iout,*) k,coskt(k),sinkt(k)
4905         enddo
4906         endif
4907         do k=1,ntheterm
4908           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4909           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4910      &      *coskt(k)
4911           if (lprn)
4912      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4913      &     " ethetai",ethetai
4914         enddo
4915         if (lprn) then
4916         write (iout,*) "cosph and sinph"
4917         do k=1,nsingle
4918           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4919         enddo
4920         write (iout,*) "cosph1ph2 and sinph2ph2"
4921         do k=2,ndouble
4922           do l=1,k-1
4923             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4924      &         sinph1ph2(l,k),sinph1ph2(k,l)
4925           enddo
4926         enddo
4927         write(iout,*) "ethetai",ethetai
4928         endif
4929         do m=1,ntheterm2
4930           do k=1,nsingle
4931             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4932      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4933      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4934      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4935             ethetai=ethetai+sinkt(m)*aux
4936             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4937             dephii=dephii+k*sinkt(m)*(
4938      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4939      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4940             dephii1=dephii1+k*sinkt(m)*(
4941      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4942      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4943             if (lprn)
4944      &      write (iout,*) "m",m," k",k," bbthet",
4945      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4946      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4947      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4948      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4949           enddo
4950         enddo
4951         if (lprn)
4952      &  write(iout,*) "ethetai",ethetai
4953         do m=1,ntheterm3
4954           do k=2,ndouble
4955             do l=1,k-1
4956               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4957      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4958      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4959      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4960               ethetai=ethetai+sinkt(m)*aux
4961               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4962               dephii=dephii+l*sinkt(m)*(
4963      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4964      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4965      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4966      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4967               dephii1=dephii1+(k-l)*sinkt(m)*(
4968      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4969      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4970      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4971      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4972               if (lprn) then
4973               write (iout,*) "m",m," k",k," l",l," ffthet",
4974      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4975      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4976      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4977      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4978               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4979      &            cosph1ph2(k,l)*sinkt(m),
4980      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4981               endif
4982             enddo
4983           enddo
4984         enddo
4985 10      continue
4986         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4987      &   i,theta(i)*rad2deg,phii*rad2deg,
4988      &   phii1*rad2deg,ethetai
4989         becompon(itype(i-1))=becompon(itype(i-1))+ethetai
4990         etheta=etheta+ethetai
4991         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4992         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4993         gloc(nphi+i-2,icg)=wang*dethetai
4994       enddo
4995       return
4996       end
4997 #endif
4998 #ifdef CRYST_SC
4999 c-----------------------------------------------------------------------------
5000       subroutine esc(escloc)
5001 C Calculate the local energy of a side chain and its derivatives in the
5002 C corresponding virtual-bond valence angles THETA and the spherical angles
5003 C ALPHA and OMEGA.
5004       implicit real*8 (a-h,o-z)
5005       include 'DIMENSIONS'
5006       include 'COMMON.GEO'
5007       include 'COMMON.LOCAL'
5008       include 'COMMON.VAR'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.CHAIN'
5012       include 'COMMON.IOUNITS'
5013       include 'COMMON.NAMES'
5014       include 'COMMON.FFIELD'
5015       include 'COMMON.CONTROL'
5016       include "COMMON.ECOMPON"
5017       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5018      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5019       common /sccalc/ time11,time12,time112,theti,it,nlobit
5020       delta=0.02d0*pi
5021       escloc=0.0D0
5022 c     write (iout,'(a)') 'ESC'
5023       do i=loc_start,loc_end
5024         it=itype(i)
5025         if (it.eq.10 .or. it.eq.ntyp1 .or. itype(i-1).eq.ntyp1 .or.
5026      &    itype(i+1).eq.ntyp1) goto 1
5027         nlobit=nlob(it)
5028 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5029 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5030         theti=theta(i+1)-pipol
5031         x(1)=dtan(theti)
5032         x(2)=alph(i)
5033         x(3)=omeg(i)
5034
5035         if (x(2).gt.pi-delta) then
5036           xtemp(1)=x(1)
5037           xtemp(2)=pi-delta
5038           xtemp(3)=x(3)
5039           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5040           xtemp(2)=pi
5041           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5042           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5043      &        escloci,dersc(2))
5044           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5045      &        ddersc0(1),dersc(1))
5046           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5047      &        ddersc0(3),dersc(3))
5048           xtemp(2)=pi-delta
5049           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5050           xtemp(2)=pi
5051           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5052           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5053      &            dersc0(2),esclocbi,dersc02)
5054           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5055      &            dersc12,dersc01)
5056           call splinthet(x(2),0.5d0*delta,ss,ssd)
5057           dersc0(1)=dersc01
5058           dersc0(2)=dersc02
5059           dersc0(3)=0.0d0
5060           do k=1,3
5061             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5062           enddo
5063           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5064 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5065 c    &             esclocbi,ss,ssd
5066           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5067 c         escloci=esclocbi
5068 c         write (iout,*) escloci
5069         else if (x(2).lt.delta) then
5070           xtemp(1)=x(1)
5071           xtemp(2)=delta
5072           xtemp(3)=x(3)
5073           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5074           xtemp(2)=0.0d0
5075           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5076           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5077      &        escloci,dersc(2))
5078           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5079      &        ddersc0(1),dersc(1))
5080           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5081      &        ddersc0(3),dersc(3))
5082           xtemp(2)=delta
5083           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5084           xtemp(2)=0.0d0
5085           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5086           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5087      &            dersc0(2),esclocbi,dersc02)
5088           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5089      &            dersc12,dersc01)
5090           dersc0(1)=dersc01
5091           dersc0(2)=dersc02
5092           dersc0(3)=0.0d0
5093           call splinthet(x(2),0.5d0*delta,ss,ssd)
5094           do k=1,3
5095             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5096           enddo
5097           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5098 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5099 c    &             esclocbi,ss,ssd
5100           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5101 c         write (iout,*) escloci
5102         else
5103           call enesc(x,escloci,dersc,ddummy,.false.)
5104         endif
5105
5106         sccompon(it)=sccompon(it)+escloci
5107         escloc=escloc+escloci
5108         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5109      &     'escloc',i,escloci
5110 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5111
5112         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5113      &   wscloc*dersc(1)
5114         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5115         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5116     1   continue
5117       enddo
5118       return
5119       end
5120 C---------------------------------------------------------------------------
5121       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5122       implicit real*8 (a-h,o-z)
5123       include 'DIMENSIONS'
5124       include 'COMMON.GEO'
5125       include 'COMMON.LOCAL'
5126       include 'COMMON.IOUNITS'
5127       common /sccalc/ time11,time12,time112,theti,it,nlobit
5128       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5129       double precision contr(maxlob,-1:1)
5130       logical mixed
5131 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5132         escloc_i=0.0D0
5133         do j=1,3
5134           dersc(j)=0.0D0
5135           if (mixed) ddersc(j)=0.0d0
5136         enddo
5137         x3=x(3)
5138
5139 C Because of periodicity of the dependence of the SC energy in omega we have
5140 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5141 C To avoid underflows, first compute & store the exponents.
5142
5143         do iii=-1,1
5144
5145           x(3)=x3+iii*dwapi
5146
5147           do j=1,nlobit
5148             do k=1,3
5149               z(k)=x(k)-censc(k,j,it)
5150             enddo
5151             do k=1,3
5152               Axk=0.0D0
5153               do l=1,3
5154                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5155               enddo
5156               Ax(k,j,iii)=Axk
5157             enddo
5158             expfac=0.0D0
5159             do k=1,3
5160               expfac=expfac+Ax(k,j,iii)*z(k)
5161             enddo
5162             contr(j,iii)=expfac
5163           enddo ! j
5164
5165         enddo ! iii
5166
5167         x(3)=x3
5168 C As in the case of ebend, we want to avoid underflows in exponentiation and
5169 C subsequent NaNs and INFs in energy calculation.
5170 C Find the largest exponent
5171         emin=contr(1,-1)
5172         do iii=-1,1
5173           do j=1,nlobit
5174             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5175           enddo
5176         enddo
5177         emin=0.5D0*emin
5178 cd      print *,'it=',it,' emin=',emin
5179
5180 C Compute the contribution to SC energy and derivatives
5181         do iii=-1,1
5182
5183           do j=1,nlobit
5184 #ifdef OSF
5185             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5186             if(adexp.ne.adexp) adexp=1.0
5187             expfac=dexp(adexp)
5188 #else
5189             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5190 #endif
5191 cd          print *,'j=',j,' expfac=',expfac
5192             escloc_i=escloc_i+expfac
5193             do k=1,3
5194               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5195             enddo
5196             if (mixed) then
5197               do k=1,3,2
5198                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5199      &            +gaussc(k,2,j,it))*expfac
5200               enddo
5201             endif
5202           enddo
5203
5204         enddo ! iii
5205
5206         dersc(1)=dersc(1)/cos(theti)**2
5207         ddersc(1)=ddersc(1)/cos(theti)**2
5208         ddersc(3)=ddersc(3)
5209
5210         escloci=-(dlog(escloc_i)-emin)
5211         do j=1,3
5212           dersc(j)=dersc(j)/escloc_i
5213         enddo
5214         if (mixed) then
5215           do j=1,3,2
5216             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5217           enddo
5218         endif
5219       return
5220       end
5221 C------------------------------------------------------------------------------
5222       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5223       implicit real*8 (a-h,o-z)
5224       include 'DIMENSIONS'
5225       include 'COMMON.GEO'
5226       include 'COMMON.LOCAL'
5227       include 'COMMON.IOUNITS'
5228       common /sccalc/ time11,time12,time112,theti,it,nlobit
5229       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5230       double precision contr(maxlob)
5231       logical mixed
5232
5233       escloc_i=0.0D0
5234
5235       do j=1,3
5236         dersc(j)=0.0D0
5237       enddo
5238
5239       do j=1,nlobit
5240         do k=1,2
5241           z(k)=x(k)-censc(k,j,it)
5242         enddo
5243         z(3)=dwapi
5244         do k=1,3
5245           Axk=0.0D0
5246           do l=1,3
5247             Axk=Axk+gaussc(l,k,j,it)*z(l)
5248           enddo
5249           Ax(k,j)=Axk
5250         enddo
5251         expfac=0.0D0
5252         do k=1,3
5253           expfac=expfac+Ax(k,j)*z(k)
5254         enddo
5255         contr(j)=expfac
5256       enddo ! j
5257
5258 C As in the case of ebend, we want to avoid underflows in exponentiation and
5259 C subsequent NaNs and INFs in energy calculation.
5260 C Find the largest exponent
5261       emin=contr(1)
5262       do j=1,nlobit
5263         if (emin.gt.contr(j)) emin=contr(j)
5264       enddo
5265       emin=0.5D0*emin
5266
5267 C Compute the contribution to SC energy and derivatives
5268
5269       dersc12=0.0d0
5270       do j=1,nlobit
5271         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5272         escloc_i=escloc_i+expfac
5273         do k=1,2
5274           dersc(k)=dersc(k)+Ax(k,j)*expfac
5275         enddo
5276         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5277      &            +gaussc(1,2,j,it))*expfac
5278         dersc(3)=0.0d0
5279       enddo
5280
5281       dersc(1)=dersc(1)/cos(theti)**2
5282       dersc12=dersc12/cos(theti)**2
5283       escloci=-(dlog(escloc_i)-emin)
5284       do j=1,2
5285         dersc(j)=dersc(j)/escloc_i
5286       enddo
5287       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5288       return
5289       end
5290 #else
5291 c----------------------------------------------------------------------------------
5292       subroutine esc(escloc)
5293 C Calculate the local energy of a side chain and its derivatives in the
5294 C corresponding virtual-bond valence angles THETA and the spherical angles
5295 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5296 C added by Urszula Kozlowska. 07/11/2007
5297 C
5298       implicit real*8 (a-h,o-z)
5299       include 'DIMENSIONS'
5300       include 'COMMON.GEO'
5301       include 'COMMON.LOCAL'
5302       include 'COMMON.VAR'
5303       include 'COMMON.SCROT'
5304       include 'COMMON.INTERACT'
5305       include 'COMMON.DERIV'
5306       include 'COMMON.CHAIN'
5307       include 'COMMON.IOUNITS'
5308       include 'COMMON.NAMES'
5309       include 'COMMON.FFIELD'
5310       include 'COMMON.CONTROL'
5311       include 'COMMON.VECTORS'
5312       include "COMMON.ECOMPON"
5313       double precision x_prime(3),y_prime(3),z_prime(3)
5314      &    , sumene,dsc_i,dp2_i,x(65),
5315      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5316      &    de_dxx,de_dyy,de_dzz,de_dt
5317       double precision s1_t,s1_6_t,s2_t,s2_6_t
5318       double precision
5319      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5320      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5321      & dt_dCi(3),dt_dCi1(3)
5322       common /sccalc/ time11,time12,time112,theti,it,nlobit
5323       delta=0.02d0*pi
5324       escloc=0.0D0
5325       do i=loc_start,loc_end
5326         costtab(i+1) =dcos(theta(i+1))
5327         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5328         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5329         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5330         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5331         cosfac=dsqrt(cosfac2)
5332         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5333         sinfac=dsqrt(sinfac2)
5334         it=itype(i)
5335         if (it.eq.10 .or. it.eq.ntyp1 .or. itype(i-1).eq.ntyp1 .or.
5336      &      itype(i+1).eq.ntyp1) goto 1
5337 c
5338 C  Compute the axes of tghe local cartesian coordinates system; store in
5339 c   x_prime, y_prime and z_prime
5340 c
5341         do j=1,3
5342           x_prime(j) = 0.00
5343           y_prime(j) = 0.00
5344           z_prime(j) = 0.00
5345         enddo
5346 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5347 C     &   dc_norm(3,i+nres)
5348         do j = 1,3
5349           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5350           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5351         enddo
5352         do j = 1,3
5353           z_prime(j) = -uz(j,i-1)
5354         enddo
5355 c       write (2,*) "i",i
5356 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5357 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5358 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5359 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5360 c      & " xy",scalar(x_prime(1),y_prime(1)),
5361 c      & " xz",scalar(x_prime(1),z_prime(1)),
5362 c      & " yy",scalar(y_prime(1),y_prime(1)),
5363 c      & " yz",scalar(y_prime(1),z_prime(1)),
5364 c      & " zz",scalar(z_prime(1),z_prime(1))
5365 c
5366 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5367 C to local coordinate system. Store in xx, yy, zz.
5368 c
5369         xx=0.0d0
5370         yy=0.0d0
5371         zz=0.0d0
5372         do j = 1,3
5373           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5374           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5375           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5376         enddo
5377
5378         xxtab(i)=xx
5379         yytab(i)=yy
5380         zztab(i)=zz
5381 C
5382 C Compute the energy of the ith side cbain
5383 C
5384 c        write (2,*) "xx",xx," yy",yy," zz",zz
5385         it=itype(i)
5386         do j = 1,65
5387           x(j) = sc_parmin(j,it)
5388         enddo
5389 #ifdef CHECK_COORD
5390 Cc diagnostics - remove later
5391         xx1 = dcos(alph(2))
5392         yy1 = dsin(alph(2))*dcos(omeg(2))
5393         zz1 = -dsin(alph(2))*dsin(omeg(2))
5394         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5395      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5396      &    xx1,yy1,zz1
5397 C,"  --- ", xx_w,yy_w,zz_w
5398 c end diagnostics
5399 #endif
5400         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5401      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5402      &   + x(10)*yy*zz
5403         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5404      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5405      & + x(20)*yy*zz
5406         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5407      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5408      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5409      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5410      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5411      &  +x(40)*xx*yy*zz
5412         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5413      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5414      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5415      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5416      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5417      &  +x(60)*xx*yy*zz
5418         dsc_i   = 0.743d0+x(61)
5419         dp2_i   = 1.9d0+x(62)
5420         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5421      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5422         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5423      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5424         s1=(1+x(63))/(0.1d0 + dscp1)
5425         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5426         s2=(1+x(65))/(0.1d0 + dscp2)
5427         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5428         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5429      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5430 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5431 c     &   sumene4,
5432 c     &   dscp1,dscp2,sumene
5433 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5434         sccompon(it)=sccompon(it)+sumene
5435         escloc = escloc + sumene
5436 c        write (2,*) "i",i," escloc",sumene,escloc
5437 #ifdef DEBUG
5438 C
5439 C This section to check the numerical derivatives of the energy of ith side
5440 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5441 C #define DEBUG in the code to turn it on.
5442 C
5443         write (2,*) "sumene               =",sumene
5444         aincr=1.0d-7
5445         xxsave=xx
5446         xx=xx+aincr
5447         write (2,*) xx,yy,zz
5448         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5449         de_dxx_num=(sumenep-sumene)/aincr
5450         xx=xxsave
5451         write (2,*) "xx+ sumene from enesc=",sumenep
5452         yysave=yy
5453         yy=yy+aincr
5454         write (2,*) xx,yy,zz
5455         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5456         de_dyy_num=(sumenep-sumene)/aincr
5457         yy=yysave
5458         write (2,*) "yy+ sumene from enesc=",sumenep
5459         zzsave=zz
5460         zz=zz+aincr
5461         write (2,*) xx,yy,zz
5462         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5463         de_dzz_num=(sumenep-sumene)/aincr
5464         zz=zzsave
5465         write (2,*) "zz+ sumene from enesc=",sumenep
5466         costsave=cost2tab(i+1)
5467         sintsave=sint2tab(i+1)
5468         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5469         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5470         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5471         de_dt_num=(sumenep-sumene)/aincr
5472         write (2,*) " t+ sumene from enesc=",sumenep
5473         cost2tab(i+1)=costsave
5474         sint2tab(i+1)=sintsave
5475 C End of diagnostics section.
5476 #endif
5477 C
5478 C Compute the gradient of esc
5479 C
5480         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5481         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5482         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5483         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5484         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5485         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5486         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5487         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5488         pom1=(sumene3*sint2tab(i+1)+sumene1)
5489      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5490         pom2=(sumene4*cost2tab(i+1)+sumene2)
5491      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5492         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5493         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5494      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5495      &  +x(40)*yy*zz
5496         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5497         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5498      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5499      &  +x(60)*yy*zz
5500         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5501      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5502      &        +(pom1+pom2)*pom_dx
5503 #ifdef DEBUG
5504         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5505 #endif
5506 C
5507         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5508         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5509      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5510      &  +x(40)*xx*zz
5511         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5512         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5513      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5514      &  +x(59)*zz**2 +x(60)*xx*zz
5515         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5516      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5517      &        +(pom1-pom2)*pom_dy
5518 #ifdef DEBUG
5519         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5520 #endif
5521 C
5522         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5523      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5524      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5525      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5526      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5527      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5528      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5529      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5530 #ifdef DEBUG
5531         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5532 #endif
5533 C
5534         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5535      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5536      &  +pom1*pom_dt1+pom2*pom_dt2
5537 #ifdef DEBUG
5538         write(2,*), "de_dt = ", de_dt,de_dt_num
5539 #endif
5540 c
5541 C
5542        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5543        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5544        cosfac2xx=cosfac2*xx
5545        sinfac2yy=sinfac2*yy
5546        do k = 1,3
5547          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5548      &      vbld_inv(i+1)
5549          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5550      &      vbld_inv(i)
5551          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5552          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5553 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5554 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5555 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5556 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5557          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5558          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5559          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5560          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5561          dZZ_Ci1(k)=0.0d0
5562          dZZ_Ci(k)=0.0d0
5563          do j=1,3
5564            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5565            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5566          enddo
5567
5568          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5569          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5570          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5571 c
5572          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5573          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5574        enddo
5575
5576        do k=1,3
5577          dXX_Ctab(k,i)=dXX_Ci(k)
5578          dXX_C1tab(k,i)=dXX_Ci1(k)
5579          dYY_Ctab(k,i)=dYY_Ci(k)
5580          dYY_C1tab(k,i)=dYY_Ci1(k)
5581          dZZ_Ctab(k,i)=dZZ_Ci(k)
5582          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5583          dXX_XYZtab(k,i)=dXX_XYZ(k)
5584          dYY_XYZtab(k,i)=dYY_XYZ(k)
5585          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5586        enddo
5587
5588        do k = 1,3
5589 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5590 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5591 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5592 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5593 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5594 c     &    dt_dci(k)
5595 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5596 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5597          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5598      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5599          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5600      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5601          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5602      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5603        enddo
5604 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5605 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5606
5607 C to check gradient call subroutine check_grad
5608
5609     1 continue
5610       enddo
5611       return
5612       end
5613 c------------------------------------------------------------------------------
5614       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5615       implicit none
5616       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5617      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5618       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5619      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5620      &   + x(10)*yy*zz
5621       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5622      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5623      & + x(20)*yy*zz
5624       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5625      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5626      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5627      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5628      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5629      &  +x(40)*xx*yy*zz
5630       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5631      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5632      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5633      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5634      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5635      &  +x(60)*xx*yy*zz
5636       dsc_i   = 0.743d0+x(61)
5637       dp2_i   = 1.9d0+x(62)
5638       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5639      &          *(xx*cost2+yy*sint2))
5640       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5641      &          *(xx*cost2-yy*sint2))
5642       s1=(1+x(63))/(0.1d0 + dscp1)
5643       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5644       s2=(1+x(65))/(0.1d0 + dscp2)
5645       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5646       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5647      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5648       enesc=sumene
5649       return
5650       end
5651 #endif
5652 c------------------------------------------------------------------------------
5653       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5654 C
5655 C This procedure calculates two-body contact function g(rij) and its derivative:
5656 C
5657 C           eps0ij                                     !       x < -1
5658 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5659 C            0                                         !       x > 1
5660 C
5661 C where x=(rij-r0ij)/delta
5662 C
5663 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5664 C
5665       implicit none
5666       double precision rij,r0ij,eps0ij,fcont,fprimcont
5667       double precision x,x2,x4,delta
5668 c     delta=0.02D0*r0ij
5669 c      delta=0.2D0*r0ij
5670       x=(rij-r0ij)/delta
5671       if (x.lt.-1.0D0) then
5672         fcont=eps0ij
5673         fprimcont=0.0D0
5674       else if (x.le.1.0D0) then
5675         x2=x*x
5676         x4=x2*x2
5677         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5678         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5679       else
5680         fcont=0.0D0
5681         fprimcont=0.0D0
5682       endif
5683       return
5684       end
5685 c------------------------------------------------------------------------------
5686       subroutine splinthet(theti,delta,ss,ssder)
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'COMMON.VAR'
5690       include 'COMMON.GEO'
5691       thetup=pi-delta
5692       thetlow=delta
5693       if (theti.gt.pipol) then
5694         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5695       else
5696         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5697         ssder=-ssder
5698       endif
5699       return
5700       end
5701 c------------------------------------------------------------------------------
5702       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5703       implicit none
5704       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5705       double precision ksi,ksi2,ksi3,a1,a2,a3
5706       a1=fprim0*delta/(f1-f0)
5707       a2=3.0d0-2.0d0*a1
5708       a3=a1-2.0d0
5709       ksi=(x-x0)/delta
5710       ksi2=ksi*ksi
5711       ksi3=ksi2*ksi
5712       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5713       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5714       return
5715       end
5716 c------------------------------------------------------------------------------
5717       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5718       implicit none
5719       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5720       double precision ksi,ksi2,ksi3,a1,a2,a3
5721       ksi=(x-x0)/delta
5722       ksi2=ksi*ksi
5723       ksi3=ksi2*ksi
5724       a1=fprim0x*delta
5725       a2=3*(f1x-f0x)-2*fprim0x*delta
5726       a3=fprim0x*delta-2*(f1x-f0x)
5727       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5728       return
5729       end
5730 C-----------------------------------------------------------------------------
5731 #ifdef CRYST_TOR
5732 C-----------------------------------------------------------------------------
5733       subroutine etor(etors,edihcnstr)
5734       implicit real*8 (a-h,o-z)
5735       include 'DIMENSIONS'
5736       include 'COMMON.VAR'
5737       include 'COMMON.GEO'
5738       include 'COMMON.LOCAL'
5739       include 'COMMON.TORSION'
5740       include 'COMMON.INTERACT'
5741       include 'COMMON.DERIV'
5742       include 'COMMON.CHAIN'
5743       include 'COMMON.NAMES'
5744       include 'COMMON.IOUNITS'
5745       include 'COMMON.FFIELD'
5746       include 'COMMON.TORCNSTR'
5747       include 'COMMON.CONTROL'
5748       include "COMMON.ECOMPON"
5749       logical lprn
5750 C Set lprn=.true. for debugging
5751       lprn=.false.
5752 c      lprn=.true.
5753       etors=0.0D0
5754       do i=iphi_start,iphi_end
5755         if (itype(i-3).eq.ntyp1 .or. itype(i-2).eq.ntyp1 .or.
5756      &      itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5757         etors_ii=0.0D0
5758         itori=itortyp(itype(i-2))
5759         itori1=itortyp(itype(i-1))
5760         phii=phi(i)
5761         gloci=0.0D0
5762 C Proline-Proline pair is a special case...
5763         if (itori.eq.3 .and. itori1.eq.3) then
5764           if (phii.gt.-dwapi3) then
5765             cosphi=dcos(3*phii)
5766             fac=1.0D0/(1.0D0-cosphi)
5767             etorsi=v1(1,3,3)*fac
5768             etorsi=etorsi+etorsi
5769             etors=etors+etorsi-v1(1,3,3)
5770             torcompon(itype(i-2),itype(i-1))=
5771      &        torcompon(itype(i-2),itype(i-1))+etorsi
5772             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5773             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5774           endif
5775           do j=1,3
5776             v1ij=v1(j+1,itori,itori1)
5777             v2ij=v2(j+1,itori,itori1)
5778             cosphi=dcos(j*phii)
5779             sinphi=dsin(j*phii)
5780             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5781             if (energy_dec) etors_ii=etors_ii+
5782      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5783             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5784           enddo
5785         else
5786           do j=1,nterm_old
5787             v1ij=v1(j,itori,itori1)
5788             v2ij=v2(j,itori,itori1)
5789             cosphi=dcos(j*phii)
5790             sinphi=dsin(j*phii)
5791             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5792             torcompon(itype(i-2),itype(i-1))=
5793      &        torcompon(itype(i-2),itype(i-1))+v1ij*cosphi+v2ij*sinphi+
5794      &        dabs(v1ij)+dabs(v2ij)
5795             if (energy_dec) etors_ii=etors_ii+
5796      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5797             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5798           enddo
5799         endif
5800         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5801      &        'etor',i,etors_ii
5802         if (lprn)
5803      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5804      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5805      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5806         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5807         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5808       enddo
5809 ! 6/20/98 - dihedral angle constraints
5810       edihcnstr=0.0d0
5811       do i=1,ndih_constr
5812         itori=idih_constr(i)
5813         phii=phi(itori)
5814         difi=phii-phi0(i)
5815         if (difi.gt.drange(i)) then
5816           difi=difi-drange(i)
5817           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5818           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5819         else if (difi.lt.-drange(i)) then
5820           difi=difi+drange(i)
5821           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5822           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5823         endif
5824 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5825 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5826       enddo
5827 !      write (iout,*) 'edihcnstr',edihcnstr
5828       return
5829       end
5830 c------------------------------------------------------------------------------
5831       subroutine etor_d(etors_d)
5832       etors_d=0.0d0
5833       return
5834       end
5835 c----------------------------------------------------------------------------
5836 #else
5837       subroutine etor(etors,edihcnstr)
5838       implicit real*8 (a-h,o-z)
5839       include 'DIMENSIONS'
5840       include 'COMMON.VAR'
5841       include 'COMMON.GEO'
5842       include 'COMMON.LOCAL'
5843       include 'COMMON.TORSION'
5844       include 'COMMON.INTERACT'
5845       include 'COMMON.DERIV'
5846       include 'COMMON.CHAIN'
5847       include 'COMMON.NAMES'
5848       include 'COMMON.IOUNITS'
5849       include 'COMMON.FFIELD'
5850       include 'COMMON.TORCNSTR'
5851       include 'COMMON.CONTROL'
5852       include "COMMON.ECOMPON"
5853       logical lprn
5854 C Set lprn=.true. for debugging
5855       lprn=.false.
5856 c     lprn=.true.
5857       etors=0.0D0
5858       do i=iphi_start,iphi_end
5859         if (itype(i-3).eq.ntyp1 .or. itype(i-2).eq.ntyp1 .or.
5860      &      itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5861         etors_ii=0.0D0
5862         itori=itortyp(itype(i-2))
5863         itori1=itortyp(itype(i-1))
5864         phii=phi(i)
5865         gloci=0.0D0
5866 C Regular cosine and sine terms
5867         do j=1,nterm(itori,itori1)
5868           v1ij=v1(j,itori,itori1)
5869           v2ij=v2(j,itori,itori1)
5870           cosphi=dcos(j*phii)
5871           sinphi=dsin(j*phii)
5872           etors=etors+v1ij*cosphi+v2ij*sinphi
5873           torcompon(itype(i-2),itype(i-1))=
5874      &      torcompon(itype(i-2),itype(i-1))+v1ij*cosphi+v2ij*sinphi
5875           if (energy_dec) etors_ii=etors_ii+
5876      &                v1ij*cosphi+v2ij*sinphi
5877           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5878         enddo
5879 C Lorentz terms
5880 C                         v1
5881 C  E = SUM ----------------------------------- - v1
5882 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5883 C
5884         cosphi=dcos(0.5d0*phii)
5885         sinphi=dsin(0.5d0*phii)
5886         do j=1,nlor(itori,itori1)
5887           vl1ij=vlor1(j,itori,itori1)
5888           vl2ij=vlor2(j,itori,itori1)
5889           vl3ij=vlor3(j,itori,itori1)
5890           pom=vl2ij*cosphi+vl3ij*sinphi
5891           pom1=1.0d0/(pom*pom+1.0d0)
5892           etors=etors+vl1ij*pom1
5893           torcompon(itype(i-2),itype(i-1))=
5894      &      torcompon(itype(i-2),itype(i-1))+vl1ij*pom1
5895           if (energy_dec) etors_ii=etors_ii+
5896      &                vl1ij*pom1
5897           pom=-pom*pom1*pom1
5898           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5899         enddo
5900 C Subtract the constant term
5901         etors=etors-v0(itori,itori1)
5902         torcompon(itype(i-2),itype(i-1))=
5903      &      torcompon(itype(i-2),itype(i-1))-v0(itori,itori1)
5904           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5905      &         'etor',i,etors_ii-v0(itori,itori1)
5906         if (lprn)
5907      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5908      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5909      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5910         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5911 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5912       enddo
5913 ! 6/20/98 - dihedral angle constraints
5914       edihcnstr=0.0d0
5915 c      do i=1,ndih_constr
5916       do i=idihconstr_start,idihconstr_end
5917         itori=idih_constr(i)
5918         phii=phi(itori)
5919         difi=pinorm(phii-phi0(i))
5920         if (difi.gt.drange(i)) then
5921           difi=difi-drange(i)
5922           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5923           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5924         else if (difi.lt.-drange(i)) then
5925           difi=difi+drange(i)
5926           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5927           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5928         else
5929           difi=0.0
5930         endif
5931 c        write (iout,*) "gloci", gloc(i-3,icg)
5932 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5933 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5934 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5935       enddo
5936 cd       write (iout,*) 'edihcnstr',edihcnstr
5937       return
5938       end
5939 c----------------------------------------------------------------------------
5940       subroutine etor_d(etors_d)
5941 C 6/23/01 Compute double torsional energy
5942       implicit real*8 (a-h,o-z)
5943       include 'DIMENSIONS'
5944       include 'COMMON.VAR'
5945       include 'COMMON.GEO'
5946       include 'COMMON.LOCAL'
5947       include 'COMMON.TORSION'
5948       include 'COMMON.INTERACT'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.CHAIN'
5951       include 'COMMON.NAMES'
5952       include 'COMMON.IOUNITS'
5953       include 'COMMON.FFIELD'
5954       include 'COMMON.TORCNSTR'
5955       include "COMMON.ECOMPON"
5956       logical lprn
5957 C Set lprn=.true. for debugging
5958       lprn=.false.
5959 c     lprn=.true.
5960       etors_d=0.0D0
5961       do i=iphid_start,iphid_end
5962         if (itype(i-3).eq.ntyp1 .or. itype(i-2).eq.ntyp1 .or.
5963      &      itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1 .or.
5964      &      itype(i+1).eq.ntyp1) cycle
5965         itori=itortyp(itype(i-2))
5966         itori1=itortyp(itype(i-1))
5967         itori2=itortyp(itype(i))
5968         phii=phi(i)
5969         phii1=phi(i+1)
5970         gloci1=0.0D0
5971         gloci2=0.0D0
5972         do j=1,ntermd_1(itori,itori1,itori2)
5973           v1cij=v1c(1,j,itori,itori1,itori2)
5974           v1sij=v1s(1,j,itori,itori1,itori2)
5975           v2cij=v1c(2,j,itori,itori1,itori2)
5976           v2sij=v1s(2,j,itori,itori1,itori2)
5977           cosphi1=dcos(j*phii)
5978           sinphi1=dsin(j*phii)
5979           cosphi2=dcos(j*phii1)
5980           sinphi2=dsin(j*phii1)
5981           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5982      &     v2cij*cosphi2+v2sij*sinphi2
5983           tordcompon(itype(i-1))=tordcompon(itype(i-1))+
5984      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5985           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5986           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5987         enddo
5988         do k=2,ntermd_2(itori,itori1,itori2)
5989           do l=1,k-1
5990             v1cdij = v2c(k,l,itori,itori1,itori2)
5991             v2cdij = v2c(l,k,itori,itori1,itori2)
5992             v1sdij = v2s(k,l,itori,itori1,itori2)
5993             v2sdij = v2s(l,k,itori,itori1,itori2)
5994             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5995             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5996             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5997             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5998             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5999      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6000             tordcompon(itype(i-1))=tordcompon(itype(i-1))+
6001      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6002      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6003             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6004      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6005             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6006      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6007           enddo
6008         enddo
6009         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6010         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6011 c        write (iout,*) "gloci", gloc(i-3,icg)
6012       enddo
6013       return
6014       end
6015 #endif
6016 c------------------------------------------------------------------------------
6017       subroutine eback_sc_corr(esccor)
6018 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6019 c        conformational states; temporarily implemented as differences
6020 c        between UNRES torsional potentials (dependent on three types of
6021 c        residues) and the torsional potentials dependent on all 20 types
6022 c        of residues computed from AM1  energy surfaces of terminally-blocked
6023 c        amino-acid residues.
6024       implicit real*8 (a-h,o-z)
6025       include 'DIMENSIONS'
6026       include 'COMMON.VAR'
6027       include 'COMMON.GEO'
6028       include 'COMMON.LOCAL'
6029       include 'COMMON.TORSION'
6030       include 'COMMON.SCCOR'
6031       include 'COMMON.INTERACT'
6032       include 'COMMON.DERIV'
6033       include 'COMMON.CHAIN'
6034       include 'COMMON.NAMES'
6035       include 'COMMON.IOUNITS'
6036       include 'COMMON.FFIELD'
6037       include 'COMMON.CONTROL'
6038       include 'COMMON.ECOMPON'
6039       logical lprn
6040 C Set lprn=.true. for debugging
6041       lprn=.false.
6042 c      lprn=.true.
6043 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6044       esccor=0.0D0
6045       do i=itau_start,itau_end
6046         esccor_ii=0.0D0
6047         isccori=isccortyp(itype(i-2))
6048         isccori1=isccortyp(itype(i-1))
6049         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1) cycle
6050         phii=phi(i)
6051 cccc  Added 9 May 2012
6052 cc Tauangle is torsional engle depending on the value of first digit
6053 c(see comment below)
6054 cc Omicron is flat angle depending on the value of first digit
6055 c(see comment below)
6056
6057
6058         do intertyp=1,3 !intertyp
6059 cc Added 09 May 2012 (Adasko)
6060 cc  Intertyp means interaction type of backbone mainchain correlation:
6061 c   1 = SC...Ca...Ca...Ca
6062 c   2 = Ca...Ca...Ca...SC
6063 c   3 = SC...Ca...Ca...SCi
6064         gloci=0.0D0
6065         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6066      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6067      &      (itype(i-1).eq.ntyp1)))
6068      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6069      &     .or.(itype(i-2).eq.ntyp1)))
6070      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6071      &      (itype(i-1).eq.ntyp1)))) cycle
6072         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6073         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6074      & cycle
6075         do j=1,nterm_sccor(isccori,isccori1)
6076           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6077           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6078           cosphi=dcos(j*tauangle(intertyp,i))
6079           sinphi=dsin(j*tauangle(intertyp,i))
6080           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6081           sccorcompon(itype(i-2),itype(i-1))=
6082      &     sccorcompon(itype(i-2),itype(i-1))+v1ij*cosphi+v2ij*sinphi
6083           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6084         enddo
6085         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6086 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6087 c     &gloc_sc(intertyp,i-3,icg)
6088         if (lprn)
6089      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6090      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6091      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6092      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6093         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6094        enddo !intertyp
6095       enddo
6096 c        do i=1,nres
6097 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6098 c        enddo
6099       return
6100       end
6101 c----------------------------------------------------------------------------
6102       subroutine multibody(ecorr)
6103 C This subroutine calculates multi-body contributions to energy following
6104 C the idea of Skolnick et al. If side chains I and J make a contact and
6105 C at the same time side chains I+1 and J+1 make a contact, an extra
6106 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6107       implicit real*8 (a-h,o-z)
6108       include 'DIMENSIONS'
6109       include 'COMMON.IOUNITS'
6110       include 'COMMON.DERIV'
6111       include 'COMMON.INTERACT'
6112       include 'COMMON.CONTACTS'
6113       double precision gx(3),gx1(3)
6114       logical lprn
6115
6116 C Set lprn=.true. for debugging
6117       lprn=.false.
6118
6119       if (lprn) then
6120         write (iout,'(a)') 'Contact function values:'
6121         do i=nnt,nct-2
6122           write (iout,'(i2,20(1x,i2,f10.5))')
6123      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6124         enddo
6125       endif
6126       ecorr=0.0D0
6127       do i=nnt,nct
6128         do j=1,3
6129           gradcorr(j,i)=0.0D0
6130           gradxorr(j,i)=0.0D0
6131         enddo
6132       enddo
6133       do i=nnt,nct-2
6134
6135         DO ISHIFT = 3,4
6136
6137         i1=i+ishift
6138         num_conti=num_cont(i)
6139         num_conti1=num_cont(i1)
6140         do jj=1,num_conti
6141           j=jcont(jj,i)
6142           do kk=1,num_conti1
6143             j1=jcont(kk,i1)
6144             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6145 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6146 cd   &                   ' ishift=',ishift
6147 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6148 C The system gains extra energy.
6149               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6150             endif   ! j1==j+-ishift
6151           enddo     ! kk
6152         enddo       ! jj
6153
6154         ENDDO ! ISHIFT
6155
6156       enddo         ! i
6157       return
6158       end
6159 c------------------------------------------------------------------------------
6160       double precision function esccorr(i,j,k,l,jj,kk)
6161       implicit real*8 (a-h,o-z)
6162       include 'DIMENSIONS'
6163       include 'COMMON.IOUNITS'
6164       include 'COMMON.DERIV'
6165       include 'COMMON.INTERACT'
6166       include 'COMMON.CONTACTS'
6167       double precision gx(3),gx1(3)
6168       logical lprn
6169       lprn=.false.
6170       eij=facont(jj,i)
6171       ekl=facont(kk,k)
6172 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6173 C Calculate the multi-body contribution to energy.
6174 C Calculate multi-body contributions to the gradient.
6175 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6176 cd   & k,l,(gacont(m,kk,k),m=1,3)
6177       do m=1,3
6178         gx(m) =ekl*gacont(m,jj,i)
6179         gx1(m)=eij*gacont(m,kk,k)
6180         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6181         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6182         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6183         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6184       enddo
6185       do m=i,j-1
6186         do ll=1,3
6187           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6188         enddo
6189       enddo
6190       do m=k,l-1
6191         do ll=1,3
6192           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6193         enddo
6194       enddo
6195       esccorr=-eij*ekl
6196       return
6197       end
6198 c------------------------------------------------------------------------------
6199       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6200 C This subroutine calculates multi-body contributions to hydrogen-bonding
6201       implicit real*8 (a-h,o-z)
6202       include 'DIMENSIONS'
6203       include 'COMMON.IOUNITS'
6204 #ifdef MPI
6205       include "mpif.h"
6206       parameter (max_cont=maxconts)
6207       parameter (max_dim=26)
6208       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6209       double precision zapas(max_dim,maxconts,max_fg_procs),
6210      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6211       common /przechowalnia/ zapas
6212       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6213      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6214 #endif
6215       include 'COMMON.SETUP'
6216       include 'COMMON.FFIELD'
6217       include 'COMMON.DERIV'
6218       include 'COMMON.INTERACT'
6219       include 'COMMON.CONTACTS'
6220       include 'COMMON.CONTROL'
6221       include 'COMMON.LOCAL'
6222       double precision gx(3),gx1(3),time00
6223       logical lprn,ldone
6224
6225 C Set lprn=.true. for debugging
6226       lprn=.false.
6227 #ifdef MPI
6228       n_corr=0
6229       n_corr1=0
6230       if (nfgtasks.le.1) goto 30
6231       if (lprn) then
6232         write (iout,'(a)') 'Contact function values before RECEIVE:'
6233         do i=nnt,nct-2
6234           write (iout,'(2i3,50(1x,i2,f5.2))')
6235      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6236      &    j=1,num_cont_hb(i))
6237         enddo
6238       endif
6239       call flush(iout)
6240       do i=1,ntask_cont_from
6241         ncont_recv(i)=0
6242       enddo
6243       do i=1,ntask_cont_to
6244         ncont_sent(i)=0
6245       enddo
6246 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6247 c     & ntask_cont_to
6248 C Make the list of contacts to send to send to other procesors
6249 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6250 c      call flush(iout)
6251       do i=iturn3_start,iturn3_end
6252 c        write (iout,*) "make contact list turn3",i," num_cont",
6253 c     &    num_cont_hb(i)
6254         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6255       enddo
6256       do i=iturn4_start,iturn4_end
6257 c        write (iout,*) "make contact list turn4",i," num_cont",
6258 c     &   num_cont_hb(i)
6259         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6260       enddo
6261       do ii=1,nat_sent
6262         i=iat_sent(ii)
6263 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6264 c     &    num_cont_hb(i)
6265         do j=1,num_cont_hb(i)
6266         do k=1,4
6267           jjc=jcont_hb(j,i)
6268           iproc=iint_sent_local(k,jjc,ii)
6269 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6270           if (iproc.gt.0) then
6271             ncont_sent(iproc)=ncont_sent(iproc)+1
6272             nn=ncont_sent(iproc)
6273             zapas(1,nn,iproc)=i
6274             zapas(2,nn,iproc)=jjc
6275             zapas(3,nn,iproc)=facont_hb(j,i)
6276             zapas(4,nn,iproc)=ees0p(j,i)
6277             zapas(5,nn,iproc)=ees0m(j,i)
6278             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6279             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6280             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6281             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6282             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6283             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6284             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6285             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6286             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6287             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6288             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6289             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6290             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6291             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6292             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6293             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6294             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6295             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6296             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6297             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6298             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6299           endif
6300         enddo
6301         enddo
6302       enddo
6303       if (lprn) then
6304       write (iout,*)
6305      &  "Numbers of contacts to be sent to other processors",
6306      &  (ncont_sent(i),i=1,ntask_cont_to)
6307       write (iout,*) "Contacts sent"
6308       do ii=1,ntask_cont_to
6309         nn=ncont_sent(ii)
6310         iproc=itask_cont_to(ii)
6311         write (iout,*) nn," contacts to processor",iproc,
6312      &   " of CONT_TO_COMM group"
6313         do i=1,nn
6314           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6315         enddo
6316       enddo
6317       call flush(iout)
6318       endif
6319       CorrelType=477
6320       CorrelID=fg_rank+1
6321       CorrelType1=478
6322       CorrelID1=nfgtasks+fg_rank+1
6323       ireq=0
6324 C Receive the numbers of needed contacts from other processors
6325       do ii=1,ntask_cont_from
6326         iproc=itask_cont_from(ii)
6327         ireq=ireq+1
6328         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6329      &    FG_COMM,req(ireq),IERR)
6330       enddo
6331 c      write (iout,*) "IRECV ended"
6332 c      call flush(iout)
6333 C Send the number of contacts needed by other processors
6334       do ii=1,ntask_cont_to
6335         iproc=itask_cont_to(ii)
6336         ireq=ireq+1
6337         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6338      &    FG_COMM,req(ireq),IERR)
6339       enddo
6340 c      write (iout,*) "ISEND ended"
6341 c      write (iout,*) "number of requests (nn)",ireq
6342       call flush(iout)
6343       if (ireq.gt.0)
6344      &  call MPI_Waitall(ireq,req,status_array,ierr)
6345 c      write (iout,*)
6346 c     &  "Numbers of contacts to be received from other processors",
6347 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6348 c      call flush(iout)
6349 C Receive contacts
6350       ireq=0
6351       do ii=1,ntask_cont_from
6352         iproc=itask_cont_from(ii)
6353         nn=ncont_recv(ii)
6354 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6355 c     &   " of CONT_TO_COMM group"
6356         call flush(iout)
6357         if (nn.gt.0) then
6358           ireq=ireq+1
6359           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6360      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6361 c          write (iout,*) "ireq,req",ireq,req(ireq)
6362         endif
6363       enddo
6364 C Send the contacts to processors that need them
6365       do ii=1,ntask_cont_to
6366         iproc=itask_cont_to(ii)
6367         nn=ncont_sent(ii)
6368 c        write (iout,*) nn," contacts to processor",iproc,
6369 c     &   " of CONT_TO_COMM group"
6370         if (nn.gt.0) then
6371           ireq=ireq+1
6372           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6373      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6374 c          write (iout,*) "ireq,req",ireq,req(ireq)
6375 c          do i=1,nn
6376 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6377 c          enddo
6378         endif
6379       enddo
6380 c      write (iout,*) "number of requests (contacts)",ireq
6381 c      write (iout,*) "req",(req(i),i=1,4)
6382 c      call flush(iout)
6383       if (ireq.gt.0)
6384      & call MPI_Waitall(ireq,req,status_array,ierr)
6385       do iii=1,ntask_cont_from
6386         iproc=itask_cont_from(iii)
6387         nn=ncont_recv(iii)
6388         if (lprn) then
6389         write (iout,*) "Received",nn," contacts from processor",iproc,
6390      &   " of CONT_FROM_COMM group"
6391         call flush(iout)
6392         do i=1,nn
6393           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6394         enddo
6395         call flush(iout)
6396         endif
6397         do i=1,nn
6398           ii=zapas_recv(1,i,iii)
6399 c Flag the received contacts to prevent double-counting
6400           jj=-zapas_recv(2,i,iii)
6401 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6402 c          call flush(iout)
6403           nnn=num_cont_hb(ii)+1
6404           num_cont_hb(ii)=nnn
6405           jcont_hb(nnn,ii)=jj
6406           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6407           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6408           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6409           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6410           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6411           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6412           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6413           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6414           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6415           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6416           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6417           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6418           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6419           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6420           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6421           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6422           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6423           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6424           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6425           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6426           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6427           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6428           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6429           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6430         enddo
6431       enddo
6432       call flush(iout)
6433       if (lprn) then
6434         write (iout,'(a)') 'Contact function values after receive:'
6435         do i=nnt,nct-2
6436           write (iout,'(2i3,50(1x,i3,f5.2))')
6437      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6438      &    j=1,num_cont_hb(i))
6439         enddo
6440         call flush(iout)
6441       endif
6442    30 continue
6443 #endif
6444       if (lprn) then
6445         write (iout,'(a)') 'Contact function values:'
6446         do i=nnt,nct-2
6447           write (iout,'(2i3,50(1x,i3,f5.2))')
6448      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6449      &    j=1,num_cont_hb(i))
6450         enddo
6451       endif
6452       ecorr=0.0D0
6453 C Remove the loop below after debugging !!!
6454       do i=nnt,nct
6455         do j=1,3
6456           gradcorr(j,i)=0.0D0
6457           gradxorr(j,i)=0.0D0
6458         enddo
6459       enddo
6460 C Calculate the local-electrostatic correlation terms
6461       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6462         i1=i+1
6463         num_conti=num_cont_hb(i)
6464         num_conti1=num_cont_hb(i+1)
6465         do jj=1,num_conti
6466           j=jcont_hb(jj,i)
6467           jp=iabs(j)
6468           do kk=1,num_conti1
6469             j1=jcont_hb(kk,i1)
6470             jp1=iabs(j1)
6471 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6472 c     &         ' jj=',jj,' kk=',kk
6473             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6474      &          .or. j.lt.0 .and. j1.gt.0) .and.
6475      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6476 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6477 C The system gains extra energy.
6478               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6480      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6481               n_corr=n_corr+1
6482             else if (j1.eq.j) then
6483 C Contacts I-J and I-(J+1) occur simultaneously.
6484 C The system loses extra energy.
6485 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6486             endif
6487           enddo ! kk
6488           do kk=1,num_conti
6489             j1=jcont_hb(kk,i)
6490 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6491 c    &         ' jj=',jj,' kk=',kk
6492             if (j1.eq.j+1) then
6493 C Contacts I-J and (I+1)-J occur simultaneously.
6494 C The system loses extra energy.
6495 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6496             endif ! j1==j+1
6497           enddo ! kk
6498         enddo ! jj
6499       enddo ! i
6500       return
6501       end
6502 c------------------------------------------------------------------------------
6503       subroutine add_hb_contact(ii,jj,itask)
6504       implicit real*8 (a-h,o-z)
6505       include "DIMENSIONS"
6506       include "COMMON.IOUNITS"
6507       integer max_cont
6508       integer max_dim
6509       parameter (max_cont=maxconts)
6510       parameter (max_dim=26)
6511       include "COMMON.CONTACTS"
6512       double precision zapas(max_dim,maxconts,max_fg_procs),
6513      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6514       common /przechowalnia/ zapas
6515       integer i,j,ii,jj,iproc,itask(4),nn
6516 c      write (iout,*) "itask",itask
6517       do i=1,2
6518         iproc=itask(i)
6519         if (iproc.gt.0) then
6520           do j=1,num_cont_hb(ii)
6521             jjc=jcont_hb(j,ii)
6522 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6523             if (jjc.eq.jj) then
6524               ncont_sent(iproc)=ncont_sent(iproc)+1
6525               nn=ncont_sent(iproc)
6526               zapas(1,nn,iproc)=ii
6527               zapas(2,nn,iproc)=jjc
6528               zapas(3,nn,iproc)=facont_hb(j,ii)
6529               zapas(4,nn,iproc)=ees0p(j,ii)
6530               zapas(5,nn,iproc)=ees0m(j,ii)
6531               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6532               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6533               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6534               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6535               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6536               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6537               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6538               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6539               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6540               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6541               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6542               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6543               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6544               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6545               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6546               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6547               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6548               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6549               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6550               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6551               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6552               exit
6553             endif
6554           enddo
6555         endif
6556       enddo
6557       return
6558       end
6559 c------------------------------------------------------------------------------
6560       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6561      &  n_corr1)
6562 C This subroutine calculates multi-body contributions to hydrogen-bonding
6563       implicit real*8 (a-h,o-z)
6564       include 'DIMENSIONS'
6565       include 'COMMON.IOUNITS'
6566 #ifdef MPI
6567       include "mpif.h"
6568       parameter (max_cont=maxconts)
6569       parameter (max_dim=70)
6570       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6571       double precision zapas(max_dim,maxconts,max_fg_procs),
6572      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6573       common /przechowalnia/ zapas
6574       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6575      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6576 #endif
6577       include 'COMMON.SETUP'
6578       include 'COMMON.FFIELD'
6579       include 'COMMON.DERIV'
6580       include 'COMMON.LOCAL'
6581       include 'COMMON.INTERACT'
6582       include 'COMMON.CONTACTS'
6583       include 'COMMON.CHAIN'
6584       include 'COMMON.CONTROL'
6585       double precision gx(3),gx1(3)
6586       integer num_cont_hb_old(maxres)
6587       logical lprn,ldone
6588       double precision eello4,eello5,eelo6,eello_turn6
6589       external eello4,eello5,eello6,eello_turn6
6590 C Set lprn=.true. for debugging
6591       lprn=.false.
6592       eturn6=0.0d0
6593 #ifdef MPI
6594       do i=1,nres
6595         num_cont_hb_old(i)=num_cont_hb(i)
6596       enddo
6597       n_corr=0
6598       n_corr1=0
6599       if (nfgtasks.le.1) goto 30
6600       if (lprn) then
6601         write (iout,'(a)') 'Contact function values before RECEIVE:'
6602         do i=nnt,nct-2
6603           write (iout,'(2i3,50(1x,i2,f5.2))')
6604      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6605      &    j=1,num_cont_hb(i))
6606         enddo
6607       endif
6608       call flush(iout)
6609       do i=1,ntask_cont_from
6610         ncont_recv(i)=0
6611       enddo
6612       do i=1,ntask_cont_to
6613         ncont_sent(i)=0
6614       enddo
6615 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6616 c     & ntask_cont_to
6617 C Make the list of contacts to send to send to other procesors
6618       do i=iturn3_start,iturn3_end
6619 c        write (iout,*) "make contact list turn3",i," num_cont",
6620 c     &    num_cont_hb(i)
6621         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6622       enddo
6623       do i=iturn4_start,iturn4_end
6624 c        write (iout,*) "make contact list turn4",i," num_cont",
6625 c     &   num_cont_hb(i)
6626         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6627       enddo
6628       do ii=1,nat_sent
6629         i=iat_sent(ii)
6630 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6631 c     &    num_cont_hb(i)
6632         do j=1,num_cont_hb(i)
6633         do k=1,4
6634           jjc=jcont_hb(j,i)
6635           iproc=iint_sent_local(k,jjc,ii)
6636 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6637           if (iproc.ne.0) then
6638             ncont_sent(iproc)=ncont_sent(iproc)+1
6639             nn=ncont_sent(iproc)
6640             zapas(1,nn,iproc)=i
6641             zapas(2,nn,iproc)=jjc
6642             zapas(3,nn,iproc)=d_cont(j,i)
6643             ind=3
6644             do kk=1,3
6645               ind=ind+1
6646               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6647             enddo
6648             do kk=1,2
6649               do ll=1,2
6650                 ind=ind+1
6651                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6652               enddo
6653             enddo
6654             do jj=1,5
6655               do kk=1,3
6656                 do ll=1,2
6657                   do mm=1,2
6658                     ind=ind+1
6659                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6660                   enddo
6661                 enddo
6662               enddo
6663             enddo
6664           endif
6665         enddo
6666         enddo
6667       enddo
6668       if (lprn) then
6669       write (iout,*)
6670      &  "Numbers of contacts to be sent to other processors",
6671      &  (ncont_sent(i),i=1,ntask_cont_to)
6672       write (iout,*) "Contacts sent"
6673       do ii=1,ntask_cont_to
6674         nn=ncont_sent(ii)
6675         iproc=itask_cont_to(ii)
6676         write (iout,*) nn," contacts to processor",iproc,
6677      &   " of CONT_TO_COMM group"
6678         do i=1,nn
6679           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6680         enddo
6681       enddo
6682       call flush(iout)
6683       endif
6684       CorrelType=477
6685       CorrelID=fg_rank+1
6686       CorrelType1=478
6687       CorrelID1=nfgtasks+fg_rank+1
6688       ireq=0
6689 C Receive the numbers of needed contacts from other processors
6690       do ii=1,ntask_cont_from
6691         iproc=itask_cont_from(ii)
6692         ireq=ireq+1
6693         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6694      &    FG_COMM,req(ireq),IERR)
6695       enddo
6696 c      write (iout,*) "IRECV ended"
6697 c      call flush(iout)
6698 C Send the number of contacts needed by other processors
6699       do ii=1,ntask_cont_to
6700         iproc=itask_cont_to(ii)
6701         ireq=ireq+1
6702         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6703      &    FG_COMM,req(ireq),IERR)
6704       enddo
6705 c      write (iout,*) "ISEND ended"
6706 c      write (iout,*) "number of requests (nn)",ireq
6707       call flush(iout)
6708       if (ireq.gt.0)
6709      &  call MPI_Waitall(ireq,req,status_array,ierr)
6710 c      write (iout,*)
6711 c     &  "Numbers of contacts to be received from other processors",
6712 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6713 c      call flush(iout)
6714 C Receive contacts
6715       ireq=0
6716       do ii=1,ntask_cont_from
6717         iproc=itask_cont_from(ii)
6718         nn=ncont_recv(ii)
6719 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6720 c     &   " of CONT_TO_COMM group"
6721         call flush(iout)
6722         if (nn.gt.0) then
6723           ireq=ireq+1
6724           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6725      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6726 c          write (iout,*) "ireq,req",ireq,req(ireq)
6727         endif
6728       enddo
6729 C Send the contacts to processors that need them
6730       do ii=1,ntask_cont_to
6731         iproc=itask_cont_to(ii)
6732         nn=ncont_sent(ii)
6733 c        write (iout,*) nn," contacts to processor",iproc,
6734 c     &   " of CONT_TO_COMM group"
6735         if (nn.gt.0) then
6736           ireq=ireq+1
6737           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6738      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6739 c          write (iout,*) "ireq,req",ireq,req(ireq)
6740 c          do i=1,nn
6741 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6742 c          enddo
6743         endif
6744       enddo
6745 c      write (iout,*) "number of requests (contacts)",ireq
6746 c      write (iout,*) "req",(req(i),i=1,4)
6747 c      call flush(iout)
6748       if (ireq.gt.0)
6749      & call MPI_Waitall(ireq,req,status_array,ierr)
6750       do iii=1,ntask_cont_from
6751         iproc=itask_cont_from(iii)
6752         nn=ncont_recv(iii)
6753         if (lprn) then
6754         write (iout,*) "Received",nn," contacts from processor",iproc,
6755      &   " of CONT_FROM_COMM group"
6756         call flush(iout)
6757         do i=1,nn
6758           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6759         enddo
6760         call flush(iout)
6761         endif
6762         do i=1,nn
6763           ii=zapas_recv(1,i,iii)
6764 c Flag the received contacts to prevent double-counting
6765           jj=-zapas_recv(2,i,iii)
6766 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6767 c          call flush(iout)
6768           nnn=num_cont_hb(ii)+1
6769           num_cont_hb(ii)=nnn
6770           jcont_hb(nnn,ii)=jj
6771           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6772           ind=3
6773           do kk=1,3
6774             ind=ind+1
6775             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6776           enddo
6777           do kk=1,2
6778             do ll=1,2
6779               ind=ind+1
6780               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6781             enddo
6782           enddo
6783           do jj=1,5
6784             do kk=1,3
6785               do ll=1,2
6786                 do mm=1,2
6787                   ind=ind+1
6788                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6789                 enddo
6790               enddo
6791             enddo
6792           enddo
6793         enddo
6794       enddo
6795       call flush(iout)
6796       if (lprn) then
6797         write (iout,'(a)') 'Contact function values after receive:'
6798         do i=nnt,nct-2
6799           write (iout,'(2i3,50(1x,i3,5f6.3))')
6800      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6801      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6802         enddo
6803         call flush(iout)
6804       endif
6805    30 continue
6806 #endif
6807       if (lprn) then
6808         write (iout,'(a)') 'Contact function values:'
6809         do i=nnt,nct-2
6810           write (iout,'(2i3,50(1x,i2,5f6.3))')
6811      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6812      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6813         enddo
6814       endif
6815       ecorr=0.0D0
6816       ecorr5=0.0d0
6817       ecorr6=0.0d0
6818 C Remove the loop below after debugging !!!
6819       do i=nnt,nct
6820         do j=1,3
6821           gradcorr(j,i)=0.0D0
6822           gradxorr(j,i)=0.0D0
6823         enddo
6824       enddo
6825 C Calculate the dipole-dipole interaction energies
6826       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6827       do i=iatel_s,iatel_e+1
6828         num_conti=num_cont_hb(i)
6829         do jj=1,num_conti
6830           j=jcont_hb(jj,i)
6831 #ifdef MOMENT
6832           call dipole(i,j,jj)
6833 #endif
6834         enddo
6835       enddo
6836       endif
6837 C Calculate the local-electrostatic correlation terms
6838 c                write (iout,*) "gradcorr5 in eello5 before loop"
6839 c                do iii=1,nres
6840 c                  write (iout,'(i5,3f10.5)')
6841 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6842 c                enddo
6843       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6844 c        write (iout,*) "corr loop i",i
6845         i1=i+1
6846         num_conti=num_cont_hb(i)
6847         num_conti1=num_cont_hb(i+1)
6848         do jj=1,num_conti
6849           j=jcont_hb(jj,i)
6850           jp=iabs(j)
6851           do kk=1,num_conti1
6852             j1=jcont_hb(kk,i1)
6853             jp1=iabs(j1)
6854 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6855 c     &         ' jj=',jj,' kk=',kk
6856 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6857             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6858      &          .or. j.lt.0 .and. j1.gt.0) .and.
6859      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6860 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6861 C The system gains extra energy.
6862               n_corr=n_corr+1
6863               sqd1=dsqrt(d_cont(jj,i))
6864               sqd2=dsqrt(d_cont(kk,i1))
6865               sred_geom = sqd1*sqd2
6866               IF (sred_geom.lt.cutoff_corr) THEN
6867                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6868      &            ekont,fprimcont)
6869 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6870 cd     &         ' jj=',jj,' kk=',kk
6871                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6872                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6873                 do l=1,3
6874                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6875                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6876                 enddo
6877                 n_corr1=n_corr1+1
6878 cd               write (iout,*) 'sred_geom=',sred_geom,
6879 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6880 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6881 cd               write (iout,*) "g_contij",g_contij
6882 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6883 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6884                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6885                 if (wcorr4.gt.0.0d0)
6886      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6887                   if (energy_dec.and.wcorr4.gt.0.0d0)
6888      1                 write (iout,'(a6,4i5,0pf7.3)')
6889      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6890 c                write (iout,*) "gradcorr5 before eello5"
6891 c                do iii=1,nres
6892 c                  write (iout,'(i5,3f10.5)')
6893 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6894 c                enddo
6895                 if (wcorr5.gt.0.0d0)
6896      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6897 c                write (iout,*) "gradcorr5 after eello5"
6898 c                do iii=1,nres
6899 c                  write (iout,'(i5,3f10.5)')
6900 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6901 c                enddo
6902                   if (energy_dec.and.wcorr5.gt.0.0d0)
6903      1                 write (iout,'(a6,4i5,0pf7.3)')
6904      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6905 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6906 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6907                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6908      &               .or. wturn6.eq.0.0d0))then
6909 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6910                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6911                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6912      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6913 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6914 cd     &            'ecorr6=',ecorr6
6915 cd                write (iout,'(4e15.5)') sred_geom,
6916 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6917 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6918 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6919                 else if (wturn6.gt.0.0d0
6920      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6921 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6922                   eturn6=eturn6+eello_turn6(i,jj,kk)
6923                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6924      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6925 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6926                 endif
6927               ENDIF
6928 1111          continue
6929             endif
6930           enddo ! kk
6931         enddo ! jj
6932       enddo ! i
6933       do i=1,nres
6934         num_cont_hb(i)=num_cont_hb_old(i)
6935       enddo
6936 c                write (iout,*) "gradcorr5 in eello5"
6937 c                do iii=1,nres
6938 c                  write (iout,'(i5,3f10.5)')
6939 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6940 c                enddo
6941       return
6942       end
6943 c------------------------------------------------------------------------------
6944       subroutine add_hb_contact_eello(ii,jj,itask)
6945       implicit real*8 (a-h,o-z)
6946       include "DIMENSIONS"
6947       include "COMMON.IOUNITS"
6948       integer max_cont
6949       integer max_dim
6950       parameter (max_cont=maxconts)
6951       parameter (max_dim=70)
6952       include "COMMON.CONTACTS"
6953       double precision zapas(max_dim,maxconts,max_fg_procs),
6954      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6955       common /przechowalnia/ zapas
6956       integer i,j,ii,jj,iproc,itask(4),nn
6957 c      write (iout,*) "itask",itask
6958       do i=1,2
6959         iproc=itask(i)
6960         if (iproc.gt.0) then
6961           do j=1,num_cont_hb(ii)
6962             jjc=jcont_hb(j,ii)
6963 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6964             if (jjc.eq.jj) then
6965               ncont_sent(iproc)=ncont_sent(iproc)+1
6966               nn=ncont_sent(iproc)
6967               zapas(1,nn,iproc)=ii
6968               zapas(2,nn,iproc)=jjc
6969               zapas(3,nn,iproc)=d_cont(j,ii)
6970               ind=3
6971               do kk=1,3
6972                 ind=ind+1
6973                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6974               enddo
6975               do kk=1,2
6976                 do ll=1,2
6977                   ind=ind+1
6978                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6979                 enddo
6980               enddo
6981               do jj=1,5
6982                 do kk=1,3
6983                   do ll=1,2
6984                     do mm=1,2
6985                       ind=ind+1
6986                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6987                     enddo
6988                   enddo
6989                 enddo
6990               enddo
6991               exit
6992             endif
6993           enddo
6994         endif
6995       enddo
6996       return
6997       end
6998 c------------------------------------------------------------------------------
6999       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7000       implicit real*8 (a-h,o-z)
7001       include 'DIMENSIONS'
7002       include 'COMMON.IOUNITS'
7003       include 'COMMON.DERIV'
7004       include 'COMMON.INTERACT'
7005       include 'COMMON.CONTACTS'
7006       double precision gx(3),gx1(3)
7007       logical lprn
7008       lprn=.false.
7009       eij=facont_hb(jj,i)
7010       ekl=facont_hb(kk,k)
7011       ees0pij=ees0p(jj,i)
7012       ees0pkl=ees0p(kk,k)
7013       ees0mij=ees0m(jj,i)
7014       ees0mkl=ees0m(kk,k)
7015       ekont=eij*ekl
7016       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7017 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7018 C Following 4 lines for diagnostics.
7019 cd    ees0pkl=0.0D0
7020 cd    ees0pij=1.0D0
7021 cd    ees0mkl=0.0D0
7022 cd    ees0mij=1.0D0
7023 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7024 c     & 'Contacts ',i,j,
7025 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7026 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7027 c     & 'gradcorr_long'
7028 C Calculate the multi-body contribution to energy.
7029 c      ecorr=ecorr+ekont*ees
7030 C Calculate multi-body contributions to the gradient.
7031       coeffpees0pij=coeffp*ees0pij
7032       coeffmees0mij=coeffm*ees0mij
7033       coeffpees0pkl=coeffp*ees0pkl
7034       coeffmees0mkl=coeffm*ees0mkl
7035       do ll=1,3
7036 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7037         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7038      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7039      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7040         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7041      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7042      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7043 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7044         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7045      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7046      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7047         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7048      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7049      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7050         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7051      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7052      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7053         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7054         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7055         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7056      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7057      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7058         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7059         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7060 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7061       enddo
7062 c      write (iout,*)
7063 cgrad      do m=i+1,j-1
7064 cgrad        do ll=1,3
7065 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7066 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7067 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7068 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7069 cgrad        enddo
7070 cgrad      enddo
7071 cgrad      do m=k+1,l-1
7072 cgrad        do ll=1,3
7073 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7074 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7075 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7076 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7077 cgrad        enddo
7078 cgrad      enddo
7079 c      write (iout,*) "ehbcorr",ekont*ees
7080       ehbcorr=ekont*ees
7081       return
7082       end
7083 #ifdef MOMENT
7084 C---------------------------------------------------------------------------
7085       subroutine dipole(i,j,jj)
7086       implicit real*8 (a-h,o-z)
7087       include 'DIMENSIONS'
7088       include 'COMMON.IOUNITS'
7089       include 'COMMON.CHAIN'
7090       include 'COMMON.FFIELD'
7091       include 'COMMON.DERIV'
7092       include 'COMMON.INTERACT'
7093       include 'COMMON.CONTACTS'
7094       include 'COMMON.TORSION'
7095       include 'COMMON.VAR'
7096       include 'COMMON.GEO'
7097       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7098      &  auxmat(2,2)
7099       iti1 = itortyp(itype(i+1))
7100       if (j.lt.nres-1) then
7101         itj1 = itortyp(itype(j+1))
7102       else
7103         itj1=ntortyp+1
7104       endif
7105       do iii=1,2
7106         dipi(iii,1)=Ub2(iii,i)
7107         dipderi(iii)=Ub2der(iii,i)
7108         dipi(iii,2)=b1(iii,iti1)
7109         dipj(iii,1)=Ub2(iii,j)
7110         dipderj(iii)=Ub2der(iii,j)
7111         dipj(iii,2)=b1(iii,itj1)
7112       enddo
7113       kkk=0
7114       do iii=1,2
7115         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7116         do jjj=1,2
7117           kkk=kkk+1
7118           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7119         enddo
7120       enddo
7121       do kkk=1,5
7122         do lll=1,3
7123           mmm=0
7124           do iii=1,2
7125             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7126      &        auxvec(1))
7127             do jjj=1,2
7128               mmm=mmm+1
7129               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7130             enddo
7131           enddo
7132         enddo
7133       enddo
7134       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7135       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7136       do iii=1,2
7137         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7138       enddo
7139       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7140       do iii=1,2
7141         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7142       enddo
7143       return
7144       end
7145 #endif
7146 C---------------------------------------------------------------------------
7147       subroutine calc_eello(i,j,k,l,jj,kk)
7148 C
7149 C This subroutine computes matrices and vectors needed to calculate
7150 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7151 C
7152       implicit real*8 (a-h,o-z)
7153       include 'DIMENSIONS'
7154       include 'COMMON.IOUNITS'
7155       include 'COMMON.CHAIN'
7156       include 'COMMON.DERIV'
7157       include 'COMMON.INTERACT'
7158       include 'COMMON.CONTACTS'
7159       include 'COMMON.TORSION'
7160       include 'COMMON.VAR'
7161       include 'COMMON.GEO'
7162       include 'COMMON.FFIELD'
7163       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7164      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7165       logical lprn
7166       common /kutas/ lprn
7167 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7168 cd     & ' jj=',jj,' kk=',kk
7169 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7170 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7171 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7172       do iii=1,2
7173         do jjj=1,2
7174           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7175           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7176         enddo
7177       enddo
7178       call transpose2(aa1(1,1),aa1t(1,1))
7179       call transpose2(aa2(1,1),aa2t(1,1))
7180       do kkk=1,5
7181         do lll=1,3
7182           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7183      &      aa1tder(1,1,lll,kkk))
7184           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7185      &      aa2tder(1,1,lll,kkk))
7186         enddo
7187       enddo
7188       if (l.eq.j+1) then
7189 C parallel orientation of the two CA-CA-CA frames.
7190         if (i.gt.1) then
7191           iti=itortyp(itype(i))
7192         else
7193           iti=ntortyp+1
7194         endif
7195         itk1=itortyp(itype(k+1))
7196         itj=itortyp(itype(j))
7197         if (l.lt.nres-1) then
7198           itl1=itortyp(itype(l+1))
7199         else
7200           itl1=ntortyp+1
7201         endif
7202 C A1 kernel(j+1) A2T
7203 cd        do iii=1,2
7204 cd          write (iout,'(3f10.5,5x,3f10.5)')
7205 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7206 cd        enddo
7207         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7208      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7209      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7210 C Following matrices are needed only for 6-th order cumulants
7211         IF (wcorr6.gt.0.0d0) THEN
7212         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7213      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7214      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7215         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7216      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7217      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7218      &   ADtEAderx(1,1,1,1,1,1))
7219         lprn=.false.
7220         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7221      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7222      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7223      &   ADtEA1derx(1,1,1,1,1,1))
7224         ENDIF
7225 C End 6-th order cumulants
7226 cd        lprn=.false.
7227 cd        if (lprn) then
7228 cd        write (2,*) 'In calc_eello6'
7229 cd        do iii=1,2
7230 cd          write (2,*) 'iii=',iii
7231 cd          do kkk=1,5
7232 cd            write (2,*) 'kkk=',kkk
7233 cd            do jjj=1,2
7234 cd              write (2,'(3(2f10.5),5x)')
7235 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7236 cd            enddo
7237 cd          enddo
7238 cd        enddo
7239 cd        endif
7240         call transpose2(EUgder(1,1,k),auxmat(1,1))
7241         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7242         call transpose2(EUg(1,1,k),auxmat(1,1))
7243         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7244         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7245         do iii=1,2
7246           do kkk=1,5
7247             do lll=1,3
7248               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7249      &          EAEAderx(1,1,lll,kkk,iii,1))
7250             enddo
7251           enddo
7252         enddo
7253 C A1T kernel(i+1) A2
7254         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7255      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7256      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7257 C Following matrices are needed only for 6-th order cumulants
7258         IF (wcorr6.gt.0.0d0) THEN
7259         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7260      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7261      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7262         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7263      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7264      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7265      &   ADtEAderx(1,1,1,1,1,2))
7266         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7267      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7268      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7269      &   ADtEA1derx(1,1,1,1,1,2))
7270         ENDIF
7271 C End 6-th order cumulants
7272         call transpose2(EUgder(1,1,l),auxmat(1,1))
7273         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7274         call transpose2(EUg(1,1,l),auxmat(1,1))
7275         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7276         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7277         do iii=1,2
7278           do kkk=1,5
7279             do lll=1,3
7280               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7281      &          EAEAderx(1,1,lll,kkk,iii,2))
7282             enddo
7283           enddo
7284         enddo
7285 C AEAb1 and AEAb2
7286 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7287 C They are needed only when the fifth- or the sixth-order cumulants are
7288 C indluded.
7289         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7290         call transpose2(AEA(1,1,1),auxmat(1,1))
7291         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7292         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7293         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7294         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7295         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7296         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7297         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7298         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7299         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7300         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7301         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7302         call transpose2(AEA(1,1,2),auxmat(1,1))
7303         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7304         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7305         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7306         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7307         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7308         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7309         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7310         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7311         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7312         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7313         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7314 C Calculate the Cartesian derivatives of the vectors.
7315         do iii=1,2
7316           do kkk=1,5
7317             do lll=1,3
7318               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7319               call matvec2(auxmat(1,1),b1(1,iti),
7320      &          AEAb1derx(1,lll,kkk,iii,1,1))
7321               call matvec2(auxmat(1,1),Ub2(1,i),
7322      &          AEAb2derx(1,lll,kkk,iii,1,1))
7323               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7324      &          AEAb1derx(1,lll,kkk,iii,2,1))
7325               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7326      &          AEAb2derx(1,lll,kkk,iii,2,1))
7327               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7328               call matvec2(auxmat(1,1),b1(1,itj),
7329      &          AEAb1derx(1,lll,kkk,iii,1,2))
7330               call matvec2(auxmat(1,1),Ub2(1,j),
7331      &          AEAb2derx(1,lll,kkk,iii,1,2))
7332               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7333      &          AEAb1derx(1,lll,kkk,iii,2,2))
7334               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7335      &          AEAb2derx(1,lll,kkk,iii,2,2))
7336             enddo
7337           enddo
7338         enddo
7339         ENDIF
7340 C End vectors
7341       else
7342 C Antiparallel orientation of the two CA-CA-CA frames.
7343         if (i.gt.1) then
7344           iti=itortyp(itype(i))
7345         else
7346           iti=ntortyp+1
7347         endif
7348         itk1=itortyp(itype(k+1))
7349         itl=itortyp(itype(l))
7350         itj=itortyp(itype(j))
7351         if (j.lt.nres-1) then
7352           itj1=itortyp(itype(j+1))
7353         else
7354           itj1=ntortyp+1
7355         endif
7356 C A2 kernel(j-1)T A1T
7357         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7358      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7359      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7360 C Following matrices are needed only for 6-th order cumulants
7361         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7362      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7364      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7365      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7366         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7367      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7368      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7369      &   ADtEAderx(1,1,1,1,1,1))
7370         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7371      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7372      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7373      &   ADtEA1derx(1,1,1,1,1,1))
7374         ENDIF
7375 C End 6-th order cumulants
7376         call transpose2(EUgder(1,1,k),auxmat(1,1))
7377         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7378         call transpose2(EUg(1,1,k),auxmat(1,1))
7379         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7380         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7381         do iii=1,2
7382           do kkk=1,5
7383             do lll=1,3
7384               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7385      &          EAEAderx(1,1,lll,kkk,iii,1))
7386             enddo
7387           enddo
7388         enddo
7389 C A2T kernel(i+1)T A1
7390         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7391      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7392      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7393 C Following matrices are needed only for 6-th order cumulants
7394         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7395      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7396         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7397      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7398      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7399         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7400      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7401      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7402      &   ADtEAderx(1,1,1,1,1,2))
7403         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7404      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7405      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7406      &   ADtEA1derx(1,1,1,1,1,2))
7407         ENDIF
7408 C End 6-th order cumulants
7409         call transpose2(EUgder(1,1,j),auxmat(1,1))
7410         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7411         call transpose2(EUg(1,1,j),auxmat(1,1))
7412         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7413         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7414         do iii=1,2
7415           do kkk=1,5
7416             do lll=1,3
7417               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7418      &          EAEAderx(1,1,lll,kkk,iii,2))
7419             enddo
7420           enddo
7421         enddo
7422 C AEAb1 and AEAb2
7423 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7424 C They are needed only when the fifth- or the sixth-order cumulants are
7425 C indluded.
7426         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7427      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7428         call transpose2(AEA(1,1,1),auxmat(1,1))
7429         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7430         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7431         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7432         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7433         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7434         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7435         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7436         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7437         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7438         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7439         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7440         call transpose2(AEA(1,1,2),auxmat(1,1))
7441         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7442         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7443         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7444         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7445         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7446         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7447         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7448         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7449         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7450         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7451         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7452 C Calculate the Cartesian derivatives of the vectors.
7453         do iii=1,2
7454           do kkk=1,5
7455             do lll=1,3
7456               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7457               call matvec2(auxmat(1,1),b1(1,iti),
7458      &          AEAb1derx(1,lll,kkk,iii,1,1))
7459               call matvec2(auxmat(1,1),Ub2(1,i),
7460      &          AEAb2derx(1,lll,kkk,iii,1,1))
7461               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7462      &          AEAb1derx(1,lll,kkk,iii,2,1))
7463               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7464      &          AEAb2derx(1,lll,kkk,iii,2,1))
7465               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7466               call matvec2(auxmat(1,1),b1(1,itl),
7467      &          AEAb1derx(1,lll,kkk,iii,1,2))
7468               call matvec2(auxmat(1,1),Ub2(1,l),
7469      &          AEAb2derx(1,lll,kkk,iii,1,2))
7470               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7471      &          AEAb1derx(1,lll,kkk,iii,2,2))
7472               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7473      &          AEAb2derx(1,lll,kkk,iii,2,2))
7474             enddo
7475           enddo
7476         enddo
7477         ENDIF
7478 C End vectors
7479       endif
7480       return
7481       end
7482 C---------------------------------------------------------------------------
7483       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7484      &  KK,KKderg,AKA,AKAderg,AKAderx)
7485       implicit none
7486       integer nderg
7487       logical transp
7488       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7489      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7490      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7491       integer iii,kkk,lll
7492       integer jjj,mmm
7493       logical lprn
7494       common /kutas/ lprn
7495       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7496       do iii=1,nderg
7497         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7498      &    AKAderg(1,1,iii))
7499       enddo
7500 cd      if (lprn) write (2,*) 'In kernel'
7501       do kkk=1,5
7502 cd        if (lprn) write (2,*) 'kkk=',kkk
7503         do lll=1,3
7504           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7505      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7506 cd          if (lprn) then
7507 cd            write (2,*) 'lll=',lll
7508 cd            write (2,*) 'iii=1'
7509 cd            do jjj=1,2
7510 cd              write (2,'(3(2f10.5),5x)')
7511 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7512 cd            enddo
7513 cd          endif
7514           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7515      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7516 cd          if (lprn) then
7517 cd            write (2,*) 'lll=',lll
7518 cd            write (2,*) 'iii=2'
7519 cd            do jjj=1,2
7520 cd              write (2,'(3(2f10.5),5x)')
7521 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7522 cd            enddo
7523 cd          endif
7524         enddo
7525       enddo
7526       return
7527       end
7528 C---------------------------------------------------------------------------
7529       double precision function eello4(i,j,k,l,jj,kk)
7530       implicit real*8 (a-h,o-z)
7531       include 'DIMENSIONS'
7532       include 'COMMON.IOUNITS'
7533       include 'COMMON.CHAIN'
7534       include 'COMMON.DERIV'
7535       include 'COMMON.INTERACT'
7536       include 'COMMON.CONTACTS'
7537       include 'COMMON.TORSION'
7538       include 'COMMON.VAR'
7539       include 'COMMON.GEO'
7540       double precision pizda(2,2),ggg1(3),ggg2(3)
7541 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7542 cd        eello4=0.0d0
7543 cd        return
7544 cd      endif
7545 cd      print *,'eello4:',i,j,k,l,jj,kk
7546 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7547 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7548 cold      eij=facont_hb(jj,i)
7549 cold      ekl=facont_hb(kk,k)
7550 cold      ekont=eij*ekl
7551       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7552 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7553       gcorr_loc(k-1)=gcorr_loc(k-1)
7554      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7555       if (l.eq.j+1) then
7556         gcorr_loc(l-1)=gcorr_loc(l-1)
7557      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7558       else
7559         gcorr_loc(j-1)=gcorr_loc(j-1)
7560      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7561       endif
7562       do iii=1,2
7563         do kkk=1,5
7564           do lll=1,3
7565             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7566      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7567 cd            derx(lll,kkk,iii)=0.0d0
7568           enddo
7569         enddo
7570       enddo
7571 cd      gcorr_loc(l-1)=0.0d0
7572 cd      gcorr_loc(j-1)=0.0d0
7573 cd      gcorr_loc(k-1)=0.0d0
7574 cd      eel4=1.0d0
7575 cd      write (iout,*)'Contacts have occurred for peptide groups',
7576 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7577 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7578       if (j.lt.nres-1) then
7579         j1=j+1
7580         j2=j-1
7581       else
7582         j1=j-1
7583         j2=j-2
7584       endif
7585       if (l.lt.nres-1) then
7586         l1=l+1
7587         l2=l-1
7588       else
7589         l1=l-1
7590         l2=l-2
7591       endif
7592       do ll=1,3
7593 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7594 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7595         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7596         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7597 cgrad        ghalf=0.5d0*ggg1(ll)
7598         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7599         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7600         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7601         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7602         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7603         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7604 cgrad        ghalf=0.5d0*ggg2(ll)
7605         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7606         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7607         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7608         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7609         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7610         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7611       enddo
7612 cgrad      do m=i+1,j-1
7613 cgrad        do ll=1,3
7614 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7615 cgrad        enddo
7616 cgrad      enddo
7617 cgrad      do m=k+1,l-1
7618 cgrad        do ll=1,3
7619 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7620 cgrad        enddo
7621 cgrad      enddo
7622 cgrad      do m=i+2,j2
7623 cgrad        do ll=1,3
7624 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7625 cgrad        enddo
7626 cgrad      enddo
7627 cgrad      do m=k+2,l2
7628 cgrad        do ll=1,3
7629 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7630 cgrad        enddo
7631 cgrad      enddo
7632 cd      do iii=1,nres-3
7633 cd        write (2,*) iii,gcorr_loc(iii)
7634 cd      enddo
7635       eello4=ekont*eel4
7636 cd      write (2,*) 'ekont',ekont
7637 cd      write (iout,*) 'eello4',ekont*eel4
7638       return
7639       end
7640 C---------------------------------------------------------------------------
7641       double precision function eello5(i,j,k,l,jj,kk)
7642       implicit real*8 (a-h,o-z)
7643       include 'DIMENSIONS'
7644       include 'COMMON.IOUNITS'
7645       include 'COMMON.CHAIN'
7646       include 'COMMON.DERIV'
7647       include 'COMMON.INTERACT'
7648       include 'COMMON.CONTACTS'
7649       include 'COMMON.TORSION'
7650       include 'COMMON.VAR'
7651       include 'COMMON.GEO'
7652       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7653       double precision ggg1(3),ggg2(3)
7654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7655 C                                                                              C
7656 C                            Parallel chains                                   C
7657 C                                                                              C
7658 C          o             o                   o             o                   C
7659 C         /l\           / \             \   / \           / \   /              C
7660 C        /   \         /   \             \ /   \         /   \ /               C
7661 C       j| o |l1       | o |              o| o |         | o |o                C
7662 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7663 C      \i/   \         /   \ /             /   \         /   \                 C
7664 C       o    k1             o                                                  C
7665 C         (I)          (II)                (III)          (IV)                 C
7666 C                                                                              C
7667 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7668 C                                                                              C
7669 C                            Antiparallel chains                               C
7670 C                                                                              C
7671 C          o             o                   o             o                   C
7672 C         /j\           / \             \   / \           / \   /              C
7673 C        /   \         /   \             \ /   \         /   \ /               C
7674 C      j1| o |l        | o |              o| o |         | o |o                C
7675 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7676 C      \i/   \         /   \ /             /   \         /   \                 C
7677 C       o     k1            o                                                  C
7678 C         (I)          (II)                (III)          (IV)                 C
7679 C                                                                              C
7680 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7681 C                                                                              C
7682 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7683 C                                                                              C
7684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7685 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7686 cd        eello5=0.0d0
7687 cd        return
7688 cd      endif
7689 cd      write (iout,*)
7690 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7691 cd     &   ' and',k,l
7692       itk=itortyp(itype(k))
7693       itl=itortyp(itype(l))
7694       itj=itortyp(itype(j))
7695       eello5_1=0.0d0
7696       eello5_2=0.0d0
7697       eello5_3=0.0d0
7698       eello5_4=0.0d0
7699 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7700 cd     &   eel5_3_num,eel5_4_num)
7701       do iii=1,2
7702         do kkk=1,5
7703           do lll=1,3
7704             derx(lll,kkk,iii)=0.0d0
7705           enddo
7706         enddo
7707       enddo
7708 cd      eij=facont_hb(jj,i)
7709 cd      ekl=facont_hb(kk,k)
7710 cd      ekont=eij*ekl
7711 cd      write (iout,*)'Contacts have occurred for peptide groups',
7712 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7713 cd      goto 1111
7714 C Contribution from the graph I.
7715 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7716 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7717       call transpose2(EUg(1,1,k),auxmat(1,1))
7718       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7719       vv(1)=pizda(1,1)-pizda(2,2)
7720       vv(2)=pizda(1,2)+pizda(2,1)
7721       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7722      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7723 C Explicit gradient in virtual-dihedral angles.
7724       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7725      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7726      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7727       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7728       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7729       vv(1)=pizda(1,1)-pizda(2,2)
7730       vv(2)=pizda(1,2)+pizda(2,1)
7731       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7732      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7733      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7734       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7735       vv(1)=pizda(1,1)-pizda(2,2)
7736       vv(2)=pizda(1,2)+pizda(2,1)
7737       if (l.eq.j+1) then
7738         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7739      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7740      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7741       else
7742         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7743      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7745       endif
7746 C Cartesian gradient
7747       do iii=1,2
7748         do kkk=1,5
7749           do lll=1,3
7750             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7751      &        pizda(1,1))
7752             vv(1)=pizda(1,1)-pizda(2,2)
7753             vv(2)=pizda(1,2)+pizda(2,1)
7754             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7755      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7756      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7757           enddo
7758         enddo
7759       enddo
7760 c      goto 1112
7761 c1111  continue
7762 C Contribution from graph II
7763       call transpose2(EE(1,1,itk),auxmat(1,1))
7764       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7765       vv(1)=pizda(1,1)+pizda(2,2)
7766       vv(2)=pizda(2,1)-pizda(1,2)
7767       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7768      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7769 C Explicit gradient in virtual-dihedral angles.
7770       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7771      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7772       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7773       vv(1)=pizda(1,1)+pizda(2,2)
7774       vv(2)=pizda(2,1)-pizda(1,2)
7775       if (l.eq.j+1) then
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7778      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7779       else
7780         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7781      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7782      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7783       endif
7784 C Cartesian gradient
7785       do iii=1,2
7786         do kkk=1,5
7787           do lll=1,3
7788             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7789      &        pizda(1,1))
7790             vv(1)=pizda(1,1)+pizda(2,2)
7791             vv(2)=pizda(2,1)-pizda(1,2)
7792             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7793      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7794      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7795           enddo
7796         enddo
7797       enddo
7798 cd      goto 1112
7799 cd1111  continue
7800       if (l.eq.j+1) then
7801 cd        goto 1110
7802 C Parallel orientation
7803 C Contribution from graph III
7804         call transpose2(EUg(1,1,l),auxmat(1,1))
7805         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7806         vv(1)=pizda(1,1)-pizda(2,2)
7807         vv(2)=pizda(1,2)+pizda(2,1)
7808         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7809      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7810 C Explicit gradient in virtual-dihedral angles.
7811         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7812      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7813      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7814         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7815         vv(1)=pizda(1,1)-pizda(2,2)
7816         vv(2)=pizda(1,2)+pizda(2,1)
7817         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7818      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7820         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7821         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7822         vv(1)=pizda(1,1)-pizda(2,2)
7823         vv(2)=pizda(1,2)+pizda(2,1)
7824         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7825      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7826      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7827 C Cartesian gradient
7828         do iii=1,2
7829           do kkk=1,5
7830             do lll=1,3
7831               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7832      &          pizda(1,1))
7833               vv(1)=pizda(1,1)-pizda(2,2)
7834               vv(2)=pizda(1,2)+pizda(2,1)
7835               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7836      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7837      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7838             enddo
7839           enddo
7840         enddo
7841 cd        goto 1112
7842 C Contribution from graph IV
7843 cd1110    continue
7844         call transpose2(EE(1,1,itl),auxmat(1,1))
7845         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7846         vv(1)=pizda(1,1)+pizda(2,2)
7847         vv(2)=pizda(2,1)-pizda(1,2)
7848         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7849      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7850 C Explicit gradient in virtual-dihedral angles.
7851         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7852      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7853         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7854         vv(1)=pizda(1,1)+pizda(2,2)
7855         vv(2)=pizda(2,1)-pizda(1,2)
7856         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7857      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7858      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7859 C Cartesian gradient
7860         do iii=1,2
7861           do kkk=1,5
7862             do lll=1,3
7863               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7864      &          pizda(1,1))
7865               vv(1)=pizda(1,1)+pizda(2,2)
7866               vv(2)=pizda(2,1)-pizda(1,2)
7867               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7868      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7869      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7870             enddo
7871           enddo
7872         enddo
7873       else
7874 C Antiparallel orientation
7875 C Contribution from graph III
7876 c        goto 1110
7877         call transpose2(EUg(1,1,j),auxmat(1,1))
7878         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7879         vv(1)=pizda(1,1)-pizda(2,2)
7880         vv(2)=pizda(1,2)+pizda(2,1)
7881         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7882      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7883 C Explicit gradient in virtual-dihedral angles.
7884         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7885      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7886      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7887         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7888         vv(1)=pizda(1,1)-pizda(2,2)
7889         vv(2)=pizda(1,2)+pizda(2,1)
7890         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7891      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7892      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7893         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7894         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7895         vv(1)=pizda(1,1)-pizda(2,2)
7896         vv(2)=pizda(1,2)+pizda(2,1)
7897         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7898      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7899      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7900 C Cartesian gradient
7901         do iii=1,2
7902           do kkk=1,5
7903             do lll=1,3
7904               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7905      &          pizda(1,1))
7906               vv(1)=pizda(1,1)-pizda(2,2)
7907               vv(2)=pizda(1,2)+pizda(2,1)
7908               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7909      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7910      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7911             enddo
7912           enddo
7913         enddo
7914 cd        goto 1112
7915 C Contribution from graph IV
7916 1110    continue
7917         call transpose2(EE(1,1,itj),auxmat(1,1))
7918         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7919         vv(1)=pizda(1,1)+pizda(2,2)
7920         vv(2)=pizda(2,1)-pizda(1,2)
7921         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7922      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7923 C Explicit gradient in virtual-dihedral angles.
7924         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7925      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7926         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7927         vv(1)=pizda(1,1)+pizda(2,2)
7928         vv(2)=pizda(2,1)-pizda(1,2)
7929         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7930      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7931      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7932 C Cartesian gradient
7933         do iii=1,2
7934           do kkk=1,5
7935             do lll=1,3
7936               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7937      &          pizda(1,1))
7938               vv(1)=pizda(1,1)+pizda(2,2)
7939               vv(2)=pizda(2,1)-pizda(1,2)
7940               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7941      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7942      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7943             enddo
7944           enddo
7945         enddo
7946       endif
7947 1112  continue
7948       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7949 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7950 cd        write (2,*) 'ijkl',i,j,k,l
7951 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7952 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7953 cd      endif
7954 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7955 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7956 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7957 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7958       if (j.lt.nres-1) then
7959         j1=j+1
7960         j2=j-1
7961       else
7962         j1=j-1
7963         j2=j-2
7964       endif
7965       if (l.lt.nres-1) then
7966         l1=l+1
7967         l2=l-1
7968       else
7969         l1=l-1
7970         l2=l-2
7971       endif
7972 cd      eij=1.0d0
7973 cd      ekl=1.0d0
7974 cd      ekont=1.0d0
7975 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7976 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7977 C        summed up outside the subrouine as for the other subroutines
7978 C        handling long-range interactions. The old code is commented out
7979 C        with "cgrad" to keep track of changes.
7980       do ll=1,3
7981 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7982 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7983         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7984         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7985 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7986 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7987 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7988 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7989 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7990 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7991 c     &   gradcorr5ij,
7992 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7993 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7994 cgrad        ghalf=0.5d0*ggg1(ll)
7995 cd        ghalf=0.0d0
7996         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7997         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7998         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7999         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8000         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8001         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8002 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8003 cgrad        ghalf=0.5d0*ggg2(ll)
8004 cd        ghalf=0.0d0
8005         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8006         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8007         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8008         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8009         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8010         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8011       enddo
8012 cd      goto 1112
8013 cgrad      do m=i+1,j-1
8014 cgrad        do ll=1,3
8015 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8016 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8017 cgrad        enddo
8018 cgrad      enddo
8019 cgrad      do m=k+1,l-1
8020 cgrad        do ll=1,3
8021 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8022 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8023 cgrad        enddo
8024 cgrad      enddo
8025 c1112  continue
8026 cgrad      do m=i+2,j2
8027 cgrad        do ll=1,3
8028 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8029 cgrad        enddo
8030 cgrad      enddo
8031 cgrad      do m=k+2,l2
8032 cgrad        do ll=1,3
8033 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8034 cgrad        enddo
8035 cgrad      enddo
8036 cd      do iii=1,nres-3
8037 cd        write (2,*) iii,g_corr5_loc(iii)
8038 cd      enddo
8039       eello5=ekont*eel5
8040 cd      write (2,*) 'ekont',ekont
8041 cd      write (iout,*) 'eello5',ekont*eel5
8042       return
8043       end
8044 c--------------------------------------------------------------------------
8045       double precision function eello6(i,j,k,l,jj,kk)
8046       implicit real*8 (a-h,o-z)
8047       include 'DIMENSIONS'
8048       include 'COMMON.IOUNITS'
8049       include 'COMMON.CHAIN'
8050       include 'COMMON.DERIV'
8051       include 'COMMON.INTERACT'
8052       include 'COMMON.CONTACTS'
8053       include 'COMMON.TORSION'
8054       include 'COMMON.VAR'
8055       include 'COMMON.GEO'
8056       include 'COMMON.FFIELD'
8057       double precision ggg1(3),ggg2(3)
8058 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8059 cd        eello6=0.0d0
8060 cd        return
8061 cd      endif
8062 cd      write (iout,*)
8063 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8064 cd     &   ' and',k,l
8065       eello6_1=0.0d0
8066       eello6_2=0.0d0
8067       eello6_3=0.0d0
8068       eello6_4=0.0d0
8069       eello6_5=0.0d0
8070       eello6_6=0.0d0
8071 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8072 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8073       do iii=1,2
8074         do kkk=1,5
8075           do lll=1,3
8076             derx(lll,kkk,iii)=0.0d0
8077           enddo
8078         enddo
8079       enddo
8080 cd      eij=facont_hb(jj,i)
8081 cd      ekl=facont_hb(kk,k)
8082 cd      ekont=eij*ekl
8083 cd      eij=1.0d0
8084 cd      ekl=1.0d0
8085 cd      ekont=1.0d0
8086       if (l.eq.j+1) then
8087         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8088         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8089         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8090         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8091         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8092         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8093       else
8094         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8095         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8096         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8097         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8098         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8099           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8100         else
8101           eello6_5=0.0d0
8102         endif
8103         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8104       endif
8105 C If turn contributions are considered, they will be handled separately.
8106       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8107 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8108 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8109 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8110 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8111 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8112 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8113 cd      goto 1112
8114       if (j.lt.nres-1) then
8115         j1=j+1
8116         j2=j-1
8117       else
8118         j1=j-1
8119         j2=j-2
8120       endif
8121       if (l.lt.nres-1) then
8122         l1=l+1
8123         l2=l-1
8124       else
8125         l1=l-1
8126         l2=l-2
8127       endif
8128       do ll=1,3
8129 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8130 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8131 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8132 cgrad        ghalf=0.5d0*ggg1(ll)
8133 cd        ghalf=0.0d0
8134         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8135         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8136         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8137         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8138         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8139         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8140         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8141         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8142 cgrad        ghalf=0.5d0*ggg2(ll)
8143 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8144 cd        ghalf=0.0d0
8145         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8146         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8147         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8148         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8149         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8150         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8151       enddo
8152 cd      goto 1112
8153 cgrad      do m=i+1,j-1
8154 cgrad        do ll=1,3
8155 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8156 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8157 cgrad        enddo
8158 cgrad      enddo
8159 cgrad      do m=k+1,l-1
8160 cgrad        do ll=1,3
8161 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8162 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8163 cgrad        enddo
8164 cgrad      enddo
8165 cgrad1112  continue
8166 cgrad      do m=i+2,j2
8167 cgrad        do ll=1,3
8168 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8169 cgrad        enddo
8170 cgrad      enddo
8171 cgrad      do m=k+2,l2
8172 cgrad        do ll=1,3
8173 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8174 cgrad        enddo
8175 cgrad      enddo
8176 cd      do iii=1,nres-3
8177 cd        write (2,*) iii,g_corr6_loc(iii)
8178 cd      enddo
8179       eello6=ekont*eel6
8180 cd      write (2,*) 'ekont',ekont
8181 cd      write (iout,*) 'eello6',ekont*eel6
8182       return
8183       end
8184 c--------------------------------------------------------------------------
8185       double precision function eello6_graph1(i,j,k,l,imat,swap)
8186       implicit real*8 (a-h,o-z)
8187       include 'DIMENSIONS'
8188       include 'COMMON.IOUNITS'
8189       include 'COMMON.CHAIN'
8190       include 'COMMON.DERIV'
8191       include 'COMMON.INTERACT'
8192       include 'COMMON.CONTACTS'
8193       include 'COMMON.TORSION'
8194       include 'COMMON.VAR'
8195       include 'COMMON.GEO'
8196       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8197       logical swap
8198       logical lprn
8199       common /kutas/ lprn
8200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8201 C
8202 C      Parallel       Antiparallel
8203 C
8204 C          o             o
8205 C         /l\           /j\
8206 C        /   \         /   \
8207 C       /| o |         | o |\
8208 C     \ j|/k\|  /   \  |/k\|l /
8209 C      \ /   \ /     \ /   \ /
8210 C       o     o       o     o
8211 C       i             i
8212 C
8213 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8214       itk=itortyp(itype(k))
8215       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8216       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8217       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8218       call transpose2(EUgC(1,1,k),auxmat(1,1))
8219       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8220       vv1(1)=pizda1(1,1)-pizda1(2,2)
8221       vv1(2)=pizda1(1,2)+pizda1(2,1)
8222       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8223       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8224       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8225       s5=scalar2(vv(1),Dtobr2(1,i))
8226 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8227       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8228       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8229      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8230      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8231      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8232      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8233      & +scalar2(vv(1),Dtobr2der(1,i)))
8234       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8235       vv1(1)=pizda1(1,1)-pizda1(2,2)
8236       vv1(2)=pizda1(1,2)+pizda1(2,1)
8237       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8238       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8239       if (l.eq.j+1) then
8240         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8241      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8242      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8243      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8244      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8245       else
8246         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8247      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8248      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8249      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8250      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8251       endif
8252       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8253       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8254       vv1(1)=pizda1(1,1)-pizda1(2,2)
8255       vv1(2)=pizda1(1,2)+pizda1(2,1)
8256       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8257      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8258      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8259      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8260       do iii=1,2
8261         if (swap) then
8262           ind=3-iii
8263         else
8264           ind=iii
8265         endif
8266         do kkk=1,5
8267           do lll=1,3
8268             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8269             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8270             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8271             call transpose2(EUgC(1,1,k),auxmat(1,1))
8272             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8273      &        pizda1(1,1))
8274             vv1(1)=pizda1(1,1)-pizda1(2,2)
8275             vv1(2)=pizda1(1,2)+pizda1(2,1)
8276             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8277             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8278      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8279             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8280      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8281             s5=scalar2(vv(1),Dtobr2(1,i))
8282             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8283           enddo
8284         enddo
8285       enddo
8286       return
8287       end
8288 c----------------------------------------------------------------------------
8289       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8290       implicit real*8 (a-h,o-z)
8291       include 'DIMENSIONS'
8292       include 'COMMON.IOUNITS'
8293       include 'COMMON.CHAIN'
8294       include 'COMMON.DERIV'
8295       include 'COMMON.INTERACT'
8296       include 'COMMON.CONTACTS'
8297       include 'COMMON.TORSION'
8298       include 'COMMON.VAR'
8299       include 'COMMON.GEO'
8300       logical swap
8301       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8302      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8303       logical lprn
8304       common /kutas/ lprn
8305 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8306 C                                                                              C
8307 C      Parallel       Antiparallel                                             C
8308 C                                                                              C
8309 C          o             o                                                     C
8310 C     \   /l\           /j\   /                                                C
8311 C      \ /   \         /   \ /                                                 C
8312 C       o| o |         | o |o                                                  C
8313 C     \ j|/k\|      \  |/k\|l                                                  C
8314 C      \ /   \       \ /   \                                                   C
8315 C       o             o                                                        C
8316 C       i             i                                                        C
8317 C                                                                              C
8318 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8319 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8320 C AL 7/4/01 s1 would occur in the sixth-order moment,
8321 C           but not in a cluster cumulant
8322 #ifdef MOMENT
8323       s1=dip(1,jj,i)*dip(1,kk,k)
8324 #endif
8325       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8326       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8327       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8328       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8329       call transpose2(EUg(1,1,k),auxmat(1,1))
8330       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8331       vv(1)=pizda(1,1)-pizda(2,2)
8332       vv(2)=pizda(1,2)+pizda(2,1)
8333       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8334 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8335 #ifdef MOMENT
8336       eello6_graph2=-(s1+s2+s3+s4)
8337 #else
8338       eello6_graph2=-(s2+s3+s4)
8339 #endif
8340 c      eello6_graph2=-s3
8341 C Derivatives in gamma(i-1)
8342       if (i.gt.1) then
8343 #ifdef MOMENT
8344         s1=dipderg(1,jj,i)*dip(1,kk,k)
8345 #endif
8346         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8347         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8348         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8349         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8350 #ifdef MOMENT
8351         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8352 #else
8353         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8354 #endif
8355 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8356       endif
8357 C Derivatives in gamma(k-1)
8358 #ifdef MOMENT
8359       s1=dip(1,jj,i)*dipderg(1,kk,k)
8360 #endif
8361       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8362       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8363       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8364       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8365       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8366       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8367       vv(1)=pizda(1,1)-pizda(2,2)
8368       vv(2)=pizda(1,2)+pizda(2,1)
8369       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8370 #ifdef MOMENT
8371       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8372 #else
8373       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8374 #endif
8375 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8376 C Derivatives in gamma(j-1) or gamma(l-1)
8377       if (j.gt.1) then
8378 #ifdef MOMENT
8379         s1=dipderg(3,jj,i)*dip(1,kk,k)
8380 #endif
8381         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8382         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8383         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8384         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8385         vv(1)=pizda(1,1)-pizda(2,2)
8386         vv(2)=pizda(1,2)+pizda(2,1)
8387         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8388 #ifdef MOMENT
8389         if (swap) then
8390           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8391         else
8392           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8393         endif
8394 #endif
8395         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8396 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8397       endif
8398 C Derivatives in gamma(l-1) or gamma(j-1)
8399       if (l.gt.1) then
8400 #ifdef MOMENT
8401         s1=dip(1,jj,i)*dipderg(3,kk,k)
8402 #endif
8403         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8404         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8405         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8406         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8407         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8408         vv(1)=pizda(1,1)-pizda(2,2)
8409         vv(2)=pizda(1,2)+pizda(2,1)
8410         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8411 #ifdef MOMENT
8412         if (swap) then
8413           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8414         else
8415           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8416         endif
8417 #endif
8418         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8419 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8420       endif
8421 C Cartesian derivatives.
8422       if (lprn) then
8423         write (2,*) 'In eello6_graph2'
8424         do iii=1,2
8425           write (2,*) 'iii=',iii
8426           do kkk=1,5
8427             write (2,*) 'kkk=',kkk
8428             do jjj=1,2
8429               write (2,'(3(2f10.5),5x)')
8430      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8431             enddo
8432           enddo
8433         enddo
8434       endif
8435       do iii=1,2
8436         do kkk=1,5
8437           do lll=1,3
8438 #ifdef MOMENT
8439             if (iii.eq.1) then
8440               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8441             else
8442               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8443             endif
8444 #endif
8445             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8446      &        auxvec(1))
8447             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8448             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8449      &        auxvec(1))
8450             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8451             call transpose2(EUg(1,1,k),auxmat(1,1))
8452             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8453      &        pizda(1,1))
8454             vv(1)=pizda(1,1)-pizda(2,2)
8455             vv(2)=pizda(1,2)+pizda(2,1)
8456             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8457 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8458 #ifdef MOMENT
8459             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8460 #else
8461             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8462 #endif
8463             if (swap) then
8464               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8465             else
8466               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8467             endif
8468           enddo
8469         enddo
8470       enddo
8471       return
8472       end
8473 c----------------------------------------------------------------------------
8474       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8475       implicit real*8 (a-h,o-z)
8476       include 'DIMENSIONS'
8477       include 'COMMON.IOUNITS'
8478       include 'COMMON.CHAIN'
8479       include 'COMMON.DERIV'
8480       include 'COMMON.INTERACT'
8481       include 'COMMON.CONTACTS'
8482       include 'COMMON.TORSION'
8483       include 'COMMON.VAR'
8484       include 'COMMON.GEO'
8485       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8486       logical swap
8487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8488 C                                                                              C
8489 C      Parallel       Antiparallel                                             C
8490 C                                                                              C
8491 C          o             o                                                     C
8492 C         /l\   /   \   /j\                                                    C
8493 C        /   \ /     \ /   \                                                   C
8494 C       /| o |o       o| o |\                                                  C
8495 C       j|/k\|  /      |/k\|l /                                                C
8496 C        /   \ /       /   \ /                                                 C
8497 C       /     o       /     o                                                  C
8498 C       i             i                                                        C
8499 C                                                                              C
8500 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8501 C
8502 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8503 C           energy moment and not to the cluster cumulant.
8504       iti=itortyp(itype(i))
8505       if (j.lt.nres-1) then
8506         itj1=itortyp(itype(j+1))
8507       else
8508         itj1=ntortyp+1
8509       endif
8510       itk=itortyp(itype(k))
8511       itk1=itortyp(itype(k+1))
8512       if (l.lt.nres-1) then
8513         itl1=itortyp(itype(l+1))
8514       else
8515         itl1=ntortyp+1
8516       endif
8517 #ifdef MOMENT
8518       s1=dip(4,jj,i)*dip(4,kk,k)
8519 #endif
8520       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8521       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8522       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8523       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8524       call transpose2(EE(1,1,itk),auxmat(1,1))
8525       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8526       vv(1)=pizda(1,1)+pizda(2,2)
8527       vv(2)=pizda(2,1)-pizda(1,2)
8528       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8529 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8530 cd     & "sum",-(s2+s3+s4)
8531 #ifdef MOMENT
8532       eello6_graph3=-(s1+s2+s3+s4)
8533 #else
8534       eello6_graph3=-(s2+s3+s4)
8535 #endif
8536 c      eello6_graph3=-s4
8537 C Derivatives in gamma(k-1)
8538       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8539       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8540       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8541       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8542 C Derivatives in gamma(l-1)
8543       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8544       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8545       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8546       vv(1)=pizda(1,1)+pizda(2,2)
8547       vv(2)=pizda(2,1)-pizda(1,2)
8548       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8549       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8550 C Cartesian derivatives.
8551       do iii=1,2
8552         do kkk=1,5
8553           do lll=1,3
8554 #ifdef MOMENT
8555             if (iii.eq.1) then
8556               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8557             else
8558               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8559             endif
8560 #endif
8561             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8562      &        auxvec(1))
8563             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8564             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8565      &        auxvec(1))
8566             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8567             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8568      &        pizda(1,1))
8569             vv(1)=pizda(1,1)+pizda(2,2)
8570             vv(2)=pizda(2,1)-pizda(1,2)
8571             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8572 #ifdef MOMENT
8573             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8574 #else
8575             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8576 #endif
8577             if (swap) then
8578               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8579             else
8580               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8581             endif
8582 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8583           enddo
8584         enddo
8585       enddo
8586       return
8587       end
8588 c----------------------------------------------------------------------------
8589       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8590       implicit real*8 (a-h,o-z)
8591       include 'DIMENSIONS'
8592       include 'COMMON.IOUNITS'
8593       include 'COMMON.CHAIN'
8594       include 'COMMON.DERIV'
8595       include 'COMMON.INTERACT'
8596       include 'COMMON.CONTACTS'
8597       include 'COMMON.TORSION'
8598       include 'COMMON.VAR'
8599       include 'COMMON.GEO'
8600       include 'COMMON.FFIELD'
8601       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8602      & auxvec1(2),auxmat1(2,2)
8603       logical swap
8604 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8605 C                                                                              C
8606 C      Parallel       Antiparallel                                             C
8607 C                                                                              C
8608 C          o             o                                                     C
8609 C         /l\   /   \   /j\                                                    C
8610 C        /   \ /     \ /   \                                                   C
8611 C       /| o |o       o| o |\                                                  C
8612 C     \ j|/k\|      \  |/k\|l                                                  C
8613 C      \ /   \       \ /   \                                                   C
8614 C       o     \       o     \                                                  C
8615 C       i             i                                                        C
8616 C                                                                              C
8617 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8618 C
8619 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8620 C           energy moment and not to the cluster cumulant.
8621 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8622       iti=itortyp(itype(i))
8623       itj=itortyp(itype(j))
8624       if (j.lt.nres-1) then
8625         itj1=itortyp(itype(j+1))
8626       else
8627         itj1=ntortyp+1
8628       endif
8629       itk=itortyp(itype(k))
8630       if (k.lt.nres-1) then
8631         itk1=itortyp(itype(k+1))
8632       else
8633         itk1=ntortyp+1
8634       endif
8635       itl=itortyp(itype(l))
8636       if (l.lt.nres-1) then
8637         itl1=itortyp(itype(l+1))
8638       else
8639         itl1=ntortyp+1
8640       endif
8641 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8642 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8643 cd     & ' itl',itl,' itl1',itl1
8644 #ifdef MOMENT
8645       if (imat.eq.1) then
8646         s1=dip(3,jj,i)*dip(3,kk,k)
8647       else
8648         s1=dip(2,jj,j)*dip(2,kk,l)
8649       endif
8650 #endif
8651       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8652       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8653       if (j.eq.l+1) then
8654         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8655         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8656       else
8657         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8658         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8659       endif
8660       call transpose2(EUg(1,1,k),auxmat(1,1))
8661       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8662       vv(1)=pizda(1,1)-pizda(2,2)
8663       vv(2)=pizda(2,1)+pizda(1,2)
8664       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8665 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8666 #ifdef MOMENT
8667       eello6_graph4=-(s1+s2+s3+s4)
8668 #else
8669       eello6_graph4=-(s2+s3+s4)
8670 #endif
8671 C Derivatives in gamma(i-1)
8672       if (i.gt.1) then
8673 #ifdef MOMENT
8674         if (imat.eq.1) then
8675           s1=dipderg(2,jj,i)*dip(3,kk,k)
8676         else
8677           s1=dipderg(4,jj,j)*dip(2,kk,l)
8678         endif
8679 #endif
8680         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8681         if (j.eq.l+1) then
8682           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8683           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8684         else
8685           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8686           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8687         endif
8688         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8689         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8690 cd          write (2,*) 'turn6 derivatives'
8691 #ifdef MOMENT
8692           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8693 #else
8694           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8695 #endif
8696         else
8697 #ifdef MOMENT
8698           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8699 #else
8700           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8701 #endif
8702         endif
8703       endif
8704 C Derivatives in gamma(k-1)
8705 #ifdef MOMENT
8706       if (imat.eq.1) then
8707         s1=dip(3,jj,i)*dipderg(2,kk,k)
8708       else
8709         s1=dip(2,jj,j)*dipderg(4,kk,l)
8710       endif
8711 #endif
8712       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8713       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8714       if (j.eq.l+1) then
8715         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8716         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8717       else
8718         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8719         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8720       endif
8721       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8722       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8723       vv(1)=pizda(1,1)-pizda(2,2)
8724       vv(2)=pizda(2,1)+pizda(1,2)
8725       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8726       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8727 #ifdef MOMENT
8728         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8729 #else
8730         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8731 #endif
8732       else
8733 #ifdef MOMENT
8734         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8735 #else
8736         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8737 #endif
8738       endif
8739 C Derivatives in gamma(j-1) or gamma(l-1)
8740       if (l.eq.j+1 .and. l.gt.1) then
8741         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8742         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8743         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8744         vv(1)=pizda(1,1)-pizda(2,2)
8745         vv(2)=pizda(2,1)+pizda(1,2)
8746         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8747         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8748       else if (j.gt.1) then
8749         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8750         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8751         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8752         vv(1)=pizda(1,1)-pizda(2,2)
8753         vv(2)=pizda(2,1)+pizda(1,2)
8754         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8755         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8756           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8757         else
8758           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8759         endif
8760       endif
8761 C Cartesian derivatives.
8762       do iii=1,2
8763         do kkk=1,5
8764           do lll=1,3
8765 #ifdef MOMENT
8766             if (iii.eq.1) then
8767               if (imat.eq.1) then
8768                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8769               else
8770                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8771               endif
8772             else
8773               if (imat.eq.1) then
8774                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8775               else
8776                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8777               endif
8778             endif
8779 #endif
8780             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8781      &        auxvec(1))
8782             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8783             if (j.eq.l+1) then
8784               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8785      &          b1(1,itj1),auxvec(1))
8786               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8787             else
8788               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8789      &          b1(1,itl1),auxvec(1))
8790               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8791             endif
8792             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8793      &        pizda(1,1))
8794             vv(1)=pizda(1,1)-pizda(2,2)
8795             vv(2)=pizda(2,1)+pizda(1,2)
8796             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8797             if (swap) then
8798               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8799 #ifdef MOMENT
8800                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8801      &             -(s1+s2+s4)
8802 #else
8803                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8804      &             -(s2+s4)
8805 #endif
8806                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8807               else
8808 #ifdef MOMENT
8809                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8810 #else
8811                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8812 #endif
8813                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8814               endif
8815             else
8816 #ifdef MOMENT
8817               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8818 #else
8819               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8820 #endif
8821               if (l.eq.j+1) then
8822                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8823               else
8824                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8825               endif
8826             endif
8827           enddo
8828         enddo
8829       enddo
8830       return
8831       end
8832 c----------------------------------------------------------------------------
8833       double precision function eello_turn6(i,jj,kk)
8834       implicit real*8 (a-h,o-z)
8835       include 'DIMENSIONS'
8836       include 'COMMON.IOUNITS'
8837       include 'COMMON.CHAIN'
8838       include 'COMMON.DERIV'
8839       include 'COMMON.INTERACT'
8840       include 'COMMON.CONTACTS'
8841       include 'COMMON.TORSION'
8842       include 'COMMON.VAR'
8843       include 'COMMON.GEO'
8844       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8845      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8846      &  ggg1(3),ggg2(3)
8847       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8848      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8849 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8850 C           the respective energy moment and not to the cluster cumulant.
8851       s1=0.0d0
8852       s8=0.0d0
8853       s13=0.0d0
8854 c
8855       eello_turn6=0.0d0
8856       j=i+4
8857       k=i+1
8858       l=i+3
8859       iti=itortyp(itype(i))
8860       itk=itortyp(itype(k))
8861       itk1=itortyp(itype(k+1))
8862       itl=itortyp(itype(l))
8863       itj=itortyp(itype(j))
8864 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8865 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8866 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8867 cd        eello6=0.0d0
8868 cd        return
8869 cd      endif
8870 cd      write (iout,*)
8871 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8872 cd     &   ' and',k,l
8873 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8874       do iii=1,2
8875         do kkk=1,5
8876           do lll=1,3
8877             derx_turn(lll,kkk,iii)=0.0d0
8878           enddo
8879         enddo
8880       enddo
8881 cd      eij=1.0d0
8882 cd      ekl=1.0d0
8883 cd      ekont=1.0d0
8884       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8885 cd      eello6_5=0.0d0
8886 cd      write (2,*) 'eello6_5',eello6_5
8887 #ifdef MOMENT
8888       call transpose2(AEA(1,1,1),auxmat(1,1))
8889       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8890       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8891       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8892 #endif
8893       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8894       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8895       s2 = scalar2(b1(1,itk),vtemp1(1))
8896 #ifdef MOMENT
8897       call transpose2(AEA(1,1,2),atemp(1,1))
8898       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8899       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8900       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8901 #endif
8902       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8903       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8904       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8905 #ifdef MOMENT
8906       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8907       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8908       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8909       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8910       ss13 = scalar2(b1(1,itk),vtemp4(1))
8911       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8912 #endif
8913 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8914 c      s1=0.0d0
8915 c      s2=0.0d0
8916 c      s8=0.0d0
8917 c      s12=0.0d0
8918 c      s13=0.0d0
8919       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8920 C Derivatives in gamma(i+2)
8921       s1d =0.0d0
8922       s8d =0.0d0
8923 #ifdef MOMENT
8924       call transpose2(AEA(1,1,1),auxmatd(1,1))
8925       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8926       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8927       call transpose2(AEAderg(1,1,2),atempd(1,1))
8928       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8929       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8930 #endif
8931       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8932       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8933       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8934 c      s1d=0.0d0
8935 c      s2d=0.0d0
8936 c      s8d=0.0d0
8937 c      s12d=0.0d0
8938 c      s13d=0.0d0
8939       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8940 C Derivatives in gamma(i+3)
8941 #ifdef MOMENT
8942       call transpose2(AEA(1,1,1),auxmatd(1,1))
8943       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8944       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8945       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8946 #endif
8947       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8948       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8949       s2d = scalar2(b1(1,itk),vtemp1d(1))
8950 #ifdef MOMENT
8951       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8952       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8953 #endif
8954       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8955 #ifdef MOMENT
8956       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8957       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8958       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8959 #endif
8960 c      s1d=0.0d0
8961 c      s2d=0.0d0
8962 c      s8d=0.0d0
8963 c      s12d=0.0d0
8964 c      s13d=0.0d0
8965 #ifdef MOMENT
8966       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8967      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8968 #else
8969       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8970      &               -0.5d0*ekont*(s2d+s12d)
8971 #endif
8972 C Derivatives in gamma(i+4)
8973       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8974       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8975       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8976 #ifdef MOMENT
8977       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8978       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8979       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8980 #endif
8981 c      s1d=0.0d0
8982 c      s2d=0.0d0
8983 c      s8d=0.0d0
8984 C      s12d=0.0d0
8985 c      s13d=0.0d0
8986 #ifdef MOMENT
8987       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8988 #else
8989       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8990 #endif
8991 C Derivatives in gamma(i+5)
8992 #ifdef MOMENT
8993       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8994       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8995       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8996 #endif
8997       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8998       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8999       s2d = scalar2(b1(1,itk),vtemp1d(1))
9000 #ifdef MOMENT
9001       call transpose2(AEA(1,1,2),atempd(1,1))
9002       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9003       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9004 #endif
9005       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9006       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9007 #ifdef MOMENT
9008       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9009       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9010       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9011 #endif
9012 c      s1d=0.0d0
9013 c      s2d=0.0d0
9014 c      s8d=0.0d0
9015 c      s12d=0.0d0
9016 c      s13d=0.0d0
9017 #ifdef MOMENT
9018       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9019      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9020 #else
9021       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9022      &               -0.5d0*ekont*(s2d+s12d)
9023 #endif
9024 C Cartesian derivatives
9025       do iii=1,2
9026         do kkk=1,5
9027           do lll=1,3
9028 #ifdef MOMENT
9029             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9030             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9031             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9032 #endif
9033             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9034             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9035      &          vtemp1d(1))
9036             s2d = scalar2(b1(1,itk),vtemp1d(1))
9037 #ifdef MOMENT
9038             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9039             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9040             s8d = -(atempd(1,1)+atempd(2,2))*
9041      &           scalar2(cc(1,1,itl),vtemp2(1))
9042 #endif
9043             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9044      &           auxmatd(1,1))
9045             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9046             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9047 c      s1d=0.0d0
9048 c      s2d=0.0d0
9049 c      s8d=0.0d0
9050 c      s12d=0.0d0
9051 c      s13d=0.0d0
9052 #ifdef MOMENT
9053             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9054      &        - 0.5d0*(s1d+s2d)
9055 #else
9056             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9057      &        - 0.5d0*s2d
9058 #endif
9059 #ifdef MOMENT
9060             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9061      &        - 0.5d0*(s8d+s12d)
9062 #else
9063             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9064      &        - 0.5d0*s12d
9065 #endif
9066           enddo
9067         enddo
9068       enddo
9069 #ifdef MOMENT
9070       do kkk=1,5
9071         do lll=1,3
9072           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9073      &      achuj_tempd(1,1))
9074           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9075           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9076           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9077           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9078           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9079      &      vtemp4d(1))
9080           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9081           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9082           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9083         enddo
9084       enddo
9085 #endif
9086 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9087 cd     &  16*eel_turn6_num
9088 cd      goto 1112
9089       if (j.lt.nres-1) then
9090         j1=j+1
9091         j2=j-1
9092       else
9093         j1=j-1
9094         j2=j-2
9095       endif
9096       if (l.lt.nres-1) then
9097         l1=l+1
9098         l2=l-1
9099       else
9100         l1=l-1
9101         l2=l-2
9102       endif
9103       do ll=1,3
9104 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9105 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9106 cgrad        ghalf=0.5d0*ggg1(ll)
9107 cd        ghalf=0.0d0
9108         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9109         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9110         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9111      &    +ekont*derx_turn(ll,2,1)
9112         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9113         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9114      &    +ekont*derx_turn(ll,4,1)
9115         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9116         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9117         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9118 cgrad        ghalf=0.5d0*ggg2(ll)
9119 cd        ghalf=0.0d0
9120         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9121      &    +ekont*derx_turn(ll,2,2)
9122         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9123         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9124      &    +ekont*derx_turn(ll,4,2)
9125         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9126         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9127         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9128       enddo
9129 cd      goto 1112
9130 cgrad      do m=i+1,j-1
9131 cgrad        do ll=1,3
9132 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9133 cgrad        enddo
9134 cgrad      enddo
9135 cgrad      do m=k+1,l-1
9136 cgrad        do ll=1,3
9137 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9138 cgrad        enddo
9139 cgrad      enddo
9140 cgrad1112  continue
9141 cgrad      do m=i+2,j2
9142 cgrad        do ll=1,3
9143 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9144 cgrad        enddo
9145 cgrad      enddo
9146 cgrad      do m=k+2,l2
9147 cgrad        do ll=1,3
9148 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9149 cgrad        enddo
9150 cgrad      enddo
9151 cd      do iii=1,nres-3
9152 cd        write (2,*) iii,g_corr6_loc(iii)
9153 cd      enddo
9154       eello_turn6=ekont*eel_turn6
9155 cd      write (2,*) 'ekont',ekont
9156 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9157       return
9158       end
9159
9160 C-----------------------------------------------------------------------------
9161       double precision function scalar(u,v)
9162 !DIR$ INLINEALWAYS scalar
9163 #ifndef OSF
9164 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9165 #endif
9166       implicit none
9167       double precision u(3),v(3)
9168 cd      double precision sc
9169 cd      integer i
9170 cd      sc=0.0d0
9171 cd      do i=1,3
9172 cd        sc=sc+u(i)*v(i)
9173 cd      enddo
9174 cd      scalar=sc
9175
9176       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9177       return
9178       end
9179 crc-------------------------------------------------
9180       SUBROUTINE MATVEC2(A1,V1,V2)
9181 !DIR$ INLINEALWAYS MATVEC2
9182 #ifndef OSF
9183 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9184 #endif
9185       implicit real*8 (a-h,o-z)
9186       include 'DIMENSIONS'
9187       DIMENSION A1(2,2),V1(2),V2(2)
9188 c      DO 1 I=1,2
9189 c        VI=0.0
9190 c        DO 3 K=1,2
9191 c    3     VI=VI+A1(I,K)*V1(K)
9192 c        Vaux(I)=VI
9193 c    1 CONTINUE
9194
9195       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9196       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9197
9198       v2(1)=vaux1
9199       v2(2)=vaux2
9200       END
9201 C---------------------------------------
9202       SUBROUTINE MATMAT2(A1,A2,A3)
9203 #ifndef OSF
9204 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9205 #endif
9206       implicit real*8 (a-h,o-z)
9207       include 'DIMENSIONS'
9208       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9209 c      DIMENSION AI3(2,2)
9210 c        DO  J=1,2
9211 c          A3IJ=0.0
9212 c          DO K=1,2
9213 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9214 c          enddo
9215 c          A3(I,J)=A3IJ
9216 c       enddo
9217 c      enddo
9218
9219       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9220       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9221       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9222       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9223
9224       A3(1,1)=AI3_11
9225       A3(2,1)=AI3_21
9226       A3(1,2)=AI3_12
9227       A3(2,2)=AI3_22
9228       END
9229
9230 c-------------------------------------------------------------------------
9231       double precision function scalar2(u,v)
9232 !DIR$ INLINEALWAYS scalar2
9233       implicit none
9234       double precision u(2),v(2)
9235       double precision sc
9236       integer i
9237       scalar2=u(1)*v(1)+u(2)*v(2)
9238       return
9239       end
9240
9241 C-----------------------------------------------------------------------------
9242
9243       subroutine transpose2(a,at)
9244 !DIR$ INLINEALWAYS transpose2
9245 #ifndef OSF
9246 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9247 #endif
9248       implicit none
9249       double precision a(2,2),at(2,2)
9250       at(1,1)=a(1,1)
9251       at(1,2)=a(2,1)
9252       at(2,1)=a(1,2)
9253       at(2,2)=a(2,2)
9254       return
9255       end
9256 c--------------------------------------------------------------------------
9257       subroutine transpose(n,a,at)
9258       implicit none
9259       integer n,i,j
9260       double precision a(n,n),at(n,n)
9261       do i=1,n
9262         do j=1,n
9263           at(j,i)=a(i,j)
9264         enddo
9265       enddo
9266       return
9267       end
9268 C---------------------------------------------------------------------------
9269       subroutine prodmat3(a1,a2,kk,transp,prod)
9270 !DIR$ INLINEALWAYS prodmat3
9271 #ifndef OSF
9272 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9273 #endif
9274       implicit none
9275       integer i,j
9276       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9277       logical transp
9278 crc      double precision auxmat(2,2),prod_(2,2)
9279
9280       if (transp) then
9281 crc        call transpose2(kk(1,1),auxmat(1,1))
9282 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9283 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9284
9285            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9286      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9287            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9288      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9289            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9290      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9291            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9292      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9293
9294       else
9295 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9296 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9297
9298            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9299      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9300            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9301      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9302            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9303      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9304            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9305      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9306
9307       endif
9308 c      call transpose2(a2(1,1),a2t(1,1))
9309
9310 crc      print *,transp
9311 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9312 crc      print *,((prod(i,j),i=1,2),j=1,2)
9313
9314       return
9315       end
9316