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