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