2 implicit real*8 (a-h,o-z)
7 & /'pool','chain regrow','multi-bond','phi','theta','side chain',
9 c Conversion from poises to molecular unit and the gas constant
10 data cPoise /2.9361d0/, Rb /0.001986d0/
12 c--------------------------------------------------------------------------
15 C Define constants and zero out tables.
17 implicit real*8 (a-h,o-z)
25 cMS$ATTRIBUTES C :: proc_proc
28 include 'COMMON.IOUNITS'
29 include 'COMMON.CHAIN'
30 include 'COMMON.INTERACT'
32 include 'COMMON.LOCAL'
33 include 'COMMON.TORSION'
34 include 'COMMON.FFIELD'
35 include 'COMMON.SBRIDGE'
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
44 c real*8 text1 /'initial_i'/
63 C The following is just to define auxiliary variables used in angle conversion
102 crc for write_rmsbank1
104 cdr include secondary structure prediction bias
107 C CSA I/O units (separated from others especially for Jooyoung)
118 icsa_bank_reminimized=38
121 crc for ifc error 118
124 C Set default weights of the energy terms.
135 print '(a,$)','Inside initialize'
136 c call memmon_print_usage()
186 gaussc(l,k,j,i)=0.0D0
207 C Initialize the bridge arrays
226 C Initialize variables used in minimization.
235 C Initialize the variables responsible for the mode of gradient storage.
240 C Initialize constants used to split the energy into long- and short-range
246 nprint_ene=nprint_ene-1
250 c-------------------------------------------------------------------------
252 implicit real*8 (a-h,o-z)
254 include 'COMMON.NAMES'
255 include 'COMMON.FFIELD'
257 &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
258 &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
260 &'C','M','F','I','L','V','W','Y','A','G','T',
261 &'S','Q','N','E','D','H','R','K','P','X'/
262 data potname /'LJ','LJK','BP','GB','GBV'/
264 & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
265 & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
266 & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
267 & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," "/
269 & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
270 & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
271 & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR",
274 data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
277 c---------------------------------------------------------------------------
278 subroutine init_int_table
279 implicit real*8 (a-h,o-z)
283 integer blocklengths(15),displs(15)
285 include 'COMMON.CONTROL'
286 include 'COMMON.SETUP'
287 include 'COMMON.CHAIN'
288 include 'COMMON.INTERACT'
289 include 'COMMON.LOCAL'
290 include 'COMMON.SBRIDGE'
291 include 'COMMON.TORCNSTR'
292 include 'COMMON.IOUNITS'
293 include 'COMMON.DERIV'
294 include 'COMMON.CONTACTS'
295 common /przechowalnia/ iturn3_start_all(0:MaxProcs),
296 & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
297 & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
298 & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
299 & ielend_all(maxres,0:MaxProcs-1),
300 & ntask_cont_from_all(0:max_fg_procs-1),
301 & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
302 & ntask_cont_to_all(0:max_fg_procs-1),
303 & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
304 integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
305 logical scheck,lprint,flag
307 integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
308 & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
309 C... Determine the numbers of start and end SC-SC interaction
310 C... to deal with by current processor.
312 itask_cont_from(i)=fg_rank
313 itask_cont_to(i)=fg_rank
317 &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
318 n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
319 call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
321 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
322 & ' absolute rank',MyRank,
323 & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
324 & ' my_sc_inde',my_sc_inde
344 cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
345 cd & (ihpb(i),jhpb(i),i=1,nss)
349 if (ihpb(ii).eq.i+nres) then
356 cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
360 c write (iout,*) 'jj=i+1'
361 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
362 & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
368 else if (jj.eq.nct) then
370 c write (iout,*) 'jj=nct'
371 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
372 & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
380 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
381 & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
383 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
384 & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
395 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
396 & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
401 ind_scint=ind_scint+nct-i
405 ind_scint_old=ind_scint
413 if (iatsc_s.eq.0) iatsc_s=1
415 if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
416 & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
419 write (iout,'(a)') 'Interaction array:'
421 write (iout,'(i3,2(2x,2i3))')
422 & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
427 C Now partition the electrostatic-interaction array
429 nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
430 call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
432 & write (*,*) 'Processor',fg_rank,' CG group',kolor,
433 & ' absolute rank',MyRank,
434 & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
435 & ' my_ele_inde',my_ele_inde
442 call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
443 & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
446 if (iatel_s.eq.0) iatel_s=1
447 nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
448 c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
449 call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
450 c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
451 c & " my_ele_inde_vdw",my_ele_inde_vdw
458 call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
460 & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
462 c write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
463 c & " ielend_vdw",ielend_vdw(i)
465 if (iatel_s_vdw.eq.0) iatel_s_vdw=1
476 do i=iatel_s_vdw,iatel_e_vdw
482 write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
483 & ' absolute rank',MyRank
484 write (iout,*) 'Electrostatic interaction array:'
486 write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
491 C Partition the SC-p interaction array
493 nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
494 call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
495 if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
496 & ' absolute rank',myrank,
497 & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
498 & ' my_scp_inde',my_scp_inde
504 if (i.lt.nnt+iscp) then
505 cd write (iout,*) 'i.le.nnt+iscp'
506 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
507 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
509 else if (i.gt.nct-iscp) then
510 cd write (iout,*) 'i.gt.nct-iscp'
511 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
512 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
515 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
516 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
519 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
520 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
529 if (i.lt.nnt+iscp) then
531 iscpstart(i,1)=i+iscp
533 elseif (i.gt.nct-iscp) then
541 iscpstart(i,2)=i+iscp
546 if (iatscp_s.eq.0) iatscp_s=1
548 write (iout,'(a)') 'SC-p interaction array:'
549 do i=iatscp_s,iatscp_e
550 write (iout,'(i3,2(2x,2i3))')
551 & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
554 C Partition local interactions
556 call int_bounds(nres-2,loc_start,loc_end)
557 loc_start=loc_start+1
559 call int_bounds(nres-2,ithet_start,ithet_end)
560 ithet_start=ithet_start+2
561 ithet_end=ithet_end+2
562 call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
563 iturn3_start=iturn3_start+nnt
564 iphi_start=iturn3_start+2
565 iturn3_end=iturn3_end+nnt
566 iphi_end=iturn3_end+2
567 iturn3_start=iturn3_start-1
568 iturn3_end=iturn3_end-1
569 call int_bounds(nres-3,itau_start,itau_end)
570 itau_start=itau_start+3
572 call int_bounds(nres-3,iphi1_start,iphi1_end)
573 iphi1_start=iphi1_start+3
574 iphi1_end=iphi1_end+3
575 call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
576 iturn4_start=iturn4_start+nnt
577 iphid_start=iturn4_start+2
578 iturn4_end=iturn4_end+nnt
579 iphid_end=iturn4_end+2
580 iturn4_start=iturn4_start-1
581 iturn4_end=iturn4_end-1
582 call int_bounds(nres-2,ibond_start,ibond_end)
583 ibond_start=ibond_start+1
584 ibond_end=ibond_end+1
585 call int_bounds(nct-nnt,ibondp_start,ibondp_end)
586 ibondp_start=ibondp_start+nnt
587 ibondp_end=ibondp_end+nnt
588 call int_bounds1(nres-1,ivec_start,ivec_end)
589 print *,"Processor",myrank,fg_rank,fg_rank1,
590 & " ivec_start",ivec_start," ivec_end",ivec_end
591 iset_start=loc_start+2
593 if (ndih_constr.eq.0) then
597 call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
599 nsumgrad=(nres-nnt)*(nres-nnt+1)/2
601 call int_bounds(nsumgrad,ngrad_start,ngrad_end)
602 igrad_start=((2*nlen+1)
603 & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
604 jgrad_start(igrad_start)=
605 & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
607 jgrad_end(igrad_start)=nres
608 igrad_end=((2*nlen+1)
609 & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
610 if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
611 jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
613 do i=igrad_start+1,igrad_end-1
618 write (*,*) 'Processor:',fg_rank,' CG group',kolor,
619 & ' absolute rank',myrank,
620 & ' loc_start',loc_start,' loc_end',loc_end,
621 & ' ithet_start',ithet_start,' ithet_end',ithet_end,
622 & ' iphi_start',iphi_start,' iphi_end',iphi_end,
623 & ' iphid_start',iphid_start,' iphid_end',iphid_end,
624 & ' ibond_start',ibond_start,' ibond_end',ibond_end,
625 & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
626 & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
627 & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
628 & ' ivec_start',ivec_start,' ivec_end',ivec_end,
629 & ' iset_start',iset_start,' iset_end',iset_end,
630 & ' idihconstr_start',idihconstr_start,' idihconstr_end',
632 write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
633 & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
634 & ' ngrad_end',ngrad_end
635 do i=igrad_start,igrad_end
636 write(*,*) 'Processor:',fg_rank,myrank,i,
637 & jgrad_start(i),jgrad_end(i)
640 if (nfgtasks.gt.1) then
641 call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
642 & MPI_INTEGER,FG_COMM1,IERROR)
643 iaux=ivec_end-ivec_start+1
644 call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
645 & MPI_INTEGER,FG_COMM1,IERROR)
646 call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
647 & MPI_INTEGER,FG_COMM,IERROR)
648 iaux=iset_end-iset_start+1
649 call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
650 & MPI_INTEGER,FG_COMM,IERROR)
651 call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
652 & MPI_INTEGER,FG_COMM,IERROR)
653 iaux=ibond_end-ibond_start+1
654 call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
655 & MPI_INTEGER,FG_COMM,IERROR)
656 call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
657 & MPI_INTEGER,FG_COMM,IERROR)
658 iaux=ithet_end-ithet_start+1
659 call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
660 & MPI_INTEGER,FG_COMM,IERROR)
661 call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
662 & MPI_INTEGER,FG_COMM,IERROR)
663 iaux=iphi_end-iphi_start+1
664 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
665 & MPI_INTEGER,FG_COMM,IERROR)
666 call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
667 & MPI_INTEGER,FG_COMM,IERROR)
668 iaux=iphi1_end-iphi1_start+1
669 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
670 & MPI_INTEGER,FG_COMM,IERROR)
677 call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
678 & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
679 call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
680 & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
681 call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
682 & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
683 call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
684 & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
685 call MPI_Allgather(iatel_s,1,MPI_INTEGER,
686 & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
687 call MPI_Allgather(iatel_e,1,MPI_INTEGER,
688 & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
689 call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
690 & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
691 call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
692 & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
694 write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
695 write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
696 write (iout,*) "iturn3_start_all",
697 & (iturn3_start_all(i),i=0,nfgtasks-1)
698 write (iout,*) "iturn3_end_all",
699 & (iturn3_end_all(i),i=0,nfgtasks-1)
700 write (iout,*) "iturn4_start_all",
701 & (iturn4_start_all(i),i=0,nfgtasks-1)
702 write (iout,*) "iturn4_end_all",
703 & (iturn4_end_all(i),i=0,nfgtasks-1)
704 write (iout,*) "The ielstart_all array"
706 write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
708 write (iout,*) "The ielend_all array"
710 write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
716 itask_cont_from(0)=fg_rank
717 itask_cont_to(0)=fg_rank
719 do ii=iturn3_start,iturn3_end
720 call add_int(ii,ii+2,iturn3_sent(1,ii),
721 & ntask_cont_to,itask_cont_to,flag)
723 do ii=iturn4_start,iturn4_end
724 call add_int(ii,ii+3,iturn4_sent(1,ii),
725 & ntask_cont_to,itask_cont_to,flag)
727 do ii=iturn3_start,iturn3_end
728 call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
730 do ii=iturn4_start,iturn4_end
731 call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
734 write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
735 & " ntask_cont_to",ntask_cont_to
736 write (iout,*) "itask_cont_from",
737 & (itask_cont_from(i),i=1,ntask_cont_from)
738 write (iout,*) "itask_cont_to",
739 & (itask_cont_to(i),i=1,ntask_cont_to)
742 c write (iout,*) "Loop forward"
745 c write (iout,*) "from loop i=",i
747 do j=ielstart(i),ielend(i)
748 call add_int_from(i,j,ntask_cont_from,itask_cont_from)
751 c write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
752 c & " iatel_e",iatel_e
756 c write (iout,*) "i",i," ielstart",ielstart(i),
757 c & " ielend",ielend(i)
760 do j=ielstart(i),ielend(i)
761 call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
762 & itask_cont_to,flag)
770 write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
771 & " ntask_cont_to",ntask_cont_to
772 write (iout,*) "itask_cont_from",
773 & (itask_cont_from(i),i=1,ntask_cont_from)
774 write (iout,*) "itask_cont_to",
775 & (itask_cont_to(i),i=1,ntask_cont_to)
777 write (iout,*) "iint_sent"
780 write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
781 & j=ielstart(ii),ielend(ii))
783 write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
784 & " iturn3_end",iturn3_end
785 write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
786 & i=iturn3_start,iturn3_end)
787 write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
788 & " iturn4_end",iturn4_end
789 write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
790 & i=iturn4_start,iturn4_end)
793 call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
794 & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
795 c write (iout,*) "Gather ntask_cont_from ended"
797 call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
798 & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
800 c write (iout,*) "Gather itask_cont_from ended"
802 call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
803 & 1,MPI_INTEGER,king,FG_COMM,IERR)
804 c write (iout,*) "Gather ntask_cont_to ended"
806 call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
807 & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
808 c write (iout,*) "Gather itask_cont_to ended"
810 if (fg_rank.eq.king) then
811 write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
813 write (iout,'(20i4)') i,ntask_cont_from_all(i),
814 & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
818 write (iout,*) "Contact send task map (proc, #tasks, tasks)"
820 write (iout,'(20i4)') i,ntask_cont_to_all(i),
821 & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
825 C Check if every send will have a matching receive
829 ncheck_to=ncheck_to+ntask_cont_to_all(i)
830 ncheck_from=ncheck_from+ntask_cont_from_all(i)
832 write (iout,*) "Control sums",ncheck_from,ncheck_to
833 if (ncheck_from.ne.ncheck_to) then
834 write (iout,*) "Error: #receive differs from #send."
835 write (iout,*) "Terminating program...!"
841 do j=1,ntask_cont_to_all(i)
842 ii=itask_cont_to_all(j,i)
843 do k=1,ntask_cont_from_all(ii)
844 if (itask_cont_from_all(k,ii).eq.i) then
845 if(lprint)write(iout,*)"Matching send/receive",i,ii
849 if (k.eq.ntask_cont_from_all(ii)+1) then
851 write (iout,*) "Error: send by",j," to",ii,
852 & " would have no matching receive"
858 write (iout,*) "Unmatched sends; terminating program"
862 call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
863 c write (iout,*) "flag broadcast ended flag=",flag
866 call MPI_Finalize(IERROR)
867 stop "Error in INIT_INT_TABLE: unmatched send/receive."
869 call MPI_Comm_group(FG_COMM,fg_group,IERR)
870 c write (iout,*) "MPI_Comm_group ended"
872 call MPI_Group_incl(fg_group,ntask_cont_from+1,
873 & itask_cont_from(0),CONT_FROM_GROUP,IERR)
874 call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
875 & CONT_TO_GROUP,IERR)
878 iaux=4*(ielend(ii)-ielstart(ii)+1)
879 call MPI_Group_translate_ranks(fg_group,iaux,
880 & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
881 & iint_sent_local(1,ielstart(ii),i),IERR )
882 c write (iout,*) "Ranks translated i=",i
885 iaux=4*(iturn3_end-iturn3_start+1)
886 call MPI_Group_translate_ranks(fg_group,iaux,
887 & iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
888 & iturn3_sent_local(1,iturn3_start),IERR)
889 iaux=4*(iturn4_end-iturn4_start+1)
890 call MPI_Group_translate_ranks(fg_group,iaux,
891 & iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
892 & iturn4_sent_local(1,iturn4_start),IERR)
894 write (iout,*) "iint_sent_local"
897 write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
898 & j=ielstart(ii),ielend(ii))
901 write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
902 & " iturn3_end",iturn3_end
903 write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
904 & i=iturn3_start,iturn3_end)
905 write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
906 & " iturn4_end",iturn4_end
907 write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
908 & i=iturn4_start,iturn4_end)
911 call MPI_Group_free(fg_group,ierr)
912 call MPI_Group_free(cont_from_group,ierr)
913 call MPI_Group_free(cont_to_group,ierr)
914 call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
915 call MPI_Type_commit(MPI_UYZ,IERROR)
916 call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
918 call MPI_Type_commit(MPI_UYZGRAD,IERROR)
919 call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
920 call MPI_Type_commit(MPI_MU,IERROR)
921 call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
922 call MPI_Type_commit(MPI_MAT1,IERROR)
923 call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
924 call MPI_Type_commit(MPI_MAT2,IERROR)
925 call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
926 call MPI_Type_commit(MPI_THET,IERROR)
927 call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
928 call MPI_Type_commit(MPI_GAM,IERROR)
930 c 9/22/08 Derived types to send matrices which appear in correlation terms
932 if (ivec_count(i).eq.ivec_count(0)) then
938 do ind_typ=lentyp(0),lentyp(nfgtasks-1)
939 if (ind_typ.eq.0) then
949 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
952 c blocklengths(i)=blocklengths(i)*ichunk
954 c write (iout,*) "blocklengths and displs"
956 c write (iout,*) i,blocklengths(i),displs(i)
959 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
960 c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
961 c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
962 c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
968 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
971 c blocklengths(i)=blocklengths(i)*ichunk
973 c write (iout,*) "blocklengths and displs"
975 c write (iout,*) i,blocklengths(i),displs(i)
978 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
979 c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
980 c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
981 c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
987 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
990 blocklengths(i)=blocklengths(i)*ichunk
992 call MPI_Type_indexed(8,blocklengths,displs,
993 & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
994 call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1000 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1003 blocklengths(i)=blocklengths(i)*ichunk
1005 call MPI_Type_indexed(8,blocklengths,displs,
1006 & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1007 call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1013 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1016 blocklengths(i)=blocklengths(i)*ichunk
1018 call MPI_Type_indexed(6,blocklengths,displs,
1019 & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1020 call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1026 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1029 blocklengths(i)=blocklengths(i)*ichunk
1031 call MPI_Type_indexed(2,blocklengths,displs,
1032 & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1033 call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1039 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1042 blocklengths(i)=blocklengths(i)*ichunk
1044 call MPI_Type_indexed(4,blocklengths,displs,
1045 & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1046 call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1050 iint_start=ivec_start+1
1053 iint_count(i)=ivec_count(i)
1054 iint_displ(i)=ivec_displ(i)
1055 ivec_displ(i)=ivec_displ(i)-1
1056 iset_displ(i)=iset_displ(i)-1
1057 ithet_displ(i)=ithet_displ(i)-1
1058 iphi_displ(i)=iphi_displ(i)-1
1059 iphi1_displ(i)=iphi1_displ(i)-1
1060 ibond_displ(i)=ibond_displ(i)-1
1062 if (nfgtasks.gt.1 .and. fg_rank.eq.king
1063 & .and. (me.eq.0 .or. out1file)) then
1064 write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1066 write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1069 write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1070 & " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1071 write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1073 write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1076 write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1077 & nele_int_tot,' electrostatic and ',nscp_int_tot,
1078 & ' SC-p interactions','were distributed among',nfgtasks,
1079 & ' fine-grain processors.'
1095 idihconstr_end=ndih_constr
1096 iphid_start=iphi_start
1097 iphid_end=iphi_end-1
1114 c---------------------------------------------------------------------------
1115 subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1117 include "DIMENSIONS"
1118 include "COMMON.INTERACT"
1119 include "COMMON.SETUP"
1120 include "COMMON.IOUNITS"
1121 integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
1123 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1124 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1125 common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1126 & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1127 & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1128 & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1129 & ielend_all(maxres,0:MaxProcs-1)
1130 integer iproc,isent,k,l
1131 c Determines whether to send interaction ii,jj to other processors; a given
1132 c interaction can be sent to at most 2 processors.
1133 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1134 c one processor, otherwise flag is unchanged from the input value.
1140 c write (iout,*) "ii",ii," jj",jj
1141 c Loop over processors to check if anybody could need interaction ii,jj
1142 do iproc=0,fg_rank-1
1143 c Check if the interaction matches any turn3 at iproc
1144 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1146 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1147 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1149 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1152 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1153 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1156 call add_task(iproc,ntask_cont_to,itask_cont_to)
1160 C Check if the interaction matches any turn4 at iproc
1161 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1163 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1164 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1166 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1169 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1170 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1173 call add_task(iproc,ntask_cont_to,itask_cont_to)
1177 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1178 & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1179 if (ielstart_all(ii-1,iproc).le.jj-1.and.
1180 & ielend_all(ii-1,iproc).ge.jj-1) then
1182 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1183 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1186 call add_task(iproc,ntask_cont_to,itask_cont_to)
1189 if (ielstart_all(ii-1,iproc).le.jj+1.and.
1190 & ielend_all(ii-1,iproc).ge.jj+1) then
1192 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1193 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1196 call add_task(iproc,ntask_cont_to,itask_cont_to)
1203 c---------------------------------------------------------------------------
1204 subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1206 include "DIMENSIONS"
1207 include "COMMON.INTERACT"
1208 include "COMMON.SETUP"
1209 include "COMMON.IOUNITS"
1210 integer ii,jj,itask(2),ntask_cont_from,
1211 & itask_cont_from(0:MaxProcs-1)
1213 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1214 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1215 common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1216 & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1217 & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1218 & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1219 & ielend_all(maxres,0:MaxProcs-1)
1221 do iproc=fg_rank+1,nfgtasks-1
1222 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1224 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1225 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1227 c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1228 call add_task(iproc,ntask_cont_from,itask_cont_from)
1231 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1233 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1234 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1236 c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1237 call add_task(iproc,ntask_cont_from,itask_cont_from)
1240 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1241 if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1243 if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1244 & jj+1.le.ielend_all(ii+1,iproc)) then
1245 call add_task(iproc,ntask_cont_from,itask_cont_from)
1247 if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1248 & jj-1.le.ielend_all(ii+1,iproc)) then
1249 call add_task(iproc,ntask_cont_from,itask_cont_from)
1252 if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1254 if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1255 & jj-1.le.ielend_all(ii-1,iproc)) then
1256 call add_task(iproc,ntask_cont_from,itask_cont_from)
1258 if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1259 & jj+1.le.ielend_all(ii-1,iproc)) then
1260 call add_task(iproc,ntask_cont_from,itask_cont_from)
1267 c---------------------------------------------------------------------------
1268 subroutine add_task(iproc,ntask_cont,itask_cont)
1270 include "DIMENSIONS"
1271 integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
1274 if (itask_cont(ii).eq.iproc) return
1276 ntask_cont=ntask_cont+1
1277 itask_cont(ntask_cont)=iproc
1280 c---------------------------------------------------------------------------
1281 subroutine int_bounds(total_ints,lower_bound,upper_bound)
1282 implicit real*8 (a-h,o-z)
1283 include 'DIMENSIONS'
1285 include 'COMMON.SETUP'
1286 integer total_ints,lower_bound,upper_bound
1287 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1288 nint=total_ints/nfgtasks
1292 nexcess=total_ints-nint*nfgtasks
1294 int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1298 lower_bound=lower_bound+int4proc(i)
1300 upper_bound=lower_bound+int4proc(fg_rank)
1301 lower_bound=lower_bound+1
1304 c---------------------------------------------------------------------------
1305 subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1306 implicit real*8 (a-h,o-z)
1307 include 'DIMENSIONS'
1309 include 'COMMON.SETUP'
1310 integer total_ints,lower_bound,upper_bound
1311 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1312 nint=total_ints/nfgtasks1
1316 nexcess=total_ints-nint*nfgtasks1
1318 int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1322 lower_bound=lower_bound+int4proc(i)
1324 upper_bound=lower_bound+int4proc(fg_rank1)
1325 lower_bound=lower_bound+1
1328 c---------------------------------------------------------------------------
1329 subroutine int_partition(int_index,lower_index,upper_index,atom,
1330 & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1331 implicit real*8 (a-h,o-z)
1332 include 'DIMENSIONS'
1333 include 'COMMON.IOUNITS'
1334 integer int_index,lower_index,upper_index,atom,at_start,at_end,
1335 & first_atom,last_atom,int_gr,jat_start,jat_end
1338 if (lprn) write (iout,*) 'int_index=',int_index
1339 int_index_old=int_index
1340 int_index=int_index+last_atom-first_atom+1
1342 & write (iout,*) 'int_index=',int_index,
1343 & ' int_index_old',int_index_old,
1344 & ' lower_index=',lower_index,
1345 & ' upper_index=',upper_index,
1346 & ' atom=',atom,' first_atom=',first_atom,
1347 & ' last_atom=',last_atom
1348 if (int_index.ge.lower_index) then
1350 if (at_start.eq.0) then
1352 jat_start=first_atom-1+lower_index-int_index_old
1354 jat_start=first_atom
1356 if (lprn) write (iout,*) 'jat_start',jat_start
1357 if (int_index.ge.upper_index) then
1359 jat_end=first_atom-1+upper_index-int_index_old
1364 if (lprn) write (iout,*) 'jat_end',jat_end
1369 c------------------------------------------------------------------------------
1370 subroutine hpb_partition
1371 implicit real*8 (a-h,o-z)
1372 include 'DIMENSIONS'
1376 include 'COMMON.SBRIDGE'
1377 include 'COMMON.IOUNITS'
1378 include 'COMMON.SETUP'
1379 include 'COMMON.CONTROL'
1380 c write(2,*)"hpb_partition: nhpb=",nhpb
1382 call int_bounds(nhpb,link_start,link_end)
1384 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1385 & ' absolute rank',MyRank,
1386 & ' nhpb',nhpb,' link_start=',link_start,
1387 & ' link_end',link_end
1392 c write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end