--- /dev/null
+ module control
+!-----------------------------------------------------------------------------
+ use io_units
+ use names
+ use MPI_data
+ use geometry_data
+ use energy_data
+ use control_data
+ use minim_data
+ use geometry, only:int_bounds
+#ifndef CLUSTER
+ use csa_data
+#ifdef WHAM_RUN
+ use wham_data
+#endif
+#endif
+ implicit none
+!-----------------------------------------------------------------------------
+! commom.control
+! common /cntrl/
+! integer :: modecalc,iscode,indpdb,indback,indphi,iranconf,&
+! icheckgrad,iprint,i2ndstr,mucadyn,constr_dist,symetr
+! logical :: minim,refstr,pdbref,outpdb,outmol2,overlapsc,&
+! energy_dec,sideadd,lsecondary,read_cart,unres_pdb,&
+! vdisulf,searchsc,lmuca,dccart,extconf,out1file,&
+! gnorm_check,gradout,split_ene
+!... minim = .true. means DO minimization.
+!... energy_dec = .true. means print energy decomposition matrix
+!-----------------------------------------------------------------------------
+! common.time1
+! FOUND_NAN - set by calcf to stop sumsl via stopx
+! COMMON/TIME1/
+ real(kind=8) :: STIME,BATIME,PREVTIM,RSTIME
+!el real(kind=8) :: TIMLIM,SAFETY
+!el real(kind=8) :: WALLTIME
+! COMMON/STOPTIM/
+ integer :: ISTOP
+! common /sumsl_flag/
+ logical :: FOUND_NAN
+! common /timing/
+ real(kind=8) :: t_init
+! time_bcast,time_reduce,time_gather,&
+! time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,&
+ !t_eelecij,
+! time_allreduce,&
+! time_lagrangian,time_cartgrad,&
+! time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart,&
+! time_mat,time_fricmatmult,&
+! time_scatter_fmat,time_scatter_ginv,&
+! time_scatter_fmatmult,time_scatter_ginvmult,&
+! t_eshort,t_elong,t_etotal
+!-----------------------------------------------------------------------------
+! initialize_p.F
+!-----------------------------------------------------------------------------
+! block data
+! integer,parameter :: MaxMoveType = 4
+! character(len=14),dimension(-1:MaxMoveType+1) :: MovTypID=(/'pool','chain regrow',&
+! character :: MovTypID(-1:MaxMoveType+1)=(/'pool','chain regrow',&
+! 'multi-bond','phi','theta','side chain','total'/)
+! Conversion from poises to molecular unit and the gas constant
+!el real(kind=8) :: cPoise=2.9361d0, Rb=0.001986d0
+!-----------------------------------------------------------------------------
+! common /przechowalnia/ subroutines: init_int_table,add_int,add_int_from
+ integer,dimension(:),allocatable :: iturn3_start_all,&
+ iturn3_end_all,iturn4_start_all,iturn4_end_all,iatel_s_all,&
+ iatel_e_all !(0:max_fg_procs)
+ integer,dimension(:,:),allocatable :: ielstart_all,&
+ ielend_all !(maxres,0:max_fg_procs-1)
+
+! common /przechowalnia/ subroutine: init_int_table
+ integer,dimension(:),allocatable :: ntask_cont_from_all,&
+ ntask_cont_to_all !(0:max_fg_procs-1)
+ integer,dimension(:,:),allocatable :: itask_cont_from_all,&
+ itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1)
+!-----------------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------------
+ contains
+!-----------------------------------------------------------------------------
+! initialize_p.F
+!-----------------------------------------------------------------------------
+ subroutine initialize
+!
+! Define constants and zero out tables.
+!
+ use comm_iofile
+ use comm_machsw
+ use MCM_data, only: MovTypID
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+!MS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+! include 'COMMON.IOUNITS'
+! include 'COMMON.CHAIN'
+! include 'COMMON.INTERACT'
+! include 'COMMON.GEO'
+! include 'COMMON.LOCAL'
+! include 'COMMON.TORSION'
+! include 'COMMON.FFIELD'
+! include 'COMMON.SBRIDGE'
+! include 'COMMON.MCM'
+! include 'COMMON.MINIM'
+! include 'COMMON.DERIV'
+! include 'COMMON.SPLITELE'
+! implicit none
+! Common blocks from the diagonalization routines
+!el integer :: IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
+!el integer :: KDIAG,ICORFL,IXDR
+!el COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA
+!el COMMON /MACHSW/ KDIAG,ICORFL,IXDR
+ logical :: mask_r
+! real*8 text1 /'initial_i'/
+ real(kind=4) :: rr
+
+!local variables el
+ integer :: i,j,k,l,ichir1,ichir2,iblock,m,maxit
+
+#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
+ mask_r=.false.
+#ifndef ISNAN
+! NaNQ initialization
+ i=-1
+ rr=dacos(100.0d0)
+#ifdef WINPGI
+ idumm=proc_proc(rr,i)
+#elif defined(WHAM_RUN)
+ call proc_proc(rr,i)
+#endif
+#endif
+
+ kdiag=0
+ icorfl=0
+ iw=2
+
+ allocate(MovTypID(-1:MaxMoveType+1))
+ MovTypID=(/'pool ','chain regrow ',&
+ 'multi-bond ','phi ','theta ',&
+ 'side chain ','total '/)
+#endif
+!
+! The following is just to define auxiliary variables used in angle conversion
+!
+ pi=4.0D0*datan(1.0D0)
+ dwapi=2.0D0*pi
+ dwapi3=dwapi/3.0D0
+ pipol=0.5D0*pi
+ deg2rad=pi/180.0D0
+ rad2deg=1.0D0/deg2rad
+ angmin=10.0D0*deg2rad
+!el#ifdef CLUSTER
+!el Rgas = 1.987D-3
+!el#endif
+!
+! Define I/O units.
+!
+ inp= 1
+ iout= 2
+ ipdbin= 3
+ ipdb= 7
+#ifdef CLUSTER
+ imol2= 18
+ jplot= 19
+!el jstatin=10
+ imol2= 4
+ jrms=30
+#else
+ icart = 30
+ imol2= 4
+ ithep_pdb=51
+ irotam_pdb=52
+ irest1=55
+ irest2=56
+ iifrag=57
+ ientin=18
+ ientout=19
+!rc for write_rmsbank1
+ izs1=21
+!dr include secondary structure prediction bias
+ isecpred=27
+#endif
+ igeom= 8
+ intin= 9
+ ithep= 11
+ irotam=12
+ itorp= 13
+ itordp= 23
+ ielep= 14
+ isidep=15
+#if defined(WHAM_RUN) || defined(CLUSTER)
+ isidep1=22 !wham
+#else
+!
+! CSA I/O units (separated from others especially for Jooyoung)
+!
+ icsa_rbank=30
+ icsa_seed=31
+ icsa_history=32
+ icsa_bank=33
+ icsa_bank1=34
+ icsa_alpha=35
+ icsa_alpha1=36
+ icsa_bankt=37
+ icsa_int=39
+ icsa_bank_reminimized=38
+ icsa_native_int=41
+ icsa_in=40
+!rc for ifc error 118
+ icsa_pdb=42
+#endif
+ iscpp=25
+ icbase=16
+ ifourier=20
+ istat= 17
+ ibond = 28
+ isccor = 29
+#ifdef WHAM_RUN
+!
+! WHAM files
+!
+ ihist=30
+ iweight=31
+ izsc=32
+#endif
+#if defined(WHAM_RUN) || defined(CLUSTER)
+!
+! setting the mpi variables for WHAM
+!
+ fgprocs=1
+ nfgtasks=1
+ nfgtasks1=1
+#endif
+!
+! Set default weights of the energy terms.
+!
+ wsc=1.0D0 ! in wham: wlong=1.0D0
+ welec=1.0D0
+ wtor =1.0D0
+ wang =1.0D0
+ wscloc=1.0D0
+ wstrain=1.0D0
+!
+! Zero out tables.
+!
+! print '(a,$)','Inside initialize'
+! call memmon_print_usage()
+
+! do i=1,maxres2
+! do j=1,3
+! c(j,i)=0.0D0
+! dc(j,i)=0.0D0
+! enddo
+! enddo
+! do i=1,maxres
+! do j=1,3
+! xloc(j,i)=0.0D0
+! enddo
+! enddo
+! do i=1,ntyp
+! do j=1,ntyp
+! aa(i,j)=0.0D0
+! bb(i,j)=0.0D0
+! augm(i,j)=0.0D0
+! sigma(i,j)=0.0D0
+! r0(i,j)=0.0D0
+! chi(i,j)=0.0D0
+! enddo
+! do j=1,2
+! bad(i,j)=0.0D0
+! enddo
+! chip(i)=0.0D0
+! alp(i)=0.0D0
+! sigma0(i)=0.0D0
+! sigii(i)=0.0D0
+! rr0(i)=0.0D0
+! a0thet(i)=0.0D0
+! do j=1,2
+! do ichir1=-1,1
+! do ichir2=-1,1
+! athet(j,i,ichir1,ichir2)=0.0D0
+! bthet(j,i,ichir1,ichir2)=0.0D0
+! enddo
+! enddo
+! enddo
+! do j=0,3
+! polthet(j,i)=0.0D0
+! enddo
+! do j=1,3
+! gthet(j,i)=0.0D0
+! enddo
+! theta0(i)=0.0D0
+! sig0(i)=0.0D0
+! sigc0(i)=0.0D0
+! do j=1,maxlob
+! bsc(j,i)=0.0D0
+! do k=1,3
+! censc(k,j,i)=0.0D0
+! enddo
+! do k=1,3
+! do l=1,3
+! gaussc(l,k,j,i)=0.0D0
+! enddo
+! enddo
+! nlob(i)=0
+! enddo
+! enddo
+! nlob(ntyp1)=0
+! dsc(ntyp1)=0.0D0
+! do i=-maxtor,maxtor
+! itortyp(i)=0
+!c write (iout,*) "TU DOCHODZE",i,itortyp(i)
+! do iblock=1,2
+! do j=-maxtor,maxtor
+! do k=1,maxterm
+! v1(k,j,i,iblock)=0.0D0
+! v2(k,j,i,iblock)=0.0D0
+! enddo
+! enddo
+! enddo
+! enddo
+! do iblock=1,2
+! do i=-maxtor,maxtor
+! do j=-maxtor,maxtor
+! do k=-maxtor,maxtor
+! do l=1,maxtermd_1
+! v1c(1,l,i,j,k,iblock)=0.0D0
+! v1s(1,l,i,j,k,iblock)=0.0D0
+! v1c(2,l,i,j,k,iblock)=0.0D0
+! v1s(2,l,i,j,k,iblock)=0.0D0
+! enddo !l
+! do l=1,maxtermd_2
+! do m=1,maxtermd_2
+! v2c(m,l,i,j,k,iblock)=0.0D0
+! v2s(m,l,i,j,k,iblock)=0.0D0
+! enddo !m
+! enddo !l
+! enddo !k
+! enddo !j
+! enddo !i
+! enddo !iblock
+
+! do i=1,maxres
+! itype(i)=0
+! itel(i)=0
+! enddo
+! Initialize the bridge arrays
+ ns=0
+ nss=0
+ nhpb=0
+! do i=1,maxss
+! iss(i)=0
+! enddo
+! do i=1,maxdim
+! dhpb(i)=0.0D0
+! enddo
+! do i=1,maxres
+! ihpb(i)=0
+! jhpb(i)=0
+! enddo
+!
+! Initialize timing.
+!
+ call set_timers
+!
+! Initialize variables used in minimization.
+!
+!c maxfun=5000
+!c maxit=2000
+ maxfun=500
+ maxit=200
+ tolf=1.0D-2
+ rtolf=5.0D-4
+!
+! Initialize the variables responsible for the mode of gradient storage.
+!
+ nfl=0
+ icg=1
+
+#ifdef WHAM_RUN
+ allocate(iww(max_eneW))
+ do i=1,14
+ do j=1,14
+ if (print_order(i).eq.j) then
+ iww(print_order(i))=j
+ goto 1121
+ endif
+ enddo
+1121 continue
+ enddo
+#endif
+
+#if defined(WHAM_RUN) || defined(CLUSTER)
+ ndih_constr=0
+
+! allocate(ww0(max_eneW))
+! ww0 = reshape((/1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,&
+! 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,&
+! 1.0d0,0.0d0,0.0/), shape(ww0))
+!
+ calc_grad=.false.
+! Set timers and counters for the respective routines
+ t_func = 0.0d0
+ t_grad = 0.0d0
+ t_fhel = 0.0d0
+ t_fbet = 0.0d0
+ t_ghel = 0.0d0
+ t_gbet = 0.0d0
+ t_viol = 0.0d0
+ t_gviol = 0.0d0
+ n_func = 0
+ n_grad = 0
+ n_fhel = 0
+ n_fbet = 0
+ n_ghel = 0
+ n_gbet = 0
+ n_viol = 0
+ n_gviol = 0
+ n_map = 0
+#endif
+!
+! Initialize constants used to split the energy into long- and short-range
+! components
+!
+ r_cut=2.0d0
+ rlamb=0.3d0
+#ifndef SPLITELE
+ nprint_ene=nprint_ene-1
+#endif
+ return
+ end subroutine initialize
+!-----------------------------------------------------------------------------
+ subroutine init_int_table
+
+ use geometry, only:int_bounds1
+!el use MPI_data
+!el implicit none
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer,dimension(15) :: blocklengths,displs
+#endif
+! include 'COMMON.CONTROL'
+! include 'COMMON.SETUP'
+! include 'COMMON.CHAIN'
+! include 'COMMON.INTERACT'
+! include 'COMMON.LOCAL'
+! include 'COMMON.SBRIDGE'
+! include 'COMMON.TORCNSTR'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.DERIV'
+! include 'COMMON.CONTACTS'
+!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,&
+!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs)
+!el integer,dimension(nres,0:nfgtasks) :: ielstart_all,&
+!el ielend_all !(maxres,0:max_fg_procs-1)
+!el integer,dimension(0:nfgtasks-1) :: ntask_cont_from_all,&
+!el ntask_cont_to_all !(0:max_fg_procs-1),
+!el integer,dimension(0:nfgtasks-1,0:nfgtasks-1) :: itask_cont_from_all,&
+!el itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1)
+
+!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,&
+!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all,&
+!el ielstart_all,ielend_all,ntask_cont_from_all,itask_cont_from_all,&
+!el ntask_cont_to_all,itask_cont_to_all
+
+ integer :: FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
+ logical :: scheck,lprint,flag
+
+!el local variables
+ integer :: ind_scint=0,ind_scint_old,ii,jj,i,j,iint
+
+#ifdef MPI
+ integer :: my_sc_int(0:nfgtasks-1),my_ele_int(0:nfgtasks-1)
+ integer :: my_sc_intt(0:nfgtasks),my_ele_intt(0:nfgtasks)
+ integer :: n_sc_int_tot,my_sc_inde,my_sc_inds,ind_sctint,npept
+ integer :: nele_int_tot,my_ele_inds,my_ele_inde,ind_eleint_old,&
+ ind_eleint,ijunk,nele_int_tot_vdw,my_ele_inds_vdw,&
+ my_ele_inde_vdw,ind_eleint_vdw,ind_eleint_vdw_old,&
+ nscp_int_tot,my_scp_inds,my_scp_inde,ind_scpint,&
+ ind_scpint_old,nsumgrad,nlen,ngrad_start,ngrad_end,&
+ ierror,k,ierr,iaux,ncheck_to,ncheck_from,ind_typ,&
+ ichunk,int_index_old
+
+!el allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
+!el allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
+
+!... Determine the numbers of start and end SC-SC interaction
+!... to deal with by current processor.
+!write (iout,*) '******INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
+ do i=0,nfgtasks-1
+ itask_cont_from(i)=fg_rank
+ itask_cont_to(i)=fg_rank
+ enddo
+ lprint=energy_dec
+! lprint=.true.
+ if (lprint) &
+ write (iout,*)'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
+ n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
+ call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
+!write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
+ if (lprint) &
+ write (iout,*) 'Processor',fg_rank,' CG group',kolor,&
+ ' absolute rank',MyRank,&
+ ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,&
+ ' my_sc_inde',my_sc_inde
+ ind_sctint=0
+ iatsc_s=0
+ iatsc_e=0
+#endif
+!el common /przechowalnia/
+ allocate(iturn3_start_all(0:nfgtasks))
+ allocate(iturn3_end_all(0:nfgtasks))
+ allocate(iturn4_start_all(0:nfgtasks))
+ allocate(iturn4_end_all(0:nfgtasks))
+ allocate(iatel_s_all(0:nfgtasks))
+ allocate(iatel_e_all(0:nfgtasks))
+ allocate(ielstart_all(nres,0:nfgtasks-1))
+ allocate(ielend_all(nres,0:nfgtasks-1))
+
+ allocate(ntask_cont_from_all(0:nfgtasks-1))
+ allocate(ntask_cont_to_all(0:nfgtasks-1))
+ allocate(itask_cont_from_all(0:nfgtasks-1,0:nfgtasks-1))
+ allocate(itask_cont_to_all(0:nfgtasks-1,0:nfgtasks-1))
+!el----------
+! lprint=.false.
+ do i=1,nres !el !maxres
+ nint_gr(i)=0
+ nscp_gr(i)=0
+ ielstart(i)=0
+ ielend(i)=0
+ do j=1,maxint_gr
+ istart(i,j)=0
+ iend(i,j)=0
+ iscpstart(i,j)=0
+ iscpend(i,j)=0
+ enddo
+ enddo
+ ind_scint=0
+ ind_scint_old=0
+!d write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
+!d & (ihpb(i),jhpb(i),i=1,nss)
+ do i=nnt,nct-1
+ scheck=.false.
+ if (dyn_ss) goto 10
+ do ii=1,nss
+ if (ihpb(ii).eq.i+nres) then
+ scheck=.true.
+ jj=jhpb(ii)-nres
+ goto 10
+ endif
+ enddo
+ 10 continue
+!d write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
+ if (scheck) then
+ if (jj.eq.i+1) then
+#ifdef MPI
+! write (iout,*) 'jj=i+1'
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,&
+ iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+2
+ iend(i,1)=nct
+#endif
+ else if (jj.eq.nct) then
+#ifdef MPI
+! write (iout,*) 'jj=nct'
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,&
+ iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct-1
+#endif
+ else
+#ifdef MPI
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,&
+ iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
+ ii=nint_gr(i)+1
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,&
+ iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
+#else
+ nint_gr(i)=2
+ istart(i,1)=i+1
+ iend(i,1)=jj-1
+ istart(i,2)=jj+1
+ iend(i,2)=nct
+#endif
+ endif
+ else
+#ifdef MPI
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,&
+ iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct
+ ind_scint=ind_scint+nct-i
+#endif
+ endif
+#ifdef MPI
+ ind_scint_old=ind_scint
+#endif
+ enddo
+ 12 continue
+#ifndef MPI
+ iatsc_s=nnt
+ iatsc_e=nct-1
+#endif
+ if (iatsc_s.eq.0) iatsc_s=1
+#ifdef MPI
+ if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,&
+ ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
+#endif
+ if (lprint) then
+ write (iout,'(a)') 'Interaction array:'
+ do i=iatsc_s,iatsc_e
+ write (iout,'(i3,2(2x,2i3))') &
+ i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
+ enddo
+ endif
+ ispp=4 !?? wham ispp=2
+#ifdef MPI
+! Now partition the electrostatic-interaction array
+ npept=nct-nnt
+ nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
+ call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
+ if (lprint) &
+ write (*,*) 'Processor',fg_rank,' CG group',kolor,&
+ ' absolute rank',MyRank,&
+ ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,&
+ ' my_ele_inde',my_ele_inde
+ iatel_s=0
+ iatel_e=0
+ ind_eleint=0
+ ind_eleint_old=0
+ do i=nnt,nct-3
+ ijunk=0
+ call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,&
+ iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
+ enddo ! i
+ 13 continue
+ if (iatel_s.eq.0) iatel_s=1
+ nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
+! write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
+ call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
+! write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
+! & " my_ele_inde_vdw",my_ele_inde_vdw
+ ind_eleint_vdw=0
+ ind_eleint_vdw_old=0
+ iatel_s_vdw=0
+ iatel_e_vdw=0
+ do i=nnt,nct-3
+ ijunk=0
+ call int_partition(ind_eleint_vdw,my_ele_inds_vdw,&
+ my_ele_inde_vdw,i,&
+ iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),&
+ ielend_vdw(i),*15)
+! write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
+! & " ielend_vdw",ielend_vdw(i)
+ enddo ! i
+ if (iatel_s_vdw.eq.0) iatel_s_vdw=1
+ 15 continue
+#else
+ iatel_s=nnt
+ iatel_e=nct-5 ! ?? wham iatel_e=nct-3
+ do i=iatel_s,iatel_e
+ ielstart(i)=i+4 ! ?? wham +2
+ ielend(i)=nct-1
+ enddo
+ iatel_s_vdw=nnt
+ iatel_e_vdw=nct-3
+ do i=iatel_s_vdw,iatel_e_vdw
+ ielstart_vdw(i)=i+2
+ ielend_vdw(i)=nct-1
+ enddo
+#endif
+ if (lprint) then
+ write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,&
+ ' absolute rank',MyRank
+ write (iout,*) 'Electrostatic interaction array:'
+ do i=iatel_s,iatel_e
+ write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
+ enddo
+ endif ! lprint
+! iscp=3
+ iscp=2
+! Partition the SC-p interaction array
+#ifdef MPI
+ nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
+ call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
+ if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,&
+ ' absolute rank',myrank,&
+ ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,&
+ ' my_scp_inde',my_scp_inde
+ iatscp_s=0
+ iatscp_e=0
+ ind_scpint=0
+ ind_scpint_old=0
+ do i=nnt,nct-1
+ if (i.lt.nnt+iscp) then
+!d write (iout,*) 'i.le.nnt+iscp'
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,&
+ iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),&
+ iscpend(i,1),*14)
+ else if (i.gt.nct-iscp) then
+!d write (iout,*) 'i.gt.nct-iscp'
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,&
+ iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),&
+ iscpend(i,1),*14)
+ else
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,&
+ iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),&
+ iscpend(i,1),*14)
+ ii=nscp_gr(i)+1
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,&
+ iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),&
+ iscpend(i,ii),*14)
+ endif
+ enddo ! i
+ 14 continue
+#else
+ iatscp_s=nnt
+ iatscp_e=nct-1
+ do i=nnt,nct-1
+ if (i.lt.nnt+iscp) then
+ nscp_gr(i)=1
+ iscpstart(i,1)=i+iscp
+ iscpend(i,1)=nct
+ elseif (i.gt.nct-iscp) then
+ nscp_gr(i)=1
+ iscpstart(i,1)=nnt
+ iscpend(i,1)=i-iscp
+ else
+ nscp_gr(i)=2
+ iscpstart(i,1)=nnt
+ iscpend(i,1)=i-iscp
+ iscpstart(i,2)=i+iscp
+ iscpend(i,2)=nct
+ endif
+ enddo ! i
+#endif
+ if (iatscp_s.eq.0) iatscp_s=1
+ if (lprint) then
+ write (iout,'(a)') 'SC-p interaction array:'
+ do i=iatscp_s,iatscp_e
+ write (iout,'(i3,2(2x,2i3))') &
+ i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
+ enddo
+ endif ! lprint
+! Partition local interactions
+#ifdef MPI
+ call int_bounds(nres-2,loc_start,loc_end)
+ loc_start=loc_start+1
+ loc_end=loc_end+1
+ call int_bounds(nres-2,ithet_start,ithet_end)
+ ithet_start=ithet_start+2
+ ithet_end=ithet_end+2
+ call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
+ iturn3_start=iturn3_start+nnt
+ iphi_start=iturn3_start+2
+ iturn3_end=iturn3_end+nnt
+ iphi_end=iturn3_end+2
+ iturn3_start=iturn3_start-1
+ iturn3_end=iturn3_end-1
+ call int_bounds(nres-3,itau_start,itau_end)
+ itau_start=itau_start+3
+ itau_end=itau_end+3
+ call int_bounds(nres-3,iphi1_start,iphi1_end)
+ iphi1_start=iphi1_start+3
+ iphi1_end=iphi1_end+3
+ call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
+ iturn4_start=iturn4_start+nnt
+ iphid_start=iturn4_start+2
+ iturn4_end=iturn4_end+nnt
+ iphid_end=iturn4_end+2
+ iturn4_start=iturn4_start-1
+ iturn4_end=iturn4_end-1
+ call int_bounds(nres-2,ibond_start,ibond_end)
+ ibond_start=ibond_start+1
+ ibond_end=ibond_end+1
+ call int_bounds(nct-nnt,ibondp_start,ibondp_end)
+ ibondp_start=ibondp_start+nnt
+ ibondp_end=ibondp_end+nnt
+ call int_bounds1(nres-1,ivec_start,ivec_end)
+! print *,"Processor",myrank,fg_rank,fg_rank1,
+! & " ivec_start",ivec_start," ivec_end",ivec_end
+ iset_start=loc_start+2
+ iset_end=loc_end+2
+ if (ndih_constr.eq.0) then
+ idihconstr_start=1
+ idihconstr_end=0
+ else
+ call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
+ endif
+! nsumgrad=(nres-nnt)*(nres-nnt+1)/2
+! nlen=nres-nnt+1
+ nsumgrad=(nres-nnt)*(nres-nnt+1)/2
+ nlen=nres-nnt+1
+ call int_bounds(nsumgrad,ngrad_start,ngrad_end)
+ igrad_start=((2*nlen+1) &
+ -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
+ igrad_end=((2*nlen+1) &
+ -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
+!el allocate(jgrad_start(igrad_start:igrad_end))
+!el allocate(jgrad_end(igrad_start:igrad_end)) !(maxres)
+ jgrad_start(igrad_start)= &
+ ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 &
+ +igrad_start
+ jgrad_end(igrad_start)=nres
+ if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
+ jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2 &
+ +igrad_end
+ do i=igrad_start+1,igrad_end-1
+ jgrad_start(i)=i+1
+ jgrad_end(i)=nres
+ enddo
+ if (lprint) then
+ write (*,*) 'Processor:',fg_rank,' CG group',kolor,&
+ ' absolute rank',myrank,&
+ ' loc_start',loc_start,' loc_end',loc_end,&
+ ' ithet_start',ithet_start,' ithet_end',ithet_end,&
+ ' iphi_start',iphi_start,' iphi_end',iphi_end,&
+ ' iphid_start',iphid_start,' iphid_end',iphid_end,&
+ ' ibond_start',ibond_start,' ibond_end',ibond_end,&
+ ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,&
+ ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,&
+ ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,&
+ ' ivec_start',ivec_start,' ivec_end',ivec_end,&
+ ' iset_start',iset_start,' iset_end',iset_end,&
+ ' idihconstr_start',idihconstr_start,' idihconstr_end',&
+ idihconstr_end
+ write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',&
+ igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,&
+ ' ngrad_end',ngrad_end
+ do i=igrad_start,igrad_end
+ write(*,*) 'Processor:',fg_rank,myrank,i,&
+ jgrad_start(i),jgrad_end(i)
+ enddo
+ endif
+ if (nfgtasks.gt.1) then
+ call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,&
+ MPI_INTEGER,FG_COMM1,IERROR)
+ iaux=ivec_end-ivec_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,&
+ MPI_INTEGER,FG_COMM1,IERROR)
+ call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iset_end-iset_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ iaux=ibond_end-ibond_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ iaux=ithet_end-ithet_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iphi_end-iphi_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iphi1_end-iphi1_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,&
+ MPI_INTEGER,FG_COMM,IERROR)
+ do i=0,nfgtasks-1
+ do j=1,nres
+ ielstart_all(j,i)=0
+ ielend_all(j,i)=0
+ enddo
+ enddo
+ call MPI_Allgather(iturn3_start,1,MPI_INTEGER,&
+ iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn4_start,1,MPI_INTEGER,&
+ iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn3_end,1,MPI_INTEGER,&
+ iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn4_end,1,MPI_INTEGER,&
+ iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iatel_s,1,MPI_INTEGER,&
+ iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iatel_e,1,MPI_INTEGER,&
+ iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ielstart(1),nres,MPI_INTEGER,&
+ ielstart_all(1,0),nres,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ielend(1),nres,MPI_INTEGER,&
+ ielend_all(1,0),nres,MPI_INTEGER,FG_COMM,IERROR)
+ if (lprint) then
+ write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
+ write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
+ write (iout,*) "iturn3_start_all",&
+ (iturn3_start_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn3_end_all",&
+ (iturn3_end_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn4_start_all",&
+ (iturn4_start_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn4_end_all",&
+ (iturn4_end_all(i),i=0,nfgtasks-1)
+ write (iout,*) "The ielstart_all array"
+ do i=nnt,nct
+ write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
+ enddo
+ write (iout,*) "The ielend_all array"
+ do i=nnt,nct
+ write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
+ enddo
+ call flush(iout)
+ endif
+ ntask_cont_from=0
+ ntask_cont_to=0
+ itask_cont_from(0)=fg_rank
+ itask_cont_to(0)=fg_rank
+ flag=.false.
+!el allocate(iturn3_sent(4,iturn3_start:iturn3_end))
+!el allocate(iturn4_sent(4,iturn4_start:iturn4_end)) !(4,maxres)
+ do ii=iturn3_start,iturn3_end
+ call add_int(ii,ii+2,iturn3_sent(1,ii),&
+ ntask_cont_to,itask_cont_to,flag)
+ enddo
+ do ii=iturn4_start,iturn4_end
+ call add_int(ii,ii+3,iturn4_sent(1,ii),&
+ ntask_cont_to,itask_cont_to,flag)
+ enddo
+ do ii=iturn3_start,iturn3_end
+ call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
+ enddo
+ do ii=iturn4_start,iturn4_end
+ call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
+ enddo
+ if (lprint) then
+ write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,&
+ " ntask_cont_to",ntask_cont_to
+ write (iout,*) "itask_cont_from",&
+ (itask_cont_from(i),i=1,ntask_cont_from)
+ write (iout,*) "itask_cont_to",&
+ (itask_cont_to(i),i=1,ntask_cont_to)
+ call flush(iout)
+ endif
+! write (iout,*) "Loop forward"
+! call flush(iout)
+ do i=iatel_s,iatel_e
+! write (iout,*) "from loop i=",i
+! call flush(iout)
+ do j=ielstart(i),ielend(i)
+ call add_int_from(i,j,ntask_cont_from,itask_cont_from)
+ enddo
+ enddo
+! write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
+! & " iatel_e",iatel_e
+! call flush(iout)
+ nat_sent=0
+ do i=iatel_s,iatel_e
+! write (iout,*) "i",i," ielstart",ielstart(i),
+! & " ielend",ielend(i)
+! call flush(iout)
+ flag=.false.
+ do j=ielstart(i),ielend(i)
+ call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,&
+ itask_cont_to,flag)
+ enddo
+ if (flag) then
+ nat_sent=nat_sent+1
+ iat_sent(nat_sent)=i
+ endif
+ enddo
+ if (lprint) then
+ write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,&
+ " ntask_cont_to",ntask_cont_to
+ write (iout,*) "itask_cont_from",&
+ (itask_cont_from(i),i=1,ntask_cont_from)
+ write (iout,*) "itask_cont_to",&
+ (itask_cont_to(i),i=1,ntask_cont_to)
+ call flush(iout)
+ write (iout,*) "iint_sent"
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),&
+ j=ielstart(ii),ielend(ii))
+ enddo
+ write (iout,*) "iturn3_sent iturn3_start",iturn3_start,&
+ " iturn3_end",iturn3_end
+ write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),&
+ i=iturn3_start,iturn3_end)
+ write (iout,*) "iturn4_sent iturn4_start",iturn4_start,&
+ " iturn4_end",iturn4_end
+ write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),&
+ i=iturn4_start,iturn4_end)
+ call flush(iout)
+ endif
+ call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,&
+ ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
+! write (iout,*) "Gather ntask_cont_from ended"
+! call flush(iout)
+ call MPI_Gather(itask_cont_from(0),nfgtasks,MPI_INTEGER,&
+ itask_cont_from_all(0,0),nfgtasks,MPI_INTEGER,king,&
+ FG_COMM,IERR)
+! write (iout,*) "Gather itask_cont_from ended"
+! call flush(iout)
+ call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,&
+ 1,MPI_INTEGER,king,FG_COMM,IERR)
+! write (iout,*) "Gather ntask_cont_to ended"
+! call flush(iout)
+ call MPI_Gather(itask_cont_to,nfgtasks,MPI_INTEGER,&
+ itask_cont_to_all,nfgtasks,MPI_INTEGER,king,FG_COMM,IERR)
+! write (iout,*) "Gather itask_cont_to ended"
+! call flush(iout)
+ if (fg_rank.eq.king) then
+ write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
+ do i=0,nfgtasks-1
+ write (iout,'(20i4)') i,ntask_cont_from_all(i),&
+ (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
+ enddo
+ write (iout,*)
+ call flush(iout)
+ write (iout,*) "Contact send task map (proc, #tasks, tasks)"
+ do i=0,nfgtasks-1
+ write (iout,'(20i4)') i,ntask_cont_to_all(i),&
+ (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
+ enddo
+ write (iout,*)
+ call flush(iout)
+! Check if every send will have a matching receive
+ ncheck_to=0
+ ncheck_from=0
+ do i=0,nfgtasks-1
+ ncheck_to=ncheck_to+ntask_cont_to_all(i)
+ ncheck_from=ncheck_from+ntask_cont_from_all(i)
+ enddo
+ write (iout,*) "Control sums",ncheck_from,ncheck_to
+ if (ncheck_from.ne.ncheck_to) then
+ write (iout,*) "Error: #receive differs from #send."
+ write (iout,*) "Terminating program...!"
+ call flush(iout)
+ flag=.false.
+ else
+ flag=.true.
+ do i=0,nfgtasks-1
+ do j=1,ntask_cont_to_all(i)
+ ii=itask_cont_to_all(j,i)
+ do k=1,ntask_cont_from_all(ii)
+ if (itask_cont_from_all(k,ii).eq.i) then
+ if(lprint)write(iout,*)"Matching send/receive",i,ii
+ exit
+ endif
+ enddo
+ if (k.eq.ntask_cont_from_all(ii)+1) then
+ flag=.false.
+ write (iout,*) "Error: send by",j," to",ii,&
+ " would have no matching receive"
+ endif
+ enddo
+ enddo
+ endif
+ if (.not.flag) then
+ write (iout,*) "Unmatched sends; terminating program"
+ call flush(iout)
+ endif
+ endif
+ call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
+! write (iout,*) "flag broadcast ended flag=",flag
+! call flush(iout)
+ if (.not.flag) then
+ call MPI_Finalize(IERROR)
+ stop "Error in INIT_INT_TABLE: unmatched send/receive."
+ endif
+ call MPI_Comm_group(FG_COMM,fg_group,IERR)
+! write (iout,*) "MPI_Comm_group ended"
+! call flush(iout)
+ call MPI_Group_incl(fg_group,ntask_cont_from+1,&
+ itask_cont_from(0),CONT_FROM_GROUP,IERR)
+ call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),&
+ CONT_TO_GROUP,IERR)
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ iaux=4*(ielend(ii)-ielstart(ii)+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,&
+ iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,&
+ iint_sent_local(1,ielstart(ii),i),IERR )
+! write (iout,*) "Ranks translated i=",i
+! call flush(iout)
+ enddo
+ iaux=4*(iturn3_end-iturn3_start+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,&
+ iturn3_sent(1,iturn3_start),CONT_TO_GROUP,&
+ iturn3_sent_local(1,iturn3_start),IERR)
+ iaux=4*(iturn4_end-iturn4_start+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,&
+ iturn4_sent(1,iturn4_start),CONT_TO_GROUP,&
+ iturn4_sent_local(1,iturn4_start),IERR)
+ if (lprint) then
+ write (iout,*) "iint_sent_local"
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),&
+ j=ielstart(ii),ielend(ii))
+ call flush(iout)
+ enddo
+ write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,&
+ " iturn3_end",iturn3_end
+ write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),&
+ i=iturn3_start,iturn3_end)
+ write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,&
+ " iturn4_end",iturn4_end
+ write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),&
+ i=iturn4_start,iturn4_end)
+ call flush(iout)
+ endif
+ call MPI_Group_free(fg_group,ierr)
+ call MPI_Group_free(cont_from_group,ierr)
+ call MPI_Group_free(cont_to_group,ierr)
+ call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
+ call MPI_Type_commit(MPI_UYZ,IERROR)
+ call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,&
+ IERROR)
+ call MPI_Type_commit(MPI_UYZGRAD,IERROR)
+ call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
+ call MPI_Type_commit(MPI_MU,IERROR)
+ call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
+ call MPI_Type_commit(MPI_MAT1,IERROR)
+ call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
+ call MPI_Type_commit(MPI_MAT2,IERROR)
+ call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
+ call MPI_Type_commit(MPI_THET,IERROR)
+ call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
+ call MPI_Type_commit(MPI_GAM,IERROR)
+
+!el allocate(lentyp(0:nfgtasks-1))
+#ifndef MATGATHER
+! 9/22/08 Derived types to send matrices which appear in correlation terms
+ do i=0,nfgtasks-1
+ if (ivec_count(i).eq.ivec_count(0)) then
+ lentyp(i)=0
+ else
+ lentyp(i)=1
+ endif
+ enddo
+ do ind_typ=lentyp(0),lentyp(nfgtasks-1)
+ if (ind_typ.eq.0) then
+ ichunk=ivec_count(0)
+ else
+ ichunk=ivec_count(1)
+ endif
+! do i=1,4
+! blocklengths(i)=4
+! enddo
+! displs(1)=0
+! do i=2,4
+! displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+! enddo
+! do i=1,4
+! blocklengths(i)=blocklengths(i)*ichunk
+! enddo
+! write (iout,*) "blocklengths and displs"
+! do i=1,4
+! write (iout,*) i,blocklengths(i),displs(i)
+! enddo
+! call flush(iout)
+! call MPI_Type_indexed(4,blocklengths(1),displs(1),
+! & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
+! call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
+! write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
+! do i=1,4
+! blocklengths(i)=2
+! enddo
+! displs(1)=0
+! do i=2,4
+! displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+! enddo
+! do i=1,4
+! blocklengths(i)=blocklengths(i)*ichunk
+! enddo
+! write (iout,*) "blocklengths and displs"
+! do i=1,4
+! write (iout,*) i,blocklengths(i),displs(i)
+! enddo
+! call flush(iout)
+! call MPI_Type_indexed(4,blocklengths(1),displs(1),
+! & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
+! call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
+! write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
+ do i=1,8
+ blocklengths(i)=2
+ enddo
+ displs(1)=0
+ do i=2,8
+ displs(i)=displs(i-1)+blocklengths(i-1)*nres !maxres
+ enddo
+ do i=1,15
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(8,blocklengths,displs,&
+ MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
+ do i=1,8
+ blocklengths(i)=4
+ enddo
+ displs(1)=0
+ do i=2,8
+ displs(i)=displs(i-1)+blocklengths(i-1)*nres !maxres
+ enddo
+ do i=1,15
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(8,blocklengths,displs,&
+ MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
+ do i=1,6
+ blocklengths(i)=4
+ enddo
+ displs(1)=0
+ do i=2,6
+ displs(i)=displs(i-1)+blocklengths(i-1)*nres !maxres
+ enddo
+ do i=1,6
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(6,blocklengths,displs,&
+ MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
+ do i=1,2
+ blocklengths(i)=8
+ enddo
+ displs(1)=0
+ do i=2,2
+ displs(i)=displs(i-1)+blocklengths(i-1)*nres !maxres
+ enddo
+ do i=1,2
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(2,blocklengths,displs,&
+ MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
+ do i=1,4
+ blocklengths(i)=1
+ enddo
+ displs(1)=0
+ do i=2,4
+ displs(i)=displs(i-1)+blocklengths(i-1)*nres !maxres
+ enddo
+ do i=1,4
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(4,blocklengths,displs,&
+ MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
+ enddo
+#endif
+ endif
+ iint_start=ivec_start+1
+ iint_end=ivec_end+1
+ do i=0,nfgtasks-1
+ iint_count(i)=ivec_count(i)
+ iint_displ(i)=ivec_displ(i)
+ ivec_displ(i)=ivec_displ(i)-1
+ iset_displ(i)=iset_displ(i)-1
+ ithet_displ(i)=ithet_displ(i)-1
+ iphi_displ(i)=iphi_displ(i)-1
+ iphi1_displ(i)=iphi1_displ(i)-1
+ ibond_displ(i)=ibond_displ(i)-1
+ enddo
+ if (nfgtasks.gt.1 .and. fg_rank.eq.king &
+ .and. (me.eq.0 .or. .not. out1file)) then
+ write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
+ do i=0,nfgtasks-1
+ write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),&
+ iset_count(i)
+ enddo
+ write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,&
+ " iphi1_start",iphi1_start," iphi1_end",iphi1_end
+ write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
+ do i=0,nfgtasks-1
+ write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),&
+ iphi1_displ(i)
+ enddo
+ write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',&
+ nele_int_tot,' electrostatic and ',nscp_int_tot,&
+ ' SC-p interactions','were distributed among',nfgtasks,&
+ ' fine-grain processors.'
+ endif
+#else
+ loc_start=2
+ loc_end=nres-1
+ ithet_start=3
+ ithet_end=nres
+ iturn3_start=nnt
+ iturn3_end=nct-3
+ iturn4_start=nnt
+ iturn4_end=nct-4
+ iphi_start=nnt+3
+ iphi_end=nct
+ iphi1_start=4
+ iphi1_end=nres
+ idihconstr_start=1
+ idihconstr_end=ndih_constr
+ iphid_start=iphi_start
+ iphid_end=iphi_end-1
+ itau_start=4
+ itau_end=nres
+ ibond_start=2
+ ibond_end=nres-1
+ ibondp_start=nnt
+ ibondp_end=nct-1
+ ivec_start=1
+ ivec_end=nres-1
+ iset_start=3
+ iset_end=nres+1
+ iint_start=2
+ iint_end=nres-1
+#endif
+!el common /przechowalnia/
+! deallocate(iturn3_start_all)
+! deallocate(iturn3_end_all)
+! deallocate(iturn4_start_all)
+! deallocate(iturn4_end_all)
+! deallocate(iatel_s_all)
+! deallocate(iatel_e_all)
+! deallocate(ielstart_all)
+! deallocate(ielend_all)
+
+! deallocate(ntask_cont_from_all)
+! deallocate(ntask_cont_to_all)
+! deallocate(itask_cont_from_all)
+! deallocate(itask_cont_to_all)
+!el----------
+ return
+ end subroutine init_int_table
+#ifdef MPI
+!-----------------------------------------------------------------------------
+ subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
+
+!el implicit none
+! include "DIMENSIONS"
+! include "COMMON.INTERACT"
+! include "COMMON.SETUP"
+! include "COMMON.IOUNITS"
+ integer :: ii,jj,ntask_cont_to
+ integer,dimension(4) :: itask
+ integer :: itask_cont_to(0:nfgtasks-1) !(0:max_fg_procs-1)
+ logical :: flag
+!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,iturn4_start_all,&
+!el iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs)
+!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1)
+!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,&
+!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
+ integer :: iproc,isent,k,l
+! Determines whether to send interaction ii,jj to other processors; a given
+! interaction can be sent to at most 2 processors.
+! Sets flag=.true. if interaction ii,jj needs to be sent to at least
+! one processor, otherwise flag is unchanged from the input value.
+ isent=0
+ itask(1)=fg_rank
+ itask(2)=fg_rank
+ itask(3)=fg_rank
+ itask(4)=fg_rank
+! write (iout,*) "ii",ii," jj",jj
+! Loop over processors to check if anybody could need interaction ii,jj
+ do iproc=0,fg_rank-1
+! Check if the interaction matches any turn3 at iproc
+ do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
+ l=k+2
+ if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 &
+ .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) &
+ then
+! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
+! call flush(iout)
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2) &
+ .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ enddo
+! Check if the interaction matches any turn4 at iproc
+ do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
+ l=k+3
+ if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 &
+ .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) &
+ then
+! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
+! call flush(iout)
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2) &
+ .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ enddo
+ if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and. &
+ iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
+ if (ielstart_all(ii-1,iproc).le.jj-1.and. &
+ ielend_all(ii-1,iproc).ge.jj-1) then
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2) &
+ .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ if (ielstart_all(ii-1,iproc).le.jj+1.and. &
+ ielend_all(ii-1,iproc).ge.jj+1) then
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2) &
+ .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ endif
+ enddo
+ return
+ end subroutine add_int
+!-----------------------------------------------------------------------------
+ subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
+
+!el use MPI_data
+!el implicit none
+! include "DIMENSIONS"
+! include "COMMON.INTERACT"
+! include "COMMON.SETUP"
+! include "COMMON.IOUNITS"
+ integer :: ii,jj,itask(2),ntask_cont_from,&
+ itask_cont_from(0:nfgtasks-1) !(0:max_fg_procs)
+ logical :: flag
+!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,&
+!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs)
+!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1)
+!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,&
+!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
+ integer :: iproc,k,l
+ do iproc=fg_rank+1,nfgtasks-1
+ do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
+ l=k+2
+ if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 &
+ .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) &
+ then
+! write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ enddo
+ do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
+ l=k+3
+ if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 &
+ .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) &
+ then
+! write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ enddo
+ if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
+ if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc)) &
+ then
+ if (jj+1.ge.ielstart_all(ii+1,iproc).and. &
+ jj+1.le.ielend_all(ii+1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ if (jj-1.ge.ielstart_all(ii+1,iproc).and. &
+ jj-1.le.ielend_all(ii+1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ endif
+ if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc)) &
+ then
+ if (jj-1.ge.ielstart_all(ii-1,iproc).and. &
+ jj-1.le.ielend_all(ii-1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ if (jj+1.ge.ielstart_all(ii-1,iproc).and. &
+ jj+1.le.ielend_all(ii-1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ endif
+ endif
+ enddo
+ return
+ end subroutine add_int_from
+!-----------------------------------------------------------------------------
+ subroutine add_task(iproc,ntask_cont,itask_cont)
+
+!el use MPI_data
+!el implicit none
+! include "DIMENSIONS"
+ integer :: iproc,ntask_cont,itask_cont(0:nfgtasks-1) !(0:max_fg_procs-1)
+ integer :: ii
+ do ii=1,ntask_cont
+ if (itask_cont(ii).eq.iproc) return
+ enddo
+ ntask_cont=ntask_cont+1
+ itask_cont(ntask_cont)=iproc
+ return
+ end subroutine add_task
+#endif
+!-----------------------------------------------------------------------------
+#if defined MPI || defined WHAM_RUN
+ subroutine int_partition(int_index,lower_index,upper_index,atom,&
+ at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
+
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+ integer :: int_index,lower_index,upper_index,atom,at_start,at_end,&
+ first_atom,last_atom,int_gr,jat_start,jat_end,int_index_old
+ logical :: lprn
+ lprn=.false.
+ if (lprn) write (iout,*) 'int_index=',int_index
+ int_index_old=int_index
+ int_index=int_index+last_atom-first_atom+1
+ if (lprn) &
+ write (iout,*) 'int_index=',int_index,&
+ ' int_index_old',int_index_old,&
+ ' lower_index=',lower_index,&
+ ' upper_index=',upper_index,&
+ ' atom=',atom,' first_atom=',first_atom,&
+ ' last_atom=',last_atom
+ if (int_index.ge.lower_index) then
+ int_gr=int_gr+1
+ if (at_start.eq.0) then
+ at_start=atom
+ jat_start=first_atom-1+lower_index-int_index_old
+ else
+ jat_start=first_atom
+ endif
+ if (lprn) write (iout,*) 'jat_start',jat_start
+ if (int_index.ge.upper_index) then
+ at_end=atom
+ jat_end=first_atom-1+upper_index-int_index_old
+ return 1
+ else
+ jat_end=last_atom
+ endif
+ if (lprn) write (iout,*) 'jat_end',jat_end
+ endif
+ return
+ end subroutine int_partition
+#endif
+!-----------------------------------------------------------------------------
+#ifndef CLUSTER
+ subroutine hpb_partition
+
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+! include 'COMMON.SBRIDGE'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.SETUP'
+#ifdef MPI
+ call int_bounds(nhpb,link_start,link_end)
+ write (iout,*) 'Processor',fg_rank,' CG group',kolor,&
+ ' absolute rank',MyRank,&
+ ' nhpb',nhpb,' link_start=',link_start,&
+ ' link_end',link_end
+#else
+ link_start=1
+ link_end=nhpb
+#endif
+ return
+ end subroutine hpb_partition
+#endif
+!-----------------------------------------------------------------------------
+! misc.f in module io_base
+!-----------------------------------------------------------------------------
+!-----------------------------------------------------------------------------
+! parmread.F
+!-----------------------------------------------------------------------------
+ subroutine getenv_loc(var, val)
+
+ character(*) :: var, val
+
+#ifdef WINIFL
+ character(len=2000) :: line
+!el external ilen
+
+ open (196,file='env',status='old',readonly,shared)
+ iread=0
+! write(*,*)'looking for ',var
+10 read(196,*,err=11,end=11)line
+ iread=index(line,var)
+! write(*,*)iread,' ',var,' ',line
+ if (iread.eq.0) go to 10
+! write(*,*)'---> ',line
+11 continue
+ if(iread.eq.0) then
+! write(*,*)'CHUJ'
+ val=''
+ else
+ iread=iread+ilen(var)+1
+ read (line(iread:),*,err=12,end=12) val
+! write(*,*)'OK: ',var,' = ',val
+ endif
+ close(196)
+ return
+12 val=''
+ close(196)
+#elif (defined CRAY)
+ integer :: lennam,lenval,ierror
+!
+! getenv using a POSIX call, useful on the T3D
+! Sept 1996, comment out error check on advice of H. Pritchard
+!
+ lennam = len(var)
+ if(lennam.le.0) stop '--error calling getenv--'
+ call pxfgetenv(var,lennam,val,lenval,ierror)
+!-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--'
+#else
+ call getenv(var,val)
+#endif
+
+ return
+ end subroutine getenv_loc
+!-----------------------------------------------------------------------------
+! readrtns_CSA.F
+!-----------------------------------------------------------------------------
+ subroutine setup_var
+
+ integer :: i
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.INTERACT'
+! include 'COMMON.LOCAL'
+! include 'COMMON.NAMES'
+! include 'COMMON.CHAIN'
+! include 'COMMON.FFIELD'
+! include 'COMMON.SBRIDGE'
+! include 'COMMON.HEADER'
+! include 'COMMON.CONTROL'
+! include 'COMMON.DBASE'
+! include 'COMMON.THREAD'
+! include 'COMMON.TIME1'
+! Set up variable list.
+ ntheta=nres-2
+ nphi=nres-3
+ nvar=ntheta+nphi
+ nside=0
+ do i=2,nres-1
+#ifdef WHAM_RUN
+ if (itype(i).ne.10) then
+#else
+ if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then
+#endif
+ nside=nside+1
+ ialph(i,1)=nvar+nside
+ ialph(nside,2)=i
+ endif
+ enddo
+ if (indphi.gt.0) then
+ nvar=nphi
+ else if (indback.gt.0) then
+ nvar=nphi+ntheta
+ else
+ nvar=nvar+2*nside
+ endif
+!d write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1)
+ return
+ end subroutine setup_var
+!-----------------------------------------------------------------------------
+! rescode.f
+!-----------------------------------------------------------------------------
+ integer function rescode(iseq,nam,itype)
+
+ use io_base, only: ucase
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.NAMES'
+! include 'COMMON.IOUNITS'
+ character(len=3) :: nam !,ucase
+ integer :: iseq,itype,i
+
+ if (itype.eq.0) then
+
+ do i=-ntyp1,ntyp1
+ if (ucase(nam).eq.restyp(i)) then
+ rescode=i
+ return
+ endif
+ enddo
+
+ else
+
+ do i=-ntyp1,ntyp1
+ if (nam(1:1).eq.onelet(i)) then
+ rescode=i
+ return
+ endif
+ enddo
+
+ endif
+ write (iout,10) iseq,nam
+ stop
+ 10 format ('**** Error - residue',i4,' has an unresolved name ',a3)
+ end function rescode
+!-----------------------------------------------------------------------------
+! timing.F
+!-----------------------------------------------------------------------------
+! $Date: 1994/10/05 16:41:52 $
+! $Revision: 2.2 $
+!
+ subroutine set_timers
+!
+!el implicit none
+!el real(kind=8) :: tcpu
+! include 'COMMON.TIME1'
+!#ifdef MP
+#ifdef MPI
+ include 'mpif.h'
+#endif
+! Diminish the assigned time limit a little so that there is some time to
+! end a batch job
+! timlim=batime-150.0
+! Calculate the initial time, if it is not zero (e.g. for the SUN).
+ stime=tcpu()
+#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
+#ifdef MPI
+ walltime=MPI_WTIME()
+ time_reduce=0.0d0
+ time_allreduce=0.0d0
+ time_bcast=0.0d0
+ time_gather=0.0d0
+ time_sendrecv=0.0d0
+ time_scatter=0.0d0
+ time_scatter_fmat=0.0d0
+ time_scatter_ginv=0.0d0
+ time_scatter_fmatmult=0.0d0
+ time_scatter_ginvmult=0.0d0
+ time_barrier_e=0.0d0
+ time_barrier_g=0.0d0
+ time_enecalc=0.0d0
+ time_sumene=0.0d0
+ time_lagrangian=0.0d0
+ time_sumgradient=0.0d0
+ time_intcartderiv=0.0d0
+ time_inttocart=0.0d0
+ time_ginvmult=0.0d0
+ time_fricmatmult=0.0d0
+ time_cartgrad=0.0d0
+ time_bcastc=0.0d0
+ time_bcast7=0.0d0
+ time_bcastw=0.0d0
+ time_intfcart=0.0d0
+ time_vec=0.0d0
+ time_mat=0.0d0
+ time_fric=0.0d0
+ time_stoch=0.0d0
+ time_fricmatmult=0.0d0
+ time_fsample=0.0d0
+#endif
+#endif
+!d print *,' in SET_TIMERS stime=',stime
+ return
+ end subroutine set_timers
+!-----------------------------------------------------------------------------
+#ifndef CLUSTER
+ logical function stopx(nf)
+! This function returns .true. if one of the following reasons to exit SUMSL
+! occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block:
+!
+!... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false.
+!... 1 - Time up in current node;
+!... 2 - STOP signal was received from another node because the
+!... node's task was accomplished (parallel only);
+!... -1 - STOP signal was received from another node because of error;
+!... -2 - STOP signal was received from another node, because
+!... the node's time was up.
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+!el#ifdef WHAM_RUN
+!el use control_data, only:WhatsUp
+!el#endif
+#ifdef MP
+!el use MPI_data !include 'COMMON.INFO'
+ include 'mpif.h'
+#endif
+ integer :: nf
+!el logical :: ovrtim
+
+! include 'COMMON.IOUNITS'
+! include 'COMMON.TIME1'
+ integer :: Kwita
+
+!d print *,'Processor',MyID,' NF=',nf
+!d write (iout,*) "stopx: ",nf
+#ifndef WHAM_RUN
+#ifndef MPI
+ if (ovrtim()) then
+! Finish if time is up.
+ stopx = .true.
+ WhatsUp=1
+#ifdef MPL
+ else if (mod(nf,100).eq.0) then
+! Other processors might have finished. Check this every 100th function
+! evaluation.
+! Master checks if any other processor has sent accepted conformation(s) to it.
+ if (MyID.ne.MasterID) call receive_mcm_info
+ if (MyID.eq.MasterID) call receive_conf
+!d print *,'Processor ',MyID,' is checking STOP: nf=',nf
+ call recv_stop_sig(Kwita)
+ if (Kwita.eq.-1) then
+ write (iout,'(a,i4,a,i5)') 'Processor',&
+ MyID,' has received STOP signal in STOPX; NF=',nf
+ write (*,'(a,i4,a,i5)') 'Processor',&
+ MyID,' has received STOP signal in STOPX; NF=',nf
+ stopx=.true.
+ WhatsUp=2
+ elseif (Kwita.eq.-2) then
+ write (iout,*) &
+ 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ write (*,*) &
+ 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ WhatsUp=-2
+ stopx=.true.
+ else if (Kwita.eq.-3) then
+ write (iout,*) &
+ 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ write (*,*) &
+ 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ WhatsUp=-1
+ stopx=.true.
+ else
+ stopx=.false.
+ WhatsUp=0
+ endif
+#endif
+ else
+ stopx = .false.
+ WhatsUp=0
+ endif
+#else
+ stopx=.false.
+!d write (iout,*) "stopx set at .false."
+#endif
+
+#ifdef OSF
+! Check for FOUND_NAN flag
+ if (FOUND_NAN) then
+ write(iout,*)" *** stopx : Found a NaN"
+ stopx=.true.
+ endif
+#endif
+#else
+ if (ovrtim()) then
+! Finish if time is up.
+ stopx = .true.
+ WhatsUp=1
+ else if (cutoffviol) then
+ stopx = .true.
+ WhatsUp=2
+ else
+ stopx=.false.
+ endif
+#endif
+ return
+ end function stopx
+!-----------------------------------------------------------------------------
+#else
+ logical function stopx(nf)
+!
+! ..................................................................
+!
+! *****PURPOSE...
+! THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
+! FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
+! THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
+! DYNAMIC STOPX.
+!
+! *****ALGORITHM NOTES...
+! AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
+! INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
+! FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
+! (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
+!
+! $$$ MODIFIED FOR USE AS THE TIMER ROUTINE.
+! $$$ WHEN THE TIME LIMIT HAS BEEN
+! $$$ REACHED STOPX IS SET TO .TRUE AND INITIATES (IN ITSUM)
+! $$$ AND ORDERLY EXIT OUT OF SUMSL. IF ARRAYS IV AND V ARE
+! $$$ SAVED, THE SUMSL ROUTINES CAN BE RESTARTED AT THE SAME
+! $$$ POINT AT WHICH THEY WERE INTERRUPTED.
+!
+! ..................................................................
+!
+! include 'DIMENSIONS'
+ integer :: nf
+! logical ovrtim
+! include 'COMMON.IOUNITS'
+! include 'COMMON.TIME1'
+#ifdef MPL
+! include 'COMMON.INFO'
+ integer :: Kwita
+
+!d print *,'Processor',MyID,' NF=',nf
+#endif
+ if (ovrtim()) then
+! Finish if time is up.
+ stopx = .true.
+#ifdef MPL
+ else if (mod(nf,100).eq.0) then
+! Other processors might have finished. Check this every 100th function
+! evaluation.
+!d print *,'Processor ',MyID,' is checking STOP: nf=',nf
+ call recv_stop_sig(Kwita)
+ if (Kwita.eq.-1) then
+ write (iout,'(a,i4,a,i5)') 'Processor',&
+ MyID,' has received STOP signal in STOPX; NF=',nf
+ write (*,'(a,i4,a,i5)') 'Processor',&
+ MyID,' has received STOP signal in STOPX; NF=',nf
+ stopx=.true.
+ else
+ stopx=.false.
+ endif
+#endif
+ else
+ stopx = .false.
+ endif
+ return
+ end function stopx
+#endif
+!-----------------------------------------------------------------------------
+ logical function ovrtim()
+
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.TIME1'
+!el real(kind=8) :: tcpu
+ real(kind=8) :: curtim
+#ifdef MPI
+ include "mpif.h"
+ curtim = MPI_Wtime()-walltime
+#else
+ curtim= tcpu()
+#endif
+! curtim is the current time in seconds.
+! write (iout,*) "curtim",curtim," timlim",timlim," safety",safety
+#ifndef WHAM_RUN
+ if (curtim .ge. timlim - safety) then
+ write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)') &
+ "***************** Elapsed time (",curtim,&
+ " s) is within the safety limit (",safety,&
+ " s) of the allocated time (",timlim," s). Terminating."
+ ovrtim=.true.
+ else
+ ovrtim=.false.
+ endif
+#else
+ ovrtim=.false.
+#endif
+!elwrite (iout,*) "ovrtim",ovrtim
+ return
+ end function ovrtim
+!-----------------------------------------------------------------------------
+ real(kind=8) function tcpu()
+
+! include 'COMMON.TIME1'
+ real(kind=8) :: seconds
+#ifdef ES9000
+!***************************
+! Next definition for EAGLE (ibm-es9000)
+ real(kind=8) :: micseconds
+ integer :: rcode
+ tcpu=cputime(micseconds,rcode)
+ tcpu=(micseconds/1.0E6) - stime
+!***************************
+#endif
+#ifdef SUN
+!***************************
+! Next definitions for sun
+ REAL(kind=8) :: ECPU,ETIME,ETCPU
+ real(kind=8),dimension(2) :: tarray
+ tcpu=etime(tarray)
+ tcpu=tarray(1)
+!***************************
+#endif
+#ifdef KSR
+!***************************
+! Next definitions for ksr
+! this function uses the ksr timer ALL_SECONDS from the PMON library to
+! return the elapsed time in seconds
+ tcpu= all_seconds() - stime
+!***************************
+#endif
+#ifdef SGI
+!***************************
+! Next definitions for sgi
+ real(kind=4) :: timar(2), etime
+ seconds = etime(timar)
+!d print *,'seconds=',seconds,' stime=',stime
+! usrsec = timar(1)
+! syssec = timar(2)
+ tcpu=seconds - stime
+!***************************
+#endif
+
+#ifdef LINUX
+!***************************
+! Next definitions for sgi
+ real(kind=4) :: timar(2), etime
+ seconds = etime(timar)
+!d print *,'seconds=',seconds,' stime=',stime
+! usrsec = timar(1)
+! syssec = timar(2)
+ tcpu=seconds - stime
+!***************************
+#endif
+
+
+#ifdef CRAY
+!***************************
+! Next definitions for Cray
+! call date(curdat)
+! curdat=curdat(1:9)
+! call clock(curtim)
+! curtim=curtim(1:8)
+ cpusec = second()
+ tcpu=cpusec - stime
+!***************************
+#endif
+#ifdef AIX
+!***************************
+! Next definitions for RS6000
+ integer(kind=4) :: i1,mclock
+ i1 = mclock()
+ tcpu = (i1+0.0D0)/100.0D0
+#endif
+#ifdef WINPGI
+!***************************
+! next definitions for windows NT Digital fortran
+ real(kind=4) :: time_real
+ call cpu_time(time_real)
+ tcpu = time_real
+#endif
+#ifdef WINIFL
+!***************************
+! next definitions for windows NT Digital fortran
+ real(kind=4) :: time_real
+ call cpu_time(time_real)
+ tcpu = time_real
+#endif
+ tcpu = 0d0 !el
+ return
+ end function tcpu
+!-----------------------------------------------------------------------------
+#ifndef CLUSTER
+ subroutine dajczas(rntime,hrtime,mintime,sectime)
+
+! include 'COMMON.IOUNITS'
+ integer :: ihr,imn,isc
+ real(kind=8) :: rntime,hrtime,mintime,sectime
+ hrtime=rntime/3600.0D0
+ hrtime=aint(hrtime)
+ mintime=aint((rntime-3600.0D0*hrtime)/60.0D0)
+ sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0)
+ if (sectime.eq.60.0D0) then
+ sectime=0.0D0
+ mintime=mintime+1.0D0
+ endif
+ ihr=hrtime
+ imn=mintime
+ isc=sectime
+ write (iout,328) ihr,imn,isc
+ 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 ,&
+ ' minutes ', I2 ,' seconds *****')
+ return
+ end subroutine dajczas
+!-----------------------------------------------------------------------------
+ subroutine print_detailed_timing
+
+!el use MPI_data
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+! include 'COMMON.IOUNITS'
+! include 'COMMON.TIME1'
+! include 'COMMON.SETUP'
+ real(kind=8) :: time1,time_barrier
+ time_barrier = 0.0d0
+#ifdef MPI !el
+ time1=MPI_WTIME()
+#endif !el
+ write (iout,'(80(1h=)/a/(80(1h=)))') &
+ "Details of FG communication time"
+ write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') &
+ "BROADCAST:",time_bcast,"REDUCE:",time_reduce,&
+ "GATHER:",time_gather,&
+ "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,&
+ "BARRIER ene",time_barrier_e,&
+ "BARRIER grad",time_barrier_g,&
+ "TOTAL:",&
+ time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv
+ write (*,*) fg_rank,myrank,&
+ ': Total wall clock time',time1-walltime,' sec'
+ write (*,*) "Processor",fg_rank,myrank,&
+ ": BROADCAST time",time_bcast," REDUCE time",&
+ time_reduce," GATHER time",time_gather," SCATTER time",&
+ time_scatter,&
+ " SCATTER fmatmult",time_scatter_fmatmult,&
+ " SCATTER ginvmult",time_scatter_ginvmult,&
+ " SCATTER fmat",time_scatter_fmat,&
+ " SCATTER ginv",time_scatter_ginv,&
+ " SENDRECV",time_sendrecv,&
+ " BARRIER ene",time_barrier_e,&
+ " BARRIER GRAD",time_barrier_g,&
+ " BCAST7",time_bcast7," BCASTC",time_bcastc,&
+ " BCASTW",time_bcastw," ALLREDUCE",time_allreduce,&
+ " TOTAL",&
+ time_bcast+time_reduce+time_gather+time_scatter+ &
+ time_sendrecv+time_barrier+time_bcastc
+!el#endif
+ write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc
+ write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene
+ write (*,*) "Processor",fg_rank,myrank," intfromcart",&
+ time_intfcart
+ write (*,*) "Processor",fg_rank,myrank," vecandderiv",&
+ time_vec
+ write (*,*) "Processor",fg_rank,myrank," setmatrices",&
+ time_mat
+ write (*,*) "Processor",fg_rank,myrank," ginvmult",&
+ time_ginvmult
+ write (*,*) "Processor",fg_rank,myrank," fricmatmult",&
+ time_fricmatmult
+ write (*,*) "Processor",fg_rank,myrank," inttocart",&
+ time_inttocart
+ write (*,*) "Processor",fg_rank,myrank," sumgradient",&
+ time_sumgradient
+ write (*,*) "Processor",fg_rank,myrank," intcartderiv",&
+ time_intcartderiv
+ if (fg_rank.eq.0) then
+ write (*,*) "Processor",fg_rank,myrank," lagrangian",&
+ time_lagrangian
+ write (*,*) "Processor",fg_rank,myrank," cartgrad",&
+ time_cartgrad
+ endif
+ return
+ end subroutine print_detailed_timing
+#endif
+!-----------------------------------------------------------------------------
+!-----------------------------------------------------------------------------
+ end module control
projects / unres4.git / blobdiff