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      &'DD' ,'DPR','DLY','DAR','DHI','DAS','DGL','DSG','DGN','DSN','DTH',
 258      &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
 259      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 260      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
 261       data onelet /
 262      &'z','p','k','r','h','d','e','n','q','s','t','g',
 263      &'a','y','w','v','l','i','f','m','c','x',
 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:MaxProcs),
 300      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
 301      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
 302      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
 303      & ielend_all(maxres,0:MaxProcs-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         do ii=1,nss
 353           if (ihpb(ii).eq.i+nres) then
 354             scheck=.true.
 355             jj=jhpb(ii)-nres
 356             goto 10
 357           endif
 358         enddo
 359    10   continue
 360 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 361         if (scheck) then
 362           if (jj.eq.i+1) then
 363 #ifdef MPI
 364 c            write (iout,*) 'jj=i+1'
 365             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 366      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 367 #else
 368             nint_gr(i)=1
 369             istart(i,1)=i+2
 370             iend(i,1)=nct
 371 #endif
 372           else if (jj.eq.nct) then
 373 #ifdef MPI
 374 c            write (iout,*) 'jj=nct'
 375             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 376      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 377 #else
 378             nint_gr(i)=1
 379             istart(i,1)=i+1
 380             iend(i,1)=nct-1
 381 #endif
 382           else
 383 #ifdef MPI
 384             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 385      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 386             ii=nint_gr(i)+1
 387             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 388      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 389 #else
 390             nint_gr(i)=2
 391             istart(i,1)=i+1
 392             iend(i,1)=jj-1
 393             istart(i,2)=jj+1
 394             iend(i,2)=nct
 395 #endif
 396           endif
 397         else
 398 #ifdef MPI
 399           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 400      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 401 #else
 402           nint_gr(i)=1
 403           istart(i,1)=i+1
 404           iend(i,1)=nct
 405           ind_scint=ind_scint+nct-i
 406 #endif
 407         endif
 408 #ifdef MPI
 409         ind_scint_old=ind_scint
 410 #endif
 411       enddo
 412    12 continue
 413 #ifndef MPI
 414       iatsc_s=nnt
 415       iatsc_e=nct-1
 416 #endif
 417 #ifdef MPI
 418       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 419      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 420 #endif
 421       if (lprint) then
 422       write (iout,'(a)') 'Interaction array:'
 423       do i=iatsc_s,iatsc_e
 424         write (iout,'(i3,2(2x,2i3))')
 425      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 426       enddo
 427       endif
 428       ispp=4
 429 #ifdef MPI
 430 C Now partition the electrostatic-interaction array
 431       npept=nct-nnt
 432       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 433       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 434       if (lprint)
 435      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 436      &  ' absolute rank',MyRank,
 437      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 438      &               ' my_ele_inde',my_ele_inde
 439       iatel_s=0
 440       iatel_e=0
 441       ind_eleint=0
 442       ind_eleint_old=0
 443       do i=nnt,nct-3
 444         ijunk=0
 445         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 446      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 447       enddo ! i
 448    13 continue
 449       if (iatel_s.eq.0) iatel_s=1
 450       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 451 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 452       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 453 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 454 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 455       ind_eleint_vdw=0
 456       ind_eleint_vdw_old=0
 457       iatel_s_vdw=0
 458       iatel_e_vdw=0
 459       do i=nnt,nct-3
 460         ijunk=0
 461         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 462      &    my_ele_inde_vdw,i,
 463      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 464      &    ielend_vdw(i),*15)
 465 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 466 c     &   " ielend_vdw",ielend_vdw(i)
 467       enddo ! i
 468       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 469    15 continue
 470 #else
 471       iatel_s=nnt
 472       iatel_e=nct-5
 473       do i=iatel_s,iatel_e
 474         ielstart(i)=i+4
 475         ielend(i)=nct-1
 476       enddo
 477       iatel_s_vdw=nnt
 478       iatel_e_vdw=nct-3
 479       do i=iatel_s_vdw,iatel_e_vdw
 480         ielstart_vdw(i)=i+2
 481         ielend_vdw(i)=nct-1
 482       enddo
 483 #endif
 484       if (lprint) then
 485         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 486      &  ' absolute rank',MyRank
 487         write (iout,*) 'Electrostatic interaction array:'
 488         do i=iatel_s,iatel_e
 489           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 490         enddo
 491       endif ! lprint
 492 c     iscp=3
 493       iscp=2
 494 C Partition the SC-p interaction array
 495 #ifdef MPI
 496       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 497       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 498       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 499      &  ' absolute rank',myrank,
 500      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 501      &               ' my_scp_inde',my_scp_inde
 502       iatscp_s=0
 503       iatscp_e=0
 504       ind_scpint=0
 505       ind_scpint_old=0
 506       do i=nnt,nct-1
 507         if (i.lt.nnt+iscp) then
 508 cd        write (iout,*) 'i.le.nnt+iscp'
 509           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 510      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 511      &      iscpend(i,1),*14)
 512         else if (i.gt.nct-iscp) then
 513 cd        write (iout,*) 'i.gt.nct-iscp'
 514           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 515      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 516      &      iscpend(i,1),*14)
 517         else
 518           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 519      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 520      &      iscpend(i,1),*14)
 521           ii=nscp_gr(i)+1
 522           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 523      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 524      &      iscpend(i,ii),*14)
 525         endif
 526       enddo ! i
 527    14 continue
 528 #else
 529       iatscp_s=nnt
 530       iatscp_e=nct-1
 531       do i=nnt,nct-1
 532         if (i.lt.nnt+iscp) then
 533           nscp_gr(i)=1
 534           iscpstart(i,1)=i+iscp
 535           iscpend(i,1)=nct
 536         elseif (i.gt.nct-iscp) then
 537           nscp_gr(i)=1
 538           iscpstart(i,1)=nnt
 539           iscpend(i,1)=i-iscp
 540         else
 541           nscp_gr(i)=2
 542           iscpstart(i,1)=nnt
 543           iscpend(i,1)=i-iscp
 544           iscpstart(i,2)=i+iscp
 545           iscpend(i,2)=nct
 546         endif
 547       enddo ! i
 548 #endif
 549       if (lprint) then
 550         write (iout,'(a)') 'SC-p interaction array:'
 551         do i=iatscp_s,iatscp_e
 552           write (iout,'(i3,2(2x,2i3))')
 553      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 554         enddo
 555       endif ! lprint
 556 C Partition local interactions
 557 #ifdef MPI
 558       call int_bounds(nres-2,loc_start,loc_end)
 559       loc_start=loc_start+1
 560       loc_end=loc_end+1
 561       call int_bounds(nres-2,ithet_start,ithet_end)
 562       ithet_start=ithet_start+2
 563       ithet_end=ithet_end+2
 564       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 565       iturn3_start=iturn3_start+nnt
 566       iphi_start=iturn3_start+2
 567       iturn3_end=iturn3_end+nnt
 568       iphi_end=iturn3_end+2
 569       iturn3_start=iturn3_start-1
 570       iturn3_end=iturn3_end-1
 571       call int_bounds(nres-3,itau_start,itau_end)
 572       itau_start=itau_start+3
 573       itau_end=itau_end+3
 574       call int_bounds(nres-3,iphi1_start,iphi1_end)
 575       iphi1_start=iphi1_start+3
 576       iphi1_end=iphi1_end+3
 577       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 578       iturn4_start=iturn4_start+nnt
 579       iphid_start=iturn4_start+2
 580       iturn4_end=iturn4_end+nnt
 581       iphid_end=iturn4_end+2
 582       iturn4_start=iturn4_start-1
 583       iturn4_end=iturn4_end-1
 584       call int_bounds(nres-2,ibond_start,ibond_end)
 585       ibond_start=ibond_start+1
 586       ibond_end=ibond_end+1
 587       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 588       ibondp_start=ibondp_start+nnt
 589       ibondp_end=ibondp_end+nnt
 590       call int_bounds1(nres-1,ivec_start,ivec_end)
 591       print *,"Processor",myrank,fg_rank,fg_rank1,
 592      &  " ivec_start",ivec_start," ivec_end",ivec_end
 593       iset_start=loc_start+2
 594       iset_end=loc_end+2
 595       if (ndih_constr.eq.0) then
 596         idihconstr_start=1
 597         idihconstr_end=0
 598       else
 599         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 600       endif
 601       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 602       nlen=nres-nnt+1
 603       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 604       igrad_start=((2*nlen+1)
 605      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 606       jgrad_start(igrad_start)=
 607      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 608      &    +igrad_start
 609       jgrad_end(igrad_start)=nres
 610       igrad_end=((2*nlen+1)
 611      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 612       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 613       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 614      &    +igrad_end
 615       do i=igrad_start+1,igrad_end-1
 616         jgrad_start(i)=i+1
 617         jgrad_end(i)=nres
 618       enddo
 619       if (lprint) then
 620         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 621      & ' absolute rank',myrank,
 622      & ' loc_start',loc_start,' loc_end',loc_end,
 623      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 624      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 625      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 626      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 627      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 628      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 629      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 630      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 631      & ' iset_start',iset_start,' iset_end',iset_end,
 632      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 633      &   idihconstr_end
 634        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 635      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 636      &   ' ngrad_end',ngrad_end
 637        do i=igrad_start,igrad_end
 638          write(*,*) 'Processor:',fg_rank,myrank,i,
 639      &    jgrad_start(i),jgrad_end(i)
 640        enddo
 641       endif
 642       if (nfgtasks.gt.1) then
 643         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 644      &    MPI_INTEGER,FG_COMM1,IERROR)
 645         iaux=ivec_end-ivec_start+1
 646         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 647      &    MPI_INTEGER,FG_COMM1,IERROR)
 648         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 649      &    MPI_INTEGER,FG_COMM,IERROR)
 650         iaux=iset_end-iset_start+1
 651         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 652      &    MPI_INTEGER,FG_COMM,IERROR)
 653         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 654      &    MPI_INTEGER,FG_COMM,IERROR)
 655         iaux=ibond_end-ibond_start+1
 656         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 657      &    MPI_INTEGER,FG_COMM,IERROR)
 658         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 659      &    MPI_INTEGER,FG_COMM,IERROR)
 660         iaux=ithet_end-ithet_start+1
 661         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 662      &    MPI_INTEGER,FG_COMM,IERROR)
 663         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 664      &    MPI_INTEGER,FG_COMM,IERROR)
 665         iaux=iphi_end-iphi_start+1
 666         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 667      &    MPI_INTEGER,FG_COMM,IERROR)
 668         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 669      &    MPI_INTEGER,FG_COMM,IERROR)
 670         iaux=iphi1_end-iphi1_start+1
 671         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 672      &    MPI_INTEGER,FG_COMM,IERROR)
 673         do i=0,maxprocs-1
 674           do j=1,maxres
 675             ielstart_all(j,i)=0
 676             ielend_all(j,i)=0
 677           enddo
 678         enddo
 679         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 680      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 681         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 682      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 683         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 684      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 685         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 686      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 687         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 688      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 689         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 690      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 691         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 692      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 693         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 694      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 695         if (lprint) then
 696         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 697         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 698         write (iout,*) "iturn3_start_all",
 699      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 700         write (iout,*) "iturn3_end_all",
 701      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 702         write (iout,*) "iturn4_start_all",
 703      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 704         write (iout,*) "iturn4_end_all",
 705      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 706         write (iout,*) "The ielstart_all array"
 707         do i=nnt,nct
 708           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 709         enddo
 710         write (iout,*) "The ielend_all array"
 711         do i=nnt,nct
 712           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 713         enddo
 714         call flush(iout)
 715         endif
 716         ntask_cont_from=0
 717         ntask_cont_to=0
 718         itask_cont_from(0)=fg_rank
 719         itask_cont_to(0)=fg_rank
 720         flag=.false.
 721         do ii=iturn3_start,iturn3_end
 722           call add_int(ii,ii+2,iturn3_sent(1,ii),
 723      &                 ntask_cont_to,itask_cont_to,flag)
 724         enddo
 725         do ii=iturn4_start,iturn4_end
 726           call add_int(ii,ii+3,iturn4_sent(1,ii),
 727      &                 ntask_cont_to,itask_cont_to,flag)
 728         enddo
 729         do ii=iturn3_start,iturn3_end
 730           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 731         enddo
 732         do ii=iturn4_start,iturn4_end
 733           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 734         enddo
 735         if (lprint) then
 736         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 737      &   " ntask_cont_to",ntask_cont_to
 738         write (iout,*) "itask_cont_from",
 739      &    (itask_cont_from(i),i=1,ntask_cont_from)
 740         write (iout,*) "itask_cont_to",
 741      &    (itask_cont_to(i),i=1,ntask_cont_to)
 742         call flush(iout)
 743         endif
 744 c        write (iout,*) "Loop forward"
 745 c        call flush(iout)
 746         do i=iatel_s,iatel_e
 747 c          write (iout,*) "from loop i=",i
 748 c          call flush(iout)
 749           do j=ielstart(i),ielend(i)
 750             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 751           enddo
 752         enddo
 753 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 754 c     &     " iatel_e",iatel_e
 755 c        call flush(iout)
 756         nat_sent=0
 757         do i=iatel_s,iatel_e
 758 c          write (iout,*) "i",i," ielstart",ielstart(i),
 759 c     &      " ielend",ielend(i)
 760 c          call flush(iout)
 761           flag=.false.
 762           do j=ielstart(i),ielend(i)
 763             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 764      &                   itask_cont_to,flag)
 765           enddo
 766           if (flag) then
 767             nat_sent=nat_sent+1
 768             iat_sent(nat_sent)=i
 769           endif
 770         enddo
 771         if (lprint) then
 772         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 773      &   " ntask_cont_to",ntask_cont_to
 774         write (iout,*) "itask_cont_from",
 775      &    (itask_cont_from(i),i=1,ntask_cont_from)
 776         write (iout,*) "itask_cont_to",
 777      &    (itask_cont_to(i),i=1,ntask_cont_to)
 778         call flush(iout)
 779         write (iout,*) "iint_sent"
 780         do i=1,nat_sent
 781           ii=iat_sent(i)
 782           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 783      &      j=ielstart(ii),ielend(ii))
 784         enddo
 785         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 786      &    " iturn3_end",iturn3_end
 787         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 788      &      i=iturn3_start,iturn3_end)
 789         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 790      &    " iturn4_end",iturn4_end
 791         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 792      &      i=iturn4_start,iturn4_end)
 793         call flush(iout)
 794         endif
 795         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 796      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 797 c        write (iout,*) "Gather ntask_cont_from ended"
 798 c        call flush(iout)
 799         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 800      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 801      &   FG_COMM,IERR)
 802 c        write (iout,*) "Gather itask_cont_from ended"
 803 c        call flush(iout)
 804         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 805      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 806 c        write (iout,*) "Gather ntask_cont_to ended"
 807 c        call flush(iout)
 808         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 809      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 810 c        write (iout,*) "Gather itask_cont_to ended"
 811 c        call flush(iout)
 812         if (fg_rank.eq.king) then
 813           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 814           do i=0,nfgtasks-1
 815             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 816      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 817           enddo
 818           write (iout,*)
 819           call flush(iout)
 820           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 821           do i=0,nfgtasks-1
 822             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 823      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 824           enddo
 825           write (iout,*)
 826           call flush(iout)
 827 C Check if every send will have a matching receive
 828           ncheck_to=0
 829           ncheck_from=0
 830           do i=0,nfgtasks-1
 831             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 832             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 833           enddo
 834           write (iout,*) "Control sums",ncheck_from,ncheck_to
 835           if (ncheck_from.ne.ncheck_to) then
 836             write (iout,*) "Error: #receive differs from #send."
 837             write (iout,*) "Terminating program...!"
 838             call flush(iout)
 839             flag=.false.
 840           else
 841             flag=.true.
 842             do i=0,nfgtasks-1
 843               do j=1,ntask_cont_to_all(i)
 844                 ii=itask_cont_to_all(j,i)
 845                 do k=1,ntask_cont_from_all(ii)
 846                   if (itask_cont_from_all(k,ii).eq.i) then
 847                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 848                     exit
 849                   endif
 850                 enddo
 851                 if (k.eq.ntask_cont_from_all(ii)+1) then
 852                   flag=.false.
 853                   write (iout,*) "Error: send by",j," to",ii,
 854      &            " would have no matching receive"
 855                 endif
 856               enddo
 857             enddo
 858           endif
 859           if (.not.flag) then
 860             write (iout,*) "Unmatched sends; terminating program"
 861             call flush(iout)
 862           endif
 863         endif
 864         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 865 c        write (iout,*) "flag broadcast ended flag=",flag
 866 c        call flush(iout)
 867         if (.not.flag) then
 868           call MPI_Finalize(IERROR)
 869           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 870         endif
 871         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 872 c        write (iout,*) "MPI_Comm_group ended"
 873 c        call flush(iout)
 874         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 875      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 876         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 877      &    CONT_TO_GROUP,IERR)
 878         do i=1,nat_sent
 879           ii=iat_sent(i)
 880           iaux=4*(ielend(ii)-ielstart(ii)+1)
 881           call MPI_Group_translate_ranks(fg_group,iaux,
 882      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 883      &      iint_sent_local(1,ielstart(ii),i),IERR )
 884 c          write (iout,*) "Ranks translated i=",i
 885 c          call flush(iout)
 886         enddo
 887         iaux=4*(iturn3_end-iturn3_start+1)
 888         call MPI_Group_translate_ranks(fg_group,iaux,
 889      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 890      &      iturn3_sent_local(1,iturn3_start),IERR)
 891         iaux=4*(iturn4_end-iturn4_start+1)
 892         call MPI_Group_translate_ranks(fg_group,iaux,
 893      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 894      &      iturn4_sent_local(1,iturn4_start),IERR)
 895         if (lprint) then
 896         write (iout,*) "iint_sent_local"
 897         do i=1,nat_sent
 898           ii=iat_sent(i)
 899           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 900      &      j=ielstart(ii),ielend(ii))
 901           call flush(iout)
 902         enddo
 903         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 904      &    " iturn3_end",iturn3_end
 905         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 906      &      i=iturn3_start,iturn3_end)
 907         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 908      &    " iturn4_end",iturn4_end
 909         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 910      &      i=iturn4_start,iturn4_end)
 911         call flush(iout)
 912         endif
 913         call MPI_Group_free(fg_group,ierr)
 914         call MPI_Group_free(cont_from_group,ierr)
 915         call MPI_Group_free(cont_to_group,ierr)
 916         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 917         call MPI_Type_commit(MPI_UYZ,IERROR)
 918         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 919      &    IERROR)
 920         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 921         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 922         call MPI_Type_commit(MPI_MU,IERROR)
 923         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 924         call MPI_Type_commit(MPI_MAT1,IERROR)
 925         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 926         call MPI_Type_commit(MPI_MAT2,IERROR)
 927         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 928         call MPI_Type_commit(MPI_THET,IERROR)
 929         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 930         call MPI_Type_commit(MPI_GAM,IERROR)
 931 #ifndef MATGATHER
 932 c 9/22/08 Derived types to send matrices which appear in correlation terms
 933         do i=0,nfgtasks-1
 934           if (ivec_count(i).eq.ivec_count(0)) then
 935             lentyp(i)=0
 936           else
 937             lentyp(i)=1
 938           endif
 939         enddo
 940         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 941         if (ind_typ.eq.0) then
 942           ichunk=ivec_count(0)
 943         else
 944           ichunk=ivec_count(1)
 945         endif
 946 c        do i=1,4
 947 c          blocklengths(i)=4
 948 c        enddo
 949 c        displs(1)=0
 950 c        do i=2,4
 951 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 952 c        enddo
 953 c        do i=1,4
 954 c          blocklengths(i)=blocklengths(i)*ichunk
 955 c        enddo
 956 c        write (iout,*) "blocklengths and displs"
 957 c        do i=1,4
 958 c          write (iout,*) i,blocklengths(i),displs(i)
 959 c        enddo
 960 c        call flush(iout)
 961 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 962 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 963 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 964 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 965 c        do i=1,4
 966 c          blocklengths(i)=2
 967 c        enddo
 968 c        displs(1)=0
 969 c        do i=2,4
 970 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 971 c        enddo
 972 c        do i=1,4
 973 c          blocklengths(i)=blocklengths(i)*ichunk
 974 c        enddo
 975 c        write (iout,*) "blocklengths and displs"
 976 c        do i=1,4
 977 c          write (iout,*) i,blocklengths(i),displs(i)
 978 c        enddo
 979 c        call flush(iout)
 980 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 981 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
 982 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
 983 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
 984         do i=1,8
 985           blocklengths(i)=2
 986         enddo
 987         displs(1)=0
 988         do i=2,8
 989           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 990         enddo
 991         do i=1,15
 992           blocklengths(i)=blocklengths(i)*ichunk
 993         enddo
 994         call MPI_Type_indexed(8,blocklengths,displs,
 995      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
 996         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
 997         do i=1,8
 998           blocklengths(i)=4
 999         enddo
1000         displs(1)=0
1001         do i=2,8
1002           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1003         enddo
1004         do i=1,15
1005           blocklengths(i)=blocklengths(i)*ichunk
1006         enddo
1007         call MPI_Type_indexed(8,blocklengths,displs,
1008      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1009         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1010         do i=1,6
1011           blocklengths(i)=4
1012         enddo
1013         displs(1)=0
1014         do i=2,6
1015           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1016         enddo
1017         do i=1,6
1018           blocklengths(i)=blocklengths(i)*ichunk
1019         enddo
1020         call MPI_Type_indexed(6,blocklengths,displs,
1021      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1022         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1023         do i=1,2
1024           blocklengths(i)=8
1025         enddo
1026         displs(1)=0
1027         do i=2,2
1028           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1029         enddo
1030         do i=1,2
1031           blocklengths(i)=blocklengths(i)*ichunk
1032         enddo
1033         call MPI_Type_indexed(2,blocklengths,displs,
1034      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1035         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1036         do i=1,4
1037           blocklengths(i)=1
1038         enddo
1039         displs(1)=0
1040         do i=2,4
1041           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1042         enddo
1043         do i=1,4
1044           blocklengths(i)=blocklengths(i)*ichunk
1045         enddo
1046         call MPI_Type_indexed(4,blocklengths,displs,
1047      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1048         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1049         enddo
1050 #endif
1051       endif
1052       iint_start=ivec_start+1
1053       iint_end=ivec_end+1
1054       do i=0,nfgtasks-1
1055           iint_count(i)=ivec_count(i)
1056           iint_displ(i)=ivec_displ(i)
1057           ivec_displ(i)=ivec_displ(i)-1
1058           iset_displ(i)=iset_displ(i)-1
1059           ithet_displ(i)=ithet_displ(i)-1
1060           iphi_displ(i)=iphi_displ(i)-1
1061           iphi1_displ(i)=iphi1_displ(i)-1
1062           ibond_displ(i)=ibond_displ(i)-1
1063       enddo
1064       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1065      &     .and. (me.eq.0 .or. out1file)) then
1066         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1067         do i=0,nfgtasks-1
1068           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1069      &      iset_count(i)
1070         enddo
1071         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1072      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1073         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1074         do i=0,nfgtasks-1
1075           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1076      &      iphi1_displ(i)
1077         enddo
1078         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1079      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1080      & ' SC-p interactions','were distributed among',nfgtasks,
1081      & ' fine-grain processors.'
1082       endif
1083 #else
1084       loc_start=2
1085       loc_end=nres-1
1086       ithet_start=3
1087       ithet_end=nres
1088       iturn3_start=nnt
1089       iturn3_end=nct-3
1090       iturn4_start=nnt
1091       iturn4_end=nct-4
1092       iphi_start=nnt+3
1093       iphi_end=nct
1094       iphi1_start=4
1095       iphi1_end=nres
1096       idihconstr_start=1
1097       idihconstr_end=ndih_constr
1098       iphid_start=iphi_start
1099       iphid_end=iphi_end-1
1100       itau_start=4
1101       itau_end=nres
1102       ibond_start=2
1103       ibond_end=nres-1
1104       ibondp_start=nnt+1
1105       ibondp_end=nct
1106       ivec_start=1
1107       ivec_end=nres-1
1108       iset_start=3
1109       iset_end=nres+1
1110       iint_start=2
1111       iint_end=nres-1
1112 #endif
1113       return
1114       end
1115 #ifdef MPI
1116 c---------------------------------------------------------------------------
1117       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1118       implicit none
1119       include "DIMENSIONS"
1120       include "COMMON.INTERACT"
1121       include "COMMON.SETUP"
1122       include "COMMON.IOUNITS"
1123       integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
1124       logical flag
1125       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1126      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1127       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1128      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1129      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1130      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1131      & ielend_all(maxres,0:MaxProcs-1)
1132       integer iproc,isent,k,l
1133 c Determines whether to send interaction ii,jj to other processors; a given
1134 c interaction can be sent to at most 2 processors.
1135 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1136 c one processor, otherwise flag is unchanged from the input value.
1137       isent=0
1138       itask(1)=fg_rank
1139       itask(2)=fg_rank
1140       itask(3)=fg_rank
1141       itask(4)=fg_rank
1142 c      write (iout,*) "ii",ii," jj",jj
1143 c Loop over processors to check if anybody could need interaction ii,jj
1144       do iproc=0,fg_rank-1
1145 c Check if the interaction matches any turn3 at iproc
1146         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1147           l=k+2
1148           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1149      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1150      &    then
1151 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1152 c            call flush(iout)
1153             flag=.true.
1154             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1155      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1156               isent=isent+1
1157               itask(isent)=iproc
1158               call add_task(iproc,ntask_cont_to,itask_cont_to)
1159             endif
1160           endif
1161         enddo
1162 C Check if the interaction matches any turn4 at iproc
1163         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1164           l=k+3
1165           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1166      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1167      &    then
1168 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1169 c            call flush(iout)
1170             flag=.true.
1171             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1172      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1173               isent=isent+1
1174               itask(isent)=iproc
1175               call add_task(iproc,ntask_cont_to,itask_cont_to)
1176             endif
1177           endif
1178         enddo
1179         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1180      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1181           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1182      &        ielend_all(ii-1,iproc).ge.jj-1) then
1183             flag=.true.
1184             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1185      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1186               isent=isent+1
1187               itask(isent)=iproc
1188               call add_task(iproc,ntask_cont_to,itask_cont_to)
1189             endif
1190           endif
1191           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1192      &        ielend_all(ii-1,iproc).ge.jj+1) then
1193             flag=.true.
1194             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1195      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1196               isent=isent+1
1197               itask(isent)=iproc
1198               call add_task(iproc,ntask_cont_to,itask_cont_to)
1199             endif
1200           endif
1201         endif
1202       enddo
1203       return
1204       end
1205 c---------------------------------------------------------------------------
1206       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1207       implicit none
1208       include "DIMENSIONS"
1209       include "COMMON.INTERACT"
1210       include "COMMON.SETUP"
1211       include "COMMON.IOUNITS"
1212       integer ii,jj,itask(2),ntask_cont_from,
1213      & itask_cont_from(0:MaxProcs-1)
1214       logical flag
1215       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1216      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1217       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1218      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1219      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1220      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1221      & ielend_all(maxres,0:MaxProcs-1)
1222       integer iproc,k,l
1223       do iproc=fg_rank+1,nfgtasks-1
1224         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1225           l=k+2
1226           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1227      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1228      &    then
1229 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1230             call add_task(iproc,ntask_cont_from,itask_cont_from)
1231           endif
1232         enddo
1233         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1234           l=k+3
1235           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1236      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1237      &    then
1238 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1239             call add_task(iproc,ntask_cont_from,itask_cont_from)
1240           endif
1241         enddo
1242         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1243           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1244      &    then
1245             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1246      &          jj+1.le.ielend_all(ii+1,iproc)) then
1247               call add_task(iproc,ntask_cont_from,itask_cont_from)
1248             endif
1249             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1250      &          jj-1.le.ielend_all(ii+1,iproc)) then
1251               call add_task(iproc,ntask_cont_from,itask_cont_from)
1252             endif
1253           endif
1254           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1255      &    then
1256             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1257      &          jj-1.le.ielend_all(ii-1,iproc)) then
1258               call add_task(iproc,ntask_cont_from,itask_cont_from)
1259             endif
1260             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1261      &          jj+1.le.ielend_all(ii-1,iproc)) then
1262                call add_task(iproc,ntask_cont_from,itask_cont_from)
1263             endif
1264           endif
1265         endif
1266       enddo
1267       return
1268       end
1269 c---------------------------------------------------------------------------
1270       subroutine add_task(iproc,ntask_cont,itask_cont)
1271       implicit none
1272       include "DIMENSIONS"
1273       integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
1274       integer ii
1275       do ii=1,ntask_cont
1276         if (itask_cont(ii).eq.iproc) return
1277       enddo
1278       ntask_cont=ntask_cont+1
1279       itask_cont(ntask_cont)=iproc
1280       return
1281       end
1282 c---------------------------------------------------------------------------
1283       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1284       implicit real*8 (a-h,o-z)
1285       include 'DIMENSIONS'
1286       include 'mpif.h'
1287       include 'COMMON.SETUP'
1288       integer total_ints,lower_bound,upper_bound
1289       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1290       nint=total_ints/nfgtasks
1291       do i=1,nfgtasks
1292         int4proc(i-1)=nint
1293       enddo
1294       nexcess=total_ints-nint*nfgtasks
1295       do i=1,nexcess
1296         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1297       enddo
1298       lower_bound=0
1299       do i=0,fg_rank-1
1300         lower_bound=lower_bound+int4proc(i)
1301       enddo
1302       upper_bound=lower_bound+int4proc(fg_rank)
1303       lower_bound=lower_bound+1
1304       return
1305       end
1306 c---------------------------------------------------------------------------
1307       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1308       implicit real*8 (a-h,o-z)
1309       include 'DIMENSIONS'
1310       include 'mpif.h'
1311       include 'COMMON.SETUP'
1312       integer total_ints,lower_bound,upper_bound
1313       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1314       nint=total_ints/nfgtasks1
1315       do i=1,nfgtasks1
1316         int4proc(i-1)=nint
1317       enddo
1318       nexcess=total_ints-nint*nfgtasks1
1319       do i=1,nexcess
1320         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1321       enddo
1322       lower_bound=0
1323       do i=0,fg_rank1-1
1324         lower_bound=lower_bound+int4proc(i)
1325       enddo
1326       upper_bound=lower_bound+int4proc(fg_rank1)
1327       lower_bound=lower_bound+1
1328       return
1329       end
1330 c---------------------------------------------------------------------------
1331       subroutine int_partition(int_index,lower_index,upper_index,atom,
1332      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1333       implicit real*8 (a-h,o-z)
1334       include 'DIMENSIONS'
1335       include 'COMMON.IOUNITS'
1336       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1337      & first_atom,last_atom,int_gr,jat_start,jat_end
1338       logical lprn
1339       lprn=.false.
1340       if (lprn) write (iout,*) 'int_index=',int_index
1341       int_index_old=int_index
1342       int_index=int_index+last_atom-first_atom+1
1343       if (lprn)
1344      &   write (iout,*) 'int_index=',int_index,
1345      &               ' int_index_old',int_index_old,
1346      &               ' lower_index=',lower_index,
1347      &               ' upper_index=',upper_index,
1348      &               ' atom=',atom,' first_atom=',first_atom,
1349      &               ' last_atom=',last_atom
1350       if (int_index.ge.lower_index) then
1351         int_gr=int_gr+1
1352         if (at_start.eq.0) then
1353           at_start=atom
1354           jat_start=first_atom-1+lower_index-int_index_old
1355         else
1356           jat_start=first_atom
1357         endif
1358         if (lprn) write (iout,*) 'jat_start',jat_start
1359         if (int_index.ge.upper_index) then
1360           at_end=atom
1361           jat_end=first_atom-1+upper_index-int_index_old
1362           return1
1363         else
1364           jat_end=last_atom
1365         endif
1366         if (lprn) write (iout,*) 'jat_end',jat_end
1367       endif
1368       return
1369       end
1370 #endif
1371 c------------------------------------------------------------------------------
1372       subroutine hpb_partition
1373       implicit real*8 (a-h,o-z)
1374       include 'DIMENSIONS'
1375 #ifdef MPI
1376       include 'mpif.h'
1377 #endif
1378       include 'COMMON.SBRIDGE'
1379       include 'COMMON.IOUNITS'
1380       include 'COMMON.SETUP'
1381       include 'COMMON.CONTROL'
1382 #ifdef MPI
1383       call int_bounds(nhpb,link_start,link_end)
1384       if (.not. out1file)
1385      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1386      &  ' absolute rank',MyRank,
1387      &  ' nhpb',nhpb,' link_start=',link_start,
1388      &  ' link_end',link_end
1389 #else
1390       link_start=1
1391       link_end=nhpb
1392 #endif
1393       return
1394       end