source/unres/src_MD/initialize_p.F

   1       block data
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.MCM'
   5       include 'COMMON.MD'
   6       data MovTypID
   7      &  /'pool','chain regrow','multi-bond','phi','theta','side chain',
   8      &   'total'/
   9 c Conversion from poises to molecular unit and the gas constant
  10       data cPoise /2.9361d0/, Rb /0.001986d0/
  11       end
  12 c--------------------------------------------------------------------------
  13       subroutine initialize
  14 C
  15 C Define constants and zero out tables.
  16 C
  17       implicit real*8 (a-h,o-z)
  18       include 'DIMENSIONS'
  19 #ifdef MPI
  20       include 'mpif.h'
  21 #endif
  22 #ifndef ISNAN
  23       external proc_proc
  24 #ifdef WINPGI
  25 cMS$ATTRIBUTES C ::  proc_proc
  26 #endif
  27 #endif
  28       include 'COMMON.IOUNITS'
  29       include 'COMMON.CHAIN'
  30       include 'COMMON.INTERACT'
  31       include 'COMMON.GEO'
  32       include 'COMMON.LOCAL'
  33       include 'COMMON.TORSION'
  34       include 'COMMON.FFIELD'
  35       include 'COMMON.SBRIDGE'
  36       include 'COMMON.MCM'
  37       include 'COMMON.MINIM'
  38       include 'COMMON.DERIV'
  39       include 'COMMON.SPLITELE'
  40 c Common blocks from the diagonalization routines
  41       COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
  42       COMMON /MACHSW/ KDIAG,ICORFL,IXDR
  43       logical mask_r
  44 c      real*8 text1 /'initial_i'/
  45
  46       mask_r=.false.
  47 #ifndef ISNAN
  48 c NaNQ initialization
  49       i=-1
  50       arg=100.0d0
  51       rr=dacos(arg)
  52 #ifdef WINPGI
  53       idumm=proc_proc(rr,i)
  54 #else
  55       call proc_proc(rr,i)
  56 #endif
  57 #endif
  58
  59       kdiag=0
  60       icorfl=0
  61       iw=2
  62 C
  63 C The following is just to define auxiliary variables used in angle conversion
  64 C
  65       pi=4.0D0*datan(1.0D0)
  66       dwapi=2.0D0*pi
  67       dwapi3=dwapi/3.0D0
  68       pipol=0.5D0*pi
  69       deg2rad=pi/180.0D0
  70       rad2deg=1.0D0/deg2rad
  71       angmin=10.0D0*deg2rad
  72 C
  73 C Define I/O units.
  74 C
  75       inp=    1
  76       iout=   2
  77       ipdbin= 3
  78       ipdb=   7
  79       icart = 30
  80       imol2=  4
  81       igeom=  8
  82       intin=  9
  83       ithep= 11
  84       ithep_pdb=51
  85       irotam=12
  86       irotam_pdb=52
  87       itorp= 13
  88       itordp= 23
  89       ielep= 14
  90       isidep=15
  91       iscpp=25
  92       icbase=16
  93       ifourier=20
  94       istat= 17
  95       irest1=55
  96       irest2=56
  97       iifrag=57
  98       ientin=18
  99       ientout=19
 100       ibond = 28
 101       isccor = 29
 102 crc for write_rmsbank1
 103       izs1=21
 104 cdr  include secondary structure prediction bias
 105       isecpred=27
 106 C
 107 C CSA I/O units (separated from others especially for Jooyoung)
 108 C
 109       icsa_rbank=30
 110       icsa_seed=31
 111       icsa_history=32
 112       icsa_bank=33
 113       icsa_bank1=34
 114       icsa_alpha=35
 115       icsa_alpha1=36
 116       icsa_bankt=37
 117       icsa_int=39
 118       icsa_bank_reminimized=38
 119       icsa_native_int=41
 120       icsa_in=40
 121 crc for ifc error 118
 122       icsa_pdb=42
 123 C
 124 C Set default weights of the energy terms.
 125 C
 126       wlong=1.0D0
 127       welec=1.0D0
 128       wtor =1.0D0
 129       wang =1.0D0
 130       wscloc=1.0D0
 131       wstrain=1.0D0
 132 C
 133 C Zero out tables.
 134 C
 135       print '(a,$)','Inside initialize'
 136 c      call memmon_print_usage()
 137       do i=1,maxres2
 138         do j=1,3
 139           c(j,i)=0.0D0
 140           dc(j,i)=0.0D0
 141         enddo
 142       enddo
 143       do i=1,maxres
 144         do j=1,3
 145           xloc(j,i)=0.0D0
 146         enddo
 147       enddo
 148       do i=1,ntyp
 149         do j=1,ntyp
 150           aa(i,j)=0.0D0
 151           bb(i,j)=0.0D0
 152           augm(i,j)=0.0D0
 153           sigma(i,j)=0.0D0
 154           r0(i,j)=0.0D0
 155           chi(i,j)=0.0D0
 156         enddo
 157         do j=1,2
 158           bad(i,j)=0.0D0
 159         enddo
 160         chip(i)=0.0D0
 161         alp(i)=0.0D0
 162         sigma0(i)=0.0D0
 163         sigii(i)=0.0D0
 164         rr0(i)=0.0D0
 165         a0thet(i)=0.0D0
 166         do j=1,2
 167           athet(j,i)=0.0D0
 168           bthet(j,i)=0.0D0
 169         enddo
 170         do j=0,3
 171           polthet(j,i)=0.0D0
 172         enddo
 173         do j=1,3
 174           gthet(j,i)=0.0D0
 175         enddo
 176         theta0(i)=0.0D0
 177         sig0(i)=0.0D0
 178         sigc0(i)=0.0D0
 179         do j=1,maxlob
 180           bsc(j,i)=0.0D0
 181           do k=1,3
 182             censc(k,j,i)=0.0D0
 183           enddo
 184           do k=1,3
 185             do l=1,3
 186               gaussc(l,k,j,i)=0.0D0
 187             enddo
 188           enddo
 189           nlob(i)=0
 190         enddo
 191       enddo
 192       nlob(ntyp1)=0
 193       dsc(ntyp1)=0.0D0
 194       do i=1,maxtor
 195         itortyp(i)=0
 196         do j=1,maxtor
 197           do k=1,maxterm
 198             v1(k,j,i)=0.0D0
 199             v2(k,j,i)=0.0D0
 200           enddo
 201         enddo
 202       enddo
 203       do i=1,maxres
 204         itype(i)=0
 205         itel(i)=0
 206       enddo
 207 C Initialize the bridge arrays
 208       ns=0
 209       nss=0
 210       nhpb=0
 211       do i=1,maxss
 212         iss(i)=0
 213       enddo
 214       do i=1,maxdim
 215         dhpb(i)=0.0D0
 216       enddo
 217       do i=1,maxres
 218         ihpb(i)=0
 219         jhpb(i)=0
 220       enddo
 221 C
 222 C Initialize timing.
 223 C
 224       call set_timers
 225 C
 226 C Initialize variables used in minimization.
 227 C
 228 c     maxfun=5000
 229 c     maxit=2000
 230       maxfun=500
 231       maxit=200
 232       tolf=1.0D-2
 233       rtolf=5.0D-4
 234 C
 235 C Initialize the variables responsible for the mode of gradient storage.
 236 C
 237       nfl=0
 238       icg=1
 239 C
 240 C Initialize constants used to split the energy into long- and short-range
 241 C components
 242 C
 243       r_cut=2.0d0
 244       rlamb=0.3d0
 245 #ifndef SPLITELE
 246       nprint_ene=nprint_ene-1
 247 #endif
 248       return
 249       end
 250 c-------------------------------------------------------------------------
 251       block data nazwy
 252       implicit real*8 (a-h,o-z)
 253       include 'DIMENSIONS'
 254       include 'COMMON.NAMES'
 255       include 'COMMON.FFIELD'
 256       data restyp /
 257      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 258      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
 259       data onelet /
 260      &'C','M','F','I','L','V','W','Y','A','G','T',
 261      &'S','Q','N','E','D','H','R','K','P','X'/
 262       data potname /'LJ','LJK','BP','GB','GBV'/
 263       data ename /
 264      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 265      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 266      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 267      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"," "," ",
 268      &   "DFA DIS","DFA TOR","DFA NEI","DFA BET"/
 269       data wname /
 270      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 271      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 272      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR",
 273      &   " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/
 274       data nprint_ene /24/
 275       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 276      & 21,24,25,26,27,0,0,0/
 277       end
 278 c---------------------------------------------------------------------------
 279       subroutine init_int_table
 280       implicit real*8 (a-h,o-z)
 281       include 'DIMENSIONS'
 282 #ifdef MPI
 283       include 'mpif.h'
 284       integer blocklengths(15),displs(15)
 285 #endif
 286       include 'COMMON.CONTROL'
 287       include 'COMMON.SETUP'
 288       include 'COMMON.CHAIN'
 289       include 'COMMON.INTERACT'
 290       include 'COMMON.LOCAL'
 291       include 'COMMON.SBRIDGE'
 292       include 'COMMON.TORCNSTR'
 293       include 'COMMON.IOUNITS'
 294       include 'COMMON.DERIV'
 295       include 'COMMON.CONTACTS'
 296       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
 297      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
 298      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
 299      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
 300      & ielend_all(maxres,0:MaxProcs-1),
 301      & ntask_cont_from_all(0:max_fg_procs-1),
 302      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 303      & ntask_cont_to_all(0:max_fg_procs-1),
 304      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 305       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 306       logical scheck,lprint,flag
 307 #ifdef MPI
 308       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 309      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 310 C... Determine the numbers of start and end SC-SC interaction
 311 C... to deal with by current processor.
 312       do i=0,nfgtasks-1
 313         itask_cont_from(i)=fg_rank
 314         itask_cont_to(i)=fg_rank
 315       enddo
 316       lprint=.false.
 317       if (lprint)
 318      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 319       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 320       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 321       if (lprint)
 322      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 323      &  ' absolute rank',MyRank,
 324      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 325      &  ' my_sc_inde',my_sc_inde
 326       ind_sctint=0
 327       iatsc_s=0
 328       iatsc_e=0
 329 #endif
 330 c      lprint=.false.
 331       do i=1,maxres
 332         nint_gr(i)=0
 333         nscp_gr(i)=0
 334         do j=1,maxint_gr
 335           istart(i,1)=0
 336           iend(i,1)=0
 337           ielstart(i)=0
 338           ielend(i)=0
 339           iscpstart(i,1)=0
 340           iscpend(i,1)=0
 341         enddo
 342       enddo
 343       ind_scint=0
 344       ind_scint_old=0
 345 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 346 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 347       do i=nnt,nct-1
 348         scheck=.false.
 349         do ii=1,nss
 350           if (ihpb(ii).eq.i+nres) then
 351             scheck=.true.
 352             jj=jhpb(ii)-nres
 353             goto 10
 354           endif
 355         enddo
 356    10   continue
 357 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 358         if (scheck) then
 359           if (jj.eq.i+1) then
 360 #ifdef MPI
 361 c            write (iout,*) 'jj=i+1'
 362             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 363      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 364 #else
 365             nint_gr(i)=1
 366             istart(i,1)=i+2
 367             iend(i,1)=nct
 368 #endif
 369           else if (jj.eq.nct) then
 370 #ifdef MPI
 371 c            write (iout,*) 'jj=nct'
 372             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 373      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 374 #else
 375             nint_gr(i)=1
 376             istart(i,1)=i+1
 377             iend(i,1)=nct-1
 378 #endif
 379           else
 380 #ifdef MPI
 381             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 382      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 383             ii=nint_gr(i)+1
 384             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 385      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 386 #else
 387             nint_gr(i)=2
 388             istart(i,1)=i+1
 389             iend(i,1)=jj-1
 390             istart(i,2)=jj+1
 391             iend(i,2)=nct
 392 #endif
 393           endif
 394         else
 395 #ifdef MPI
 396           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 397      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 398 #else
 399           nint_gr(i)=1
 400           istart(i,1)=i+1
 401           iend(i,1)=nct
 402           ind_scint=ind_scint+nct-i
 403 #endif
 404         endif
 405 #ifdef MPI
 406         ind_scint_old=ind_scint
 407 #endif
 408       enddo
 409    12 continue
 410 #ifndef MPI
 411       iatsc_s=nnt
 412       iatsc_e=nct-1
 413 #endif
 414 #ifdef MPI
 415       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 416      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 417 #endif
 418       if (lprint) then
 419       write (iout,'(a)') 'Interaction array:'
 420       do i=iatsc_s,iatsc_e
 421         write (iout,'(i3,2(2x,2i3))')
 422      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 423       enddo
 424       endif
 425       ispp=4
 426 #ifdef MPI
 427 C Now partition the electrostatic-interaction array
 428       npept=nct-nnt
 429       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 430       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 431       if (lprint)
 432      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 433      &  ' absolute rank',MyRank,
 434      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 435      &               ' my_ele_inde',my_ele_inde
 436       iatel_s=0
 437       iatel_e=0
 438       ind_eleint=0
 439       ind_eleint_old=0
 440       do i=nnt,nct-3
 441         ijunk=0
 442         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 443      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 444       enddo ! i
 445    13 continue
 446       if (iatel_s.eq.0) iatel_s=1
 447       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 448 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 449       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 450 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 451 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 452       ind_eleint_vdw=0
 453       ind_eleint_vdw_old=0
 454       iatel_s_vdw=0
 455       iatel_e_vdw=0
 456       do i=nnt,nct-3
 457         ijunk=0
 458         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 459      &    my_ele_inde_vdw,i,
 460      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 461      &    ielend_vdw(i),*15)
 462 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 463 c     &   " ielend_vdw",ielend_vdw(i)
 464       enddo ! i
 465       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 466    15 continue
 467 #else
 468       iatel_s=nnt
 469       iatel_e=nct-5
 470       do i=iatel_s,iatel_e
 471         ielstart(i)=i+4
 472         ielend(i)=nct-1
 473       enddo
 474       iatel_s_vdw=nnt
 475       iatel_e_vdw=nct-3
 476       do i=iatel_s_vdw,iatel_e_vdw
 477         ielstart_vdw(i)=i+2
 478         ielend_vdw(i)=nct-1
 479       enddo
 480 #endif
 481       if (lprint) then
 482         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 483      &  ' absolute rank',MyRank
 484         write (iout,*) 'Electrostatic interaction array:'
 485         do i=iatel_s,iatel_e
 486           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 487         enddo
 488       endif ! lprint
 489 c     iscp=3
 490       iscp=2
 491 C Partition the SC-p interaction array
 492 #ifdef MPI
 493       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 494       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 495       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 496      &  ' absolute rank',myrank,
 497      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 498      &               ' my_scp_inde',my_scp_inde
 499       iatscp_s=0
 500       iatscp_e=0
 501       ind_scpint=0
 502       ind_scpint_old=0
 503       do i=nnt,nct-1
 504         if (i.lt.nnt+iscp) then
 505 cd        write (iout,*) 'i.le.nnt+iscp'
 506           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 507      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 508      &      iscpend(i,1),*14)
 509         else if (i.gt.nct-iscp) then
 510 cd        write (iout,*) 'i.gt.nct-iscp'
 511           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 512      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 513      &      iscpend(i,1),*14)
 514         else
 515           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 516      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 517      &      iscpend(i,1),*14)
 518           ii=nscp_gr(i)+1
 519           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 520      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 521      &      iscpend(i,ii),*14)
 522         endif
 523       enddo ! i
 524    14 continue
 525 #else
 526       iatscp_s=nnt
 527       iatscp_e=nct-1
 528       do i=nnt,nct-1
 529         if (i.lt.nnt+iscp) then
 530           nscp_gr(i)=1
 531           iscpstart(i,1)=i+iscp
 532           iscpend(i,1)=nct
 533         elseif (i.gt.nct-iscp) then
 534           nscp_gr(i)=1
 535           iscpstart(i,1)=nnt
 536           iscpend(i,1)=i-iscp
 537         else
 538           nscp_gr(i)=2
 539           iscpstart(i,1)=nnt
 540           iscpend(i,1)=i-iscp
 541           iscpstart(i,2)=i+iscp
 542           iscpend(i,2)=nct
 543         endif
 544       enddo ! i
 545 #endif
 546       if (lprint) then
 547         write (iout,'(a)') 'SC-p interaction array:'
 548         do i=iatscp_s,iatscp_e
 549           write (iout,'(i3,2(2x,2i3))')
 550      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 551         enddo
 552       endif ! lprint
 553 C Partition local interactions
 554 #ifdef MPI
 555       call int_bounds(nres-2,loc_start,loc_end)
 556       loc_start=loc_start+1
 557       loc_end=loc_end+1
 558       call int_bounds(nres-2,ithet_start,ithet_end)
 559       ithet_start=ithet_start+2
 560       ithet_end=ithet_end+2
 561       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 562       iturn3_start=iturn3_start+nnt
 563       iphi_start=iturn3_start+2
 564       iturn3_end=iturn3_end+nnt
 565       iphi_end=iturn3_end+2
 566       iturn3_start=iturn3_start-1
 567       iturn3_end=iturn3_end-1
 568       call int_bounds(nres-3,itau_start,itau_end)
 569       itau_start=itau_start+3
 570       itau_end=itau_end+3
 571       call int_bounds(nres-3,iphi1_start,iphi1_end)
 572       iphi1_start=iphi1_start+3
 573       iphi1_end=iphi1_end+3
 574       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 575       iturn4_start=iturn4_start+nnt
 576       iphid_start=iturn4_start+2
 577       iturn4_end=iturn4_end+nnt
 578       iphid_end=iturn4_end+2
 579       iturn4_start=iturn4_start-1
 580       iturn4_end=iturn4_end-1
 581       call int_bounds(nres-2,ibond_start,ibond_end)
 582       ibond_start=ibond_start+1
 583       ibond_end=ibond_end+1
 584       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 585       ibondp_start=ibondp_start+nnt
 586       ibondp_end=ibondp_end+nnt
 587       call int_bounds1(nres-1,ivec_start,ivec_end)
 588       print *,"Processor",myrank,fg_rank,fg_rank1,
 589      &  " ivec_start",ivec_start," ivec_end",ivec_end
 590       iset_start=loc_start+2
 591       iset_end=loc_end+2
 592       if (ndih_constr.eq.0) then
 593         idihconstr_start=1
 594         idihconstr_end=0
 595       else
 596         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 597       endif
 598       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 599       nlen=nres-nnt+1
 600       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 601       igrad_start=((2*nlen+1)
 602      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 603       jgrad_start(igrad_start)=
 604      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 605      &    +igrad_start
 606       jgrad_end(igrad_start)=nres
 607       igrad_end=((2*nlen+1)
 608      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 609       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 610       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 611      &    +igrad_end
 612       do i=igrad_start+1,igrad_end-1
 613         jgrad_start(i)=i+1
 614         jgrad_end(i)=nres
 615       enddo
 616       if (lprint) then
 617         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 618      & ' absolute rank',myrank,
 619      & ' loc_start',loc_start,' loc_end',loc_end,
 620      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 621      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 622      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 623      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 624      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 625      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 626      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 627      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 628      & ' iset_start',iset_start,' iset_end',iset_end,
 629      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 630      &   idihconstr_end
 631        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 632      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 633      &   ' ngrad_end',ngrad_end
 634        do i=igrad_start,igrad_end
 635          write(*,*) 'Processor:',fg_rank,myrank,i,
 636      &    jgrad_start(i),jgrad_end(i)
 637        enddo
 638       endif
 639       if (nfgtasks.gt.1) then
 640         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 641      &    MPI_INTEGER,FG_COMM1,IERROR)
 642         iaux=ivec_end-ivec_start+1
 643         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 644      &    MPI_INTEGER,FG_COMM1,IERROR)
 645         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 646      &    MPI_INTEGER,FG_COMM,IERROR)
 647         iaux=iset_end-iset_start+1
 648         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 649      &    MPI_INTEGER,FG_COMM,IERROR)
 650         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 651      &    MPI_INTEGER,FG_COMM,IERROR)
 652         iaux=ibond_end-ibond_start+1
 653         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 654      &    MPI_INTEGER,FG_COMM,IERROR)
 655         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 656      &    MPI_INTEGER,FG_COMM,IERROR)
 657         iaux=ithet_end-ithet_start+1
 658         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 659      &    MPI_INTEGER,FG_COMM,IERROR)
 660         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 661      &    MPI_INTEGER,FG_COMM,IERROR)
 662         iaux=iphi_end-iphi_start+1
 663         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 664      &    MPI_INTEGER,FG_COMM,IERROR)
 665         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 666      &    MPI_INTEGER,FG_COMM,IERROR)
 667         iaux=iphi1_end-iphi1_start+1
 668         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 669      &    MPI_INTEGER,FG_COMM,IERROR)
 670         do i=0,maxprocs-1
 671           do j=1,maxres
 672             ielstart_all(j,i)=0
 673             ielend_all(j,i)=0
 674           enddo
 675         enddo
 676         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 677      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 678         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 679      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 680         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 681      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 682         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 683      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 684         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 685      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 686         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 687      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 688         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 689      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 690         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 691      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 692         if (lprint) then
 693         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 694         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 695         write (iout,*) "iturn3_start_all",
 696      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 697         write (iout,*) "iturn3_end_all",
 698      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 699         write (iout,*) "iturn4_start_all",
 700      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 701         write (iout,*) "iturn4_end_all",
 702      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 703         write (iout,*) "The ielstart_all array"
 704         do i=nnt,nct
 705           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 706         enddo
 707         write (iout,*) "The ielend_all array"
 708         do i=nnt,nct
 709           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 710         enddo
 711         call flush(iout)
 712         endif
 713         ntask_cont_from=0
 714         ntask_cont_to=0
 715         itask_cont_from(0)=fg_rank
 716         itask_cont_to(0)=fg_rank
 717         flag=.false.
 718         do ii=iturn3_start,iturn3_end
 719           call add_int(ii,ii+2,iturn3_sent(1,ii),
 720      &                 ntask_cont_to,itask_cont_to,flag)
 721         enddo
 722         do ii=iturn4_start,iturn4_end
 723           call add_int(ii,ii+3,iturn4_sent(1,ii),
 724      &                 ntask_cont_to,itask_cont_to,flag)
 725         enddo
 726         do ii=iturn3_start,iturn3_end
 727           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 728         enddo
 729         do ii=iturn4_start,iturn4_end
 730           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 731         enddo
 732         if (lprint) then
 733         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 734      &   " ntask_cont_to",ntask_cont_to
 735         write (iout,*) "itask_cont_from",
 736      &    (itask_cont_from(i),i=1,ntask_cont_from)
 737         write (iout,*) "itask_cont_to",
 738      &    (itask_cont_to(i),i=1,ntask_cont_to)
 739         call flush(iout)
 740         endif
 741 c        write (iout,*) "Loop forward"
 742 c        call flush(iout)
 743         do i=iatel_s,iatel_e
 744 c          write (iout,*) "from loop i=",i
 745 c          call flush(iout)
 746           do j=ielstart(i),ielend(i)
 747             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 748           enddo
 749         enddo
 750 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 751 c     &     " iatel_e",iatel_e
 752 c        call flush(iout)
 753         nat_sent=0
 754         do i=iatel_s,iatel_e
 755 c          write (iout,*) "i",i," ielstart",ielstart(i),
 756 c     &      " ielend",ielend(i)
 757 c          call flush(iout)
 758           flag=.false.
 759           do j=ielstart(i),ielend(i)
 760             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 761      &                   itask_cont_to,flag)
 762           enddo
 763           if (flag) then
 764             nat_sent=nat_sent+1
 765             iat_sent(nat_sent)=i
 766           endif
 767         enddo
 768         if (lprint) then
 769         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 770      &   " ntask_cont_to",ntask_cont_to
 771         write (iout,*) "itask_cont_from",
 772      &    (itask_cont_from(i),i=1,ntask_cont_from)
 773         write (iout,*) "itask_cont_to",
 774      &    (itask_cont_to(i),i=1,ntask_cont_to)
 775         call flush(iout)
 776         write (iout,*) "iint_sent"
 777         do i=1,nat_sent
 778           ii=iat_sent(i)
 779           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 780      &      j=ielstart(ii),ielend(ii))
 781         enddo
 782         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 783      &    " iturn3_end",iturn3_end
 784         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 785      &      i=iturn3_start,iturn3_end)
 786         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 787      &    " iturn4_end",iturn4_end
 788         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 789      &      i=iturn4_start,iturn4_end)
 790         call flush(iout)
 791         endif
 792         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 793      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 794 c        write (iout,*) "Gather ntask_cont_from ended"
 795 c        call flush(iout)
 796         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 797      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 798      &   FG_COMM,IERR)
 799 c        write (iout,*) "Gather itask_cont_from ended"
 800 c        call flush(iout)
 801         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 802      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 803 c        write (iout,*) "Gather ntask_cont_to ended"
 804 c        call flush(iout)
 805         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 806      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 807 c        write (iout,*) "Gather itask_cont_to ended"
 808 c        call flush(iout)
 809         if (fg_rank.eq.king) then
 810           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 811           do i=0,nfgtasks-1
 812             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 813      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 814           enddo
 815           write (iout,*)
 816           call flush(iout)
 817           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 818           do i=0,nfgtasks-1
 819             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 820      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 821           enddo
 822           write (iout,*)
 823           call flush(iout)
 824 C Check if every send will have a matching receive
 825           ncheck_to=0
 826           ncheck_from=0
 827           do i=0,nfgtasks-1
 828             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 829             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 830           enddo
 831           write (iout,*) "Control sums",ncheck_from,ncheck_to
 832           if (ncheck_from.ne.ncheck_to) then
 833             write (iout,*) "Error: #receive differs from #send."
 834             write (iout,*) "Terminating program...!"
 835             call flush(iout)
 836             flag=.false.
 837           else
 838             flag=.true.
 839             do i=0,nfgtasks-1
 840               do j=1,ntask_cont_to_all(i)
 841                 ii=itask_cont_to_all(j,i)
 842                 do k=1,ntask_cont_from_all(ii)
 843                   if (itask_cont_from_all(k,ii).eq.i) then
 844                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 845                     exit
 846                   endif
 847                 enddo
 848                 if (k.eq.ntask_cont_from_all(ii)+1) then
 849                   flag=.false.
 850                   write (iout,*) "Error: send by",j," to",ii,
 851      &            " would have no matching receive"
 852                 endif
 853               enddo
 854             enddo
 855           endif
 856           if (.not.flag) then
 857             write (iout,*) "Unmatched sends; terminating program"
 858             call flush(iout)
 859           endif
 860         endif
 861         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 862 c        write (iout,*) "flag broadcast ended flag=",flag
 863 c        call flush(iout)
 864         if (.not.flag) then
 865           call MPI_Finalize(IERROR)
 866           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 867         endif
 868         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 869 c        write (iout,*) "MPI_Comm_group ended"
 870 c        call flush(iout)
 871         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 872      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 873         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 874      &    CONT_TO_GROUP,IERR)
 875         do i=1,nat_sent
 876           ii=iat_sent(i)
 877           iaux=4*(ielend(ii)-ielstart(ii)+1)
 878           call MPI_Group_translate_ranks(fg_group,iaux,
 879      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 880      &      iint_sent_local(1,ielstart(ii),i),IERR )
 881 c          write (iout,*) "Ranks translated i=",i
 882 c          call flush(iout)
 883         enddo
 884         iaux=4*(iturn3_end-iturn3_start+1)
 885         call MPI_Group_translate_ranks(fg_group,iaux,
 886      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 887      &      iturn3_sent_local(1,iturn3_start),IERR)
 888         iaux=4*(iturn4_end-iturn4_start+1)
 889         call MPI_Group_translate_ranks(fg_group,iaux,
 890      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 891      &      iturn4_sent_local(1,iturn4_start),IERR)
 892         if (lprint) then
 893         write (iout,*) "iint_sent_local"
 894         do i=1,nat_sent
 895           ii=iat_sent(i)
 896           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 897      &      j=ielstart(ii),ielend(ii))
 898           call flush(iout)
 899         enddo
 900         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 901      &    " iturn3_end",iturn3_end
 902         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 903      &      i=iturn3_start,iturn3_end)
 904         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 905      &    " iturn4_end",iturn4_end
 906         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 907      &      i=iturn4_start,iturn4_end)
 908         call flush(iout)
 909         endif
 910         call MPI_Group_free(fg_group,ierr)
 911         call MPI_Group_free(cont_from_group,ierr)
 912         call MPI_Group_free(cont_to_group,ierr)
 913         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 914         call MPI_Type_commit(MPI_UYZ,IERROR)
 915         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 916      &    IERROR)
 917         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 918         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 919         call MPI_Type_commit(MPI_MU,IERROR)
 920         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 921         call MPI_Type_commit(MPI_MAT1,IERROR)
 922         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 923         call MPI_Type_commit(MPI_MAT2,IERROR)
 924         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 925         call MPI_Type_commit(MPI_THET,IERROR)
 926         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 927         call MPI_Type_commit(MPI_GAM,IERROR)
 928 #ifndef MATGATHER
 929 c 9/22/08 Derived types to send matrices which appear in correlation terms
 930         do i=0,nfgtasks-1
 931           if (ivec_count(i).eq.ivec_count(0)) then
 932             lentyp(i)=0
 933           else
 934             lentyp(i)=1
 935           endif
 936         enddo
 937         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 938         if (ind_typ.eq.0) then
 939           ichunk=ivec_count(0)
 940         else
 941           ichunk=ivec_count(1)
 942         endif
 943 c        do i=1,4
 944 c          blocklengths(i)=4
 945 c        enddo
 946 c        displs(1)=0
 947 c        do i=2,4
 948 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 949 c        enddo
 950 c        do i=1,4
 951 c          blocklengths(i)=blocklengths(i)*ichunk
 952 c        enddo
 953 c        write (iout,*) "blocklengths and displs"
 954 c        do i=1,4
 955 c          write (iout,*) i,blocklengths(i),displs(i)
 956 c        enddo
 957 c        call flush(iout)
 958 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 959 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 960 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 961 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 962 c        do i=1,4
 963 c          blocklengths(i)=2
 964 c        enddo
 965 c        displs(1)=0
 966 c        do i=2,4
 967 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 968 c        enddo
 969 c        do i=1,4
 970 c          blocklengths(i)=blocklengths(i)*ichunk
 971 c        enddo
 972 c        write (iout,*) "blocklengths and displs"
 973 c        do i=1,4
 974 c          write (iout,*) i,blocklengths(i),displs(i)
 975 c        enddo
 976 c        call flush(iout)
 977 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 978 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
 979 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
 980 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
 981         do i=1,8
 982           blocklengths(i)=2
 983         enddo
 984         displs(1)=0
 985         do i=2,8
 986           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 987         enddo
 988         do i=1,15
 989           blocklengths(i)=blocklengths(i)*ichunk
 990         enddo
 991         call MPI_Type_indexed(8,blocklengths,displs,
 992      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
 993         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
 994         do i=1,8
 995           blocklengths(i)=4
 996         enddo
 997         displs(1)=0
 998         do i=2,8
 999           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1000         enddo
1001         do i=1,15
1002           blocklengths(i)=blocklengths(i)*ichunk
1003         enddo
1004         call MPI_Type_indexed(8,blocklengths,displs,
1005      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1006         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1007         do i=1,6
1008           blocklengths(i)=4
1009         enddo
1010         displs(1)=0
1011         do i=2,6
1012           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1013         enddo
1014         do i=1,6
1015           blocklengths(i)=blocklengths(i)*ichunk
1016         enddo
1017         call MPI_Type_indexed(6,blocklengths,displs,
1018      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1019         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1020         do i=1,2
1021           blocklengths(i)=8
1022         enddo
1023         displs(1)=0
1024         do i=2,2
1025           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1026         enddo
1027         do i=1,2
1028           blocklengths(i)=blocklengths(i)*ichunk
1029         enddo
1030         call MPI_Type_indexed(2,blocklengths,displs,
1031      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1032         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1033         do i=1,4
1034           blocklengths(i)=1
1035         enddo
1036         displs(1)=0
1037         do i=2,4
1038           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1039         enddo
1040         do i=1,4
1041           blocklengths(i)=blocklengths(i)*ichunk
1042         enddo
1043         call MPI_Type_indexed(4,blocklengths,displs,
1044      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1045         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1046         enddo
1047 #endif
1048       endif
1049       iint_start=ivec_start+1
1050       iint_end=ivec_end+1
1051       do i=0,nfgtasks-1
1052           iint_count(i)=ivec_count(i)
1053           iint_displ(i)=ivec_displ(i)
1054           ivec_displ(i)=ivec_displ(i)-1
1055           iset_displ(i)=iset_displ(i)-1
1056           ithet_displ(i)=ithet_displ(i)-1
1057           iphi_displ(i)=iphi_displ(i)-1
1058           iphi1_displ(i)=iphi1_displ(i)-1
1059           ibond_displ(i)=ibond_displ(i)-1
1060       enddo
1061       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1062      &     .and. (me.eq.0 .or. out1file)) then
1063         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1064         do i=0,nfgtasks-1
1065           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1066      &      iset_count(i)
1067         enddo
1068         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1069      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1070         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1071         do i=0,nfgtasks-1
1072           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1073      &      iphi1_displ(i)
1074         enddo
1075         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1076      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1077      & ' SC-p interactions','were distributed among',nfgtasks,
1078      & ' fine-grain processors.'
1079       endif
1080 #else
1081       loc_start=2
1082       loc_end=nres-1
1083       ithet_start=3
1084       ithet_end=nres
1085       iturn3_start=nnt
1086       iturn3_end=nct-3
1087       iturn4_start=nnt
1088       iturn4_end=nct-4
1089       iphi_start=nnt+3
1090       iphi_end=nct
1091       iphi1_start=4
1092       iphi1_end=nres
1093       idihconstr_start=1
1094       idihconstr_end=ndih_constr
1095       iphid_start=iphi_start
1096       iphid_end=iphi_end-1
1097       itau_start=4
1098       itau_end=nres
1099       ibond_start=2
1100       ibond_end=nres-1
1101       ibondp_start=nnt+1
1102       ibondp_end=nct
1103       ivec_start=1
1104       ivec_end=nres-1
1105       iset_start=3
1106       iset_end=nres+1
1107       iint_start=2
1108       iint_end=nres-1
1109 #endif
1110       return
1111       end
1112 #ifdef MPI
1113 c---------------------------------------------------------------------------
1114       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1115       implicit none
1116       include "DIMENSIONS"
1117       include "COMMON.INTERACT"
1118       include "COMMON.SETUP"
1119       include "COMMON.IOUNITS"
1120       integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
1121       logical flag
1122       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1123      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1124       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1125      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1126      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1127      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1128      & ielend_all(maxres,0:MaxProcs-1)
1129       integer iproc,isent,k,l
1130 c Determines whether to send interaction ii,jj to other processors; a given
1131 c interaction can be sent to at most 2 processors.
1132 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1133 c one processor, otherwise flag is unchanged from the input value.
1134       isent=0
1135       itask(1)=fg_rank
1136       itask(2)=fg_rank
1137       itask(3)=fg_rank
1138       itask(4)=fg_rank
1139 c      write (iout,*) "ii",ii," jj",jj
1140 c Loop over processors to check if anybody could need interaction ii,jj
1141       do iproc=0,fg_rank-1
1142 c Check if the interaction matches any turn3 at iproc
1143         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1144           l=k+2
1145           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1146      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1147      &    then
1148 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1149 c            call flush(iout)
1150             flag=.true.
1151             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1152      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1153               isent=isent+1
1154               itask(isent)=iproc
1155               call add_task(iproc,ntask_cont_to,itask_cont_to)
1156             endif
1157           endif
1158         enddo
1159 C Check if the interaction matches any turn4 at iproc
1160         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1161           l=k+3
1162           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1163      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1164      &    then
1165 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1166 c            call flush(iout)
1167             flag=.true.
1168             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1169      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1170               isent=isent+1
1171               itask(isent)=iproc
1172               call add_task(iproc,ntask_cont_to,itask_cont_to)
1173             endif
1174           endif
1175         enddo
1176         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1177      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1178           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1179      &        ielend_all(ii-1,iproc).ge.jj-1) then
1180             flag=.true.
1181             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1182      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1183               isent=isent+1
1184               itask(isent)=iproc
1185               call add_task(iproc,ntask_cont_to,itask_cont_to)
1186             endif
1187           endif
1188           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1189      &        ielend_all(ii-1,iproc).ge.jj+1) then
1190             flag=.true.
1191             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1192      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1193               isent=isent+1
1194               itask(isent)=iproc
1195               call add_task(iproc,ntask_cont_to,itask_cont_to)
1196             endif
1197           endif
1198         endif
1199       enddo
1200       return
1201       end
1202 c---------------------------------------------------------------------------
1203       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1204       implicit none
1205       include "DIMENSIONS"
1206       include "COMMON.INTERACT"
1207       include "COMMON.SETUP"
1208       include "COMMON.IOUNITS"
1209       integer ii,jj,itask(2),ntask_cont_from,
1210      & itask_cont_from(0:MaxProcs-1)
1211       logical flag
1212       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1213      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1214       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1215      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1216      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1217      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1218      & ielend_all(maxres,0:MaxProcs-1)
1219       integer iproc,k,l
1220       do iproc=fg_rank+1,nfgtasks-1
1221         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1222           l=k+2
1223           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1224      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1225      &    then
1226 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1227             call add_task(iproc,ntask_cont_from,itask_cont_from)
1228           endif
1229         enddo
1230         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1231           l=k+3
1232           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1233      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1234      &    then
1235 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1236             call add_task(iproc,ntask_cont_from,itask_cont_from)
1237           endif
1238         enddo
1239         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1240           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1241      &    then
1242             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1243      &          jj+1.le.ielend_all(ii+1,iproc)) then
1244               call add_task(iproc,ntask_cont_from,itask_cont_from)
1245             endif
1246             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1247      &          jj-1.le.ielend_all(ii+1,iproc)) then
1248               call add_task(iproc,ntask_cont_from,itask_cont_from)
1249             endif
1250           endif
1251           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1252      &    then
1253             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1254      &          jj-1.le.ielend_all(ii-1,iproc)) then
1255               call add_task(iproc,ntask_cont_from,itask_cont_from)
1256             endif
1257             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1258      &          jj+1.le.ielend_all(ii-1,iproc)) then
1259                call add_task(iproc,ntask_cont_from,itask_cont_from)
1260             endif
1261           endif
1262         endif
1263       enddo
1264       return
1265       end
1266 c---------------------------------------------------------------------------
1267       subroutine add_task(iproc,ntask_cont,itask_cont)
1268       implicit none
1269       include "DIMENSIONS"
1270       integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
1271       integer ii
1272       do ii=1,ntask_cont
1273         if (itask_cont(ii).eq.iproc) return
1274       enddo
1275       ntask_cont=ntask_cont+1
1276       itask_cont(ntask_cont)=iproc
1277       return
1278       end
1279 c---------------------------------------------------------------------------
1280       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1281       implicit real*8 (a-h,o-z)
1282       include 'DIMENSIONS'
1283       include 'mpif.h'
1284       include 'COMMON.SETUP'
1285       integer total_ints,lower_bound,upper_bound
1286       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1287       nint=total_ints/nfgtasks
1288       do i=1,nfgtasks
1289         int4proc(i-1)=nint
1290       enddo
1291       nexcess=total_ints-nint*nfgtasks
1292       do i=1,nexcess
1293         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1294       enddo
1295       lower_bound=0
1296       do i=0,fg_rank-1
1297         lower_bound=lower_bound+int4proc(i)
1298       enddo
1299       upper_bound=lower_bound+int4proc(fg_rank)
1300       lower_bound=lower_bound+1
1301       return
1302       end
1303 c---------------------------------------------------------------------------
1304       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1305       implicit real*8 (a-h,o-z)
1306       include 'DIMENSIONS'
1307       include 'mpif.h'
1308       include 'COMMON.SETUP'
1309       integer total_ints,lower_bound,upper_bound
1310       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1311       nint=total_ints/nfgtasks1
1312       do i=1,nfgtasks1
1313         int4proc(i-1)=nint
1314       enddo
1315       nexcess=total_ints-nint*nfgtasks1
1316       do i=1,nexcess
1317         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1318       enddo
1319       lower_bound=0
1320       do i=0,fg_rank1-1
1321         lower_bound=lower_bound+int4proc(i)
1322       enddo
1323       upper_bound=lower_bound+int4proc(fg_rank1)
1324       lower_bound=lower_bound+1
1325       return
1326       end
1327 c---------------------------------------------------------------------------
1328       subroutine int_partition(int_index,lower_index,upper_index,atom,
1329      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1330       implicit real*8 (a-h,o-z)
1331       include 'DIMENSIONS'
1332       include 'COMMON.IOUNITS'
1333       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1334      & first_atom,last_atom,int_gr,jat_start,jat_end
1335       logical lprn
1336       lprn=.false.
1337       if (lprn) write (iout,*) 'int_index=',int_index
1338       int_index_old=int_index
1339       int_index=int_index+last_atom-first_atom+1
1340       if (lprn)
1341      &   write (iout,*) 'int_index=',int_index,
1342      &               ' int_index_old',int_index_old,
1343      &               ' lower_index=',lower_index,
1344      &               ' upper_index=',upper_index,
1345      &               ' atom=',atom,' first_atom=',first_atom,
1346      &               ' last_atom=',last_atom
1347       if (int_index.ge.lower_index) then
1348         int_gr=int_gr+1
1349         if (at_start.eq.0) then
1350           at_start=atom
1351           jat_start=first_atom-1+lower_index-int_index_old
1352         else
1353           jat_start=first_atom
1354         endif
1355         if (lprn) write (iout,*) 'jat_start',jat_start
1356         if (int_index.ge.upper_index) then
1357           at_end=atom
1358           jat_end=first_atom-1+upper_index-int_index_old
1359           return1
1360         else
1361           jat_end=last_atom
1362         endif
1363         if (lprn) write (iout,*) 'jat_end',jat_end
1364       endif
1365       return
1366       end
1367 #endif
1368 c------------------------------------------------------------------------------
1369       subroutine hpb_partition
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372 #ifdef MPI
1373       include 'mpif.h'
1374 #endif
1375       include 'COMMON.SBRIDGE'
1376       include 'COMMON.IOUNITS'
1377       include 'COMMON.SETUP'
1378       include 'COMMON.CONTROL'
1379 #ifdef MPI
1380       call int_bounds(nhpb,link_start,link_end)
1381       if (.not. out1file)
1382      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1383      &  ' absolute rank',MyRank,
1384      &  ' nhpb',nhpb,' link_start=',link_start,
1385      &  ' link_end',link_end
1386 #else
1387       link_start=1
1388       link_end=nhpb
1389 #endif
1390       return
1391       end