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