3 implicit real*8 (a-h,o-z)
7 include 'COMMON.CONTROL'
8 include 'COMMON.IOUNITS'
10 c real*8 text1 /'group_i '/,text2/'group_f '/,
11 c & text3/'initialb'/,text4/'initiale'/,
12 c & text5/'openb'/,text6/'opene'/
13 integer cgtasks(0:max_cg_procs)
15 integer cg_size,fg_size,fg_size1
16 c start parallel processing
17 c print *,'Initializing MPI'
20 print *, ' cannot initialize MPI'
23 c determine # of nodes and current node
24 call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr )
26 print *, ' cannot determine rank of all processes'
27 call MPI_Finalize( MPI_COMM_WORLD, IERR )
30 call MPI_Comm_size( MPI_Comm_world, nodes, ierr )
32 print *, ' cannot determine number of processes'
37 write (*,*) "nodes",nodes," rank",me
38 C Determine the number of "fine-grain" tasks
39 call getenv_loc("FGPROCS",cfgprocs)
40 read (cfgprocs,'(i3)') nfgtasks
41 if (nfgtasks.eq.0) nfgtasks=1
42 call getenv_loc("MAXGSPROCS",cfgprocs)
43 read (cfgprocs,'(i3)') max_gs_size
44 if (max_gs_size.eq.0) max_gs_size=2
46 & print *,"Processor",me," nfgtasks",nfgtasks,
47 & " max_gs_size",max_gs_size
48 if (nfgtasks.eq.1) then
49 CG_COMM = MPI_COMM_WORLD
56 if (nfgtasks*nodes.ne.nprocs) then
57 write (*,'(a)') 'ERROR: Number of processors assigned',
58 & ' to coarse-grained tasks must be divisor',
59 & ' of the total number of processors.'
60 call MPI_Finalize( MPI_COMM_WORLD, IERR )
63 C Put the ranks of coarse-grain processes in one table and create
64 C the respective communicator. The processes with ranks "in between"
65 C the ranks of CG processes will perform fine graining for the CG
66 C process with the next lower rank.
67 do i=0,nprocs-1,nfgtasks
71 print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1)
72 c print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group"
74 c call memmon_print_usage()
75 call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR)
76 call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR)
77 call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR)
78 call MPI_Group_rank(cg_group,me,ierr)
79 call MPI_Group_free(world_group,ierr)
80 call MPI_Group_free(cg_group,ierr)
81 c print "(a,i5,a)","Processor",myrank," After MPI_Comm_group"
82 c call memmon_print_usage()
83 if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr)
84 if (lprn) print *," Processor",myrank," CG rank",me
85 C Create communicators containig processes doing "fine grain" tasks.
86 C The processes within each FG_COMM should have fast communication.
88 key=mod(MyRank,nfgtasks)
89 call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr)
90 call MPI_Comm_size(FG_COMM,fg_size,ierr)
91 if (fg_size.ne.nfgtasks) then
92 write (*,*) "OOOOps... the number of fg tasks is",fg_size,
93 & " but",nfgtasks," was requested. MyRank=",MyRank
95 call MPI_Comm_rank(FG_COMM,fg_rank,ierr)
96 if (fg_size.gt.max_gs_size) then
97 kolor1=fg_rank/max_gs_size
98 key1=mod(fg_rank,max_gs_size)
99 call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr)
100 call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr)
101 call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr)
108 if (fg_rank.eq.0) then
109 write (*,*) "Processor",MyRank," out of",nprocs,
110 & " rank in CG_COMM",me," size of CG_COMM",nodes,
111 & " size of FG_COMM",fg_size,
112 & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
114 write (*,*) "Processor",MyRank," out of",nprocs,
115 & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size,
116 & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
118 C Initialize other variables.
119 c print '(a)','Before initialize'
120 c call memmon_print_usage()
122 c print '(a,i5,a)','Processor',myrank,' After initialize'
123 c call memmon_print_usage()
124 C Open task-dependent files.
125 c print '(a,i5,a)','Processor',myrank,' Before openunits'
126 c call memmon_print_usage()
128 c print '(a,i5,a)','Processor',myrank,' After openunits'
129 c call memmon_print_usage()
130 if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file)
131 & write (iout,'(80(1h*)/a/80(1h*))')
132 & 'United-residue force field calculation - parallel job.'
133 c print *,"Processor",myrank," exited OPENUNITS"
136 C-----------------------------------------------------------------------------
137 subroutine finish_task
138 implicit real*8 (a-h,o-z)
141 include 'COMMON.SETUP'
142 include 'COMMON.CONTROL'
143 include 'COMMON.REMD'
144 include 'COMMON.IOUNITS'
145 include 'COMMON.FFIELD'
146 include 'COMMON.TIME1'
151 call MPI_Barrier(CG_COMM,ierr)
153 & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR)
155 if (me.eq.king .or. .not. out1file) then
156 write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.'
157 write (iout,*) 'Total wall clock time',time1-walltime,' sec'
158 if (nfgtasks.gt.1) then
159 write (iout,'(80(1h=)/a/(80(1h=)))')
160 & "Details of FG communication time"
161 write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))')
162 & "BROADCAST:",time_bcast,"REDUCE:",time_reduce,
163 & "GATHER:",time_gather,
164 & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,
165 & "BARRIER ene",time_barrier_e,
166 & "BARRIER grad",time_barrier_g,"TOTAL:",
167 & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv
168 & +time_barrier_e+time_barrier_g
169 write (*,*) 'Total wall clock time',time1-walltime,' sec'
170 write (*,*) "Processor",me," BROADCAST time",time_bcast,
172 & time_reduce," GATHER time",time_gather," SCATTER time",
173 & time_scatter," SENDRECV",time_sendrecv,
174 & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g
177 write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.'
178 if (ilen(tmpdir).gt.0) then
179 write (*,*) "Processor",me,
180 & ": moving output files to the parent directory..."
182 close(istat,status='keep')
183 if (ntwe.gt.0) call move_from_tmp(statname)
184 close(irest2,status='keep')
185 if (modecalc.eq.12.or.
186 & (modecalc.eq.14 .and. .not.restart1file)) then
187 call move_from_tmp(rest2name)
188 else if (modecalc.eq.14.and. me.eq.king) then
189 call move_from_tmp(mremd_rst_name)
192 close(ipdb,status='keep')
193 call move_from_tmp(pdbname)
194 else if (me.eq.king .or. .not.traj1file) then
195 close(icart,status='keep')
196 call move_from_tmp(cartname)
198 if (me.eq.king .or. .not. out1file) then
199 close (iout,status='keep')
200 call move_from_tmp(outname)
205 c-------------------------------------------------------------------------
206 subroutine pattern_receive
207 implicit real*8 (a-h,o-z)
210 include 'COMMON.SETUP'
211 include 'COMMON.THREAD'
212 include 'COMMON.IOUNITS'
213 integer tag,status(MPI_STATUS_SIZE)
214 integer source,ThreadType
217 source=mpi_any_source
218 call mpi_iprobe(source,ThreadType,
219 & CG_COMM,flag,status,ierr)
221 write (iout,*) 'Processor ',Me,' is receiving threading',
222 & ' pattern from processor',status(mpi_source)
223 write (*,*) 'Processor ',Me,' is receiving threading',
224 & ' pattern from processor',status(mpi_source)
226 call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source),
227 & ThreadType, CG_COMM,ireq,ierr)
228 write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl),
230 source=mpi_any_source
231 call mpi_iprobe(source,ThreadType,
232 & CG_COMM,flag,status,ierr)
236 c----------------------------------------------------------------------------
237 subroutine pattern_send
238 implicit real*8 (a-h,o-z)
241 include 'COMMON.INFO'
242 include 'COMMON.THREAD'
243 include 'COMMON.IOUNITS'
244 integer source,ThreadType,ireq
247 if (iproc.ne.me .and. .not.Koniec(iproc) ) then
248 call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc,
249 & ThreadType, CG_COMM, ireq, ierr)
250 write (iout,*) 'CG processor ',me,' has sent pattern ',
251 & 'to processor',iproc
252 write (*,*) 'CG processor ',me,' has sent pattern ',
253 & 'to processor',iproc
254 write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl)
259 c-----------------------------------------------------------------------------
260 subroutine send_stop_sig(Kwita)
261 implicit real*8 (a-h,o-z)
264 include 'COMMON.INFO'
265 include 'COMMON.IOUNITS'
266 integer StopType,StopId,iproc,Kwita,NBytes
269 C print *,'CG processor',me,' StopType=',StopType
272 C Master sends the STOP signal to everybody.
274 & 'Master is sending STOP signal to other processors.'
276 print *,'Koniec(',iproc,')=',Koniec(iproc)
277 if (.not. Koniec(iproc)) then
278 call mpi_send(Kwita,1,mpi_integer,iproc,StopType,
279 & mpi_comm_world,ierr)
280 write (iout,*) 'Iproc=',iproc,' StopID=',StopID
281 write (*,*) 'Iproc=',iproc,' StopID=',StopID
285 C Else send the STOP signal to Master.
286 call mpi_send(Kwita,1,mpi_integer,MasterID,StopType,
287 & mpi_comm_world,ierr)
288 write (iout,*) 'CG processor=',me,' StopID=',StopID
289 write (*,*) 'CG processor=',me,' StopID=',StopID
293 c-----------------------------------------------------------------------------
294 subroutine recv_stop_sig(Kwita)
295 implicit real*8 (a-h,o-z)
298 include 'COMMON.INFO'
299 include 'COMMON.IOUNITS'
300 integer source,StopType,StopId,iproc,Kwita
304 source=mpi_any_source
305 c print *,'CG processor:',me,' StopType=',StopType
306 call mpi_iprobe(source,StopType,
307 & mpi_comm_world,flag,status,ierr)
309 Koniec(status(mpi_source))=.true.
310 write (iout,*) 'CG processor ',me,' is receiving STOP signal',
311 & ' from processor',status(mpi_source)
312 write (*,*) 'CG processor ',me,' is receiving STOP signal',
313 & ' from processor',status(mpi_source)
314 call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType,
315 & mpi_comm_world,ireq,ierr)
316 call mpi_iprobe(source,StopType,
317 & mpi_comm_world,flag,status,ierr)
321 c-----------------------------------------------------------------------------
322 subroutine send_MCM_info(ione)
323 implicit real*8 (a-h,o-z)
326 include 'COMMON.SETUP'
328 include 'COMMON.IOUNITS'
329 integer tag,status(MPI_STATUS_SIZE)
330 integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes
331 common /aaaa/ isend,irecv
336 cd write (iout,'(a,i4,a)') 'CG Processor',me,
337 cd & ' is sending MCM info to Master.'
338 write (*,'(a,i4,a,i8)') 'CG processor',me,
339 & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID
340 call mpi_isend(ione,1,mpi_integer,MasterID,
341 & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr)
342 cd write (iout,*) 'CG processor',me,' has sent info to the master;',
343 cd & ' MCM_info_ID=',MCM_info_ID
344 write (*,*) 'CG processor',me,' has sent info to the master;',
345 & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr
350 c----------------------------------------------------------------------------
351 subroutine receive_MCM_info
352 implicit real*8 (a-h,o-z)
355 include 'COMMON.SETUP'
357 include 'COMMON.IOUNITS'
358 integer tag,status(MPI_STATUS_SIZE)
359 integer source,MCM_info_Type,MCM_info_ID,iproc,ione
362 source=mpi_any_source
363 c print *,'source=',source,' dontcare=',dontcare
364 call mpi_iprobe(source,MCM_info_Type,
365 & mpi_comm_world,flag,status,ierr)
367 source=status(mpi_source)
368 itask=source/fgProcs+1
369 cd write (iout,*) 'Master is receiving MCM info from processor ',
370 cd & source,' itask',itask
371 write (*,*) 'Master is receiving MCM info from processor ',
372 & source,' itask',itask
373 call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type,
374 & mpi_comm_world,MCM_info_ID,ierr)
375 cd write (iout,*) 'Received from processor',source,' IONE=',ione
376 write (*,*) 'Received from processor',source,' IONE=',ione
378 if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1
379 cd print *,'nsave_part(',itask,')=',nsave_part(itask)
380 cd write (iout,*) 'Nacc_tot=',Nacc_tot
381 cd write (*,*) 'Nacc_tot=',Nacc_tot
382 source=mpi_any_source
383 call mpi_iprobe(source,MCM_info_Type,
384 & mpi_comm_world,flag,status,ierr)
388 c---------------------------------------------------------------------------
389 subroutine send_thread_results
390 implicit real*8 (a-h,o-z)
393 include 'COMMON.SETUP'
394 include 'COMMON.THREAD'
395 include 'COMMON.IOUNITS'
396 integer tag,status(MPI_STATUS_SIZE)
397 integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
398 & EnerID,msglen,nbytes
399 double precision buffer(20*maxthread+2)
402 ipatt(1,nthread+1)=nthread
403 ipatt(2,nthread+1)=nexcl
406 ener(j,i+nthread)=ener0(j,i)
409 ener(1,2*nthread+1)=max_time_for_thread
410 ener(2,2*nthread+1)=ave_time_for_thread
411 C Send the IPATT array
412 write (iout,*) 'CG processor',me,
413 & ' is sending IPATT array to master: NTHREAD=',nthread
414 write (*,*) 'CG processor',me,
415 & ' is sending IPATT array to master: NTHREAD=',nthread
417 call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID,
418 & ThreadType,mpi_comm_world,ierror)
419 write (iout,*) 'CG processor',me,
420 & ' has sent IPATT array to master MSGLEN',msglen
421 write (*,*) 'CG processor',me,
422 & ' has sent IPATT array to master MSGLEN',msglen
424 msglen=n_ene2*nthread+2
425 write (iout,*) 'CG processor',me,' is sending energies to master.'
426 write (*,*) 'CG processor',me,' is sending energies to master.'
427 call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID,
428 & EnerType,mpi_comm_world,ierror)
429 write (iout,*) 'CG processor',me,' has sent energies to master.'
430 write (*,*) 'CG processor',me,' has sent energies to master.'
433 c----------------------------------------------------------------------------
434 subroutine receive_thread_results(iproc)
435 implicit real*8 (a-h,o-z)
438 include 'COMMON.INFO'
439 include 'COMMON.THREAD'
440 include 'COMMON.IOUNITS'
441 integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
442 & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp
443 double precision buffer(20*maxthread+2),max_time_for_thread_t,
444 & ave_time_for_thread_t
448 C Receive the IPATT array
449 call mpi_probe(iproc,ThreadType,
450 & mpi_comm_world,status,ierr)
451 call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR)
452 write (iout,*) 'Master is receiving IPATT array from processor:',
453 & iproc,' MSGLEN',msglen
454 write (*,*) 'Master is receiving IPATT array from processor:',
455 & iproc,' MSGLEN',msglen
456 call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc,
458 & mpi_comm_world,status,ierror)
459 write (iout,*) 'Master has received IPATT array from processor:',
460 & iproc,' MSGLEN=',msglen
461 write (*,*) 'Master has received IPATT array from processor:',
462 & iproc,' MSGLEN=',msglen
463 nthread_temp=ipatt(1,nthread+msglen/2)
464 nexcl_temp=ipatt(2,nthread+msglen/2)
465 C Receive the energies.
466 call mpi_probe(iproc,EnerType,
467 & mpi_comm_world,status,ierr)
468 call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR)
469 write (iout,*) 'Master is receiving energies from processor:',
470 & iproc,' MSGLEN=',MSGLEN
471 write (*,*) 'Master is receiving energies from processor:',
472 & iproc,' MSGLEN=',MSGLEN
473 call mpi_recv(ener(1,nthread+1),msglen,
474 & MPI_DOUBLE_PRECISION,iproc,
475 & EnerType,MPI_COMM_WORLD,status,ierror)
476 write (iout,*) 'Msglen=',Msglen
477 write (*,*) 'Msglen=',Msglen
478 write (iout,*) 'Master has received energies from processor',iproc
479 write (*,*) 'Master has received energies from processor',iproc
480 write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
481 write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
484 ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i)
487 max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1)
488 ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1)
489 write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
490 write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
491 write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
492 write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
493 if (max_time_for_thread_t.gt.max_time_for_thread)
494 & max_time_for_thread=max_time_for_thread_t
495 ave_time_for_thread=(nthread*ave_time_for_thread+
496 & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp)
497 nthread=nthread+nthread_temp
502 implicit real*8 (a-h,o-z)
504 include 'COMMON.SETUP'
513 write (iout,'(80(1h*)/a/80(1h*))')
514 & 'United-residue force field calculation - serial job.'