Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mph.F90 @ 6331

Last change on this file since 6331 was 6331, checked in by aclsce, 17 months ago
Moved oasis-mct_5.0 in oasis3-mct/branches directory.
File size: 33.3 KB

Line
1	!-----------------------------------------------------------------------
2	! CVS $Id: mph.F90,v 1.3 2006-10-03 22:43:29 jacob Exp $
3	! CVS $Name: $
4	! =============================================================
5	! Multi Program-Components Handshaking (MPH) Utility
6
7	! This is a small utility of global handshaking among different component
8	! models. Each component will run on a set of nodes or processors.
9	! Different components could run either on different set of nodes, or
10	! on set of nodes that overlap.
11
12	! There are three seperate implementations:
13	! 1. Multiple Components, Multiple Executables, components non-overlap
14	! 2. Multiple Components, Single Executable, components non-overlap
15	! 3. Multiple Components, Single Executable, components overlap, flexible
16
17	! This is a combined module for all the above.
18	! The user only has to "use MPH_all" in their application codes.
19	! You may need to use MPH_help to understand the required information
20	! for setup, input file and inquiry functions.
21
22	! Written by Yun He and Chris Ding, NERSC/LBL, January 2001.
23
24
25	!==============================================================
26	! common data used by all three versions of MPH
27	!==============================================================
28
29	module comm_data123
30
31	use m_mpif
32	implicit none
33
34	integer istatus(MPI_STATUS_SIZE), ierr
35	integer max_num_comps, maxProcs_comp
36	parameter (max_num_comps=20) ! maximum number of components
37	parameter (maxProcs_comp=128) ! maximum number of procs per comps
38
39	type Acomponent
40	character*16 name ! component name
41	integer num_process ! number of processors
42	integer process_list(maxProcs_comp)
43	! global processor_id, increasing order
44	end type Acomponent
45
46	type (Acomponent) components(max_num_comps) ! allocate components
47	integer MPI_Acomponent
48
49	integer global_proc_id ! proc id in the whole world
50	integer global_totProcs ! total # of procs for the whole world
51	integer COMM_master ! communicator for submaster of each component
52
53	integer total_components
54	character*16 component_names(max_num_comps)
55
56	! for timer
57	integer N_CHANNELS
58	parameter (N_CHANNELS=10)
59	real (kind=8) :: init_time = -1.0
60	real (kind=8) :: last_time, tot_time(0:N_CHANNELS)
61
62	end module comm_data123
63
64	!===============================================================
65	! common data shared by MPH_Multi_Exec and MPH_Single_Exec
66	!===============================================================
67
68	module comm_data12
69	use comm_data123
70	integer component_id
71	integer local_world ! communicator for this component
72	integer local_proc_id ! proc id in this component
73	integer local_totProcs ! total # of procs for this component
74	end module comm_data12
75
76	!==================================================================
77	! common subroutines used by all three versions of MPH
78	!==================================================================
79
80	module comm_sub123
81	use comm_data123
82	contains
83
84	!--------------- subroutine MPH_init () ------------
85
86	subroutine MPH_init ()
87	implicit none
88
89	integer iblock(3), idisp(3), itype(3)
90
91	call MPI_COMM_RANK (MPI_COMM_WORLD, global_proc_id, ierr)
92	call MPI_COMM_SIZE (MPI_COMM_WORLD, global_totProcs, ierr)
93
94	! create a new MPI data type MPI_Acomponent
95
96	iblock(1) = 16
97	iblock(2) = 1
98	iblock(3) = maxProcs_comp
99	idisp(1) = 0
100	idisp(2) = 16
101	idisp(3) = 20
102	itype(1) = MPI_CHARACTER
103	itype(2) = MPI_INTEGER
104	itype(3) = MPI_INTEGER
105	call MPI_TYPE_STRUCT (3,iblock,idisp,itype,MPI_Acomponent,ierr)
106	call MPI_TYPE_COMMIT (MPI_Acomponent, ierr)
107
108	end subroutine MPH_init
109
110
111	!--------- subroutine MPH_global_id (name, local_id) ----------
112
113	integer function MPH_global_id (name, local_id)
114	implicit none
115
116	character() name
117	integer local_id, temp
118
119	! then find out the component rank
120	temp = MPH_find_name (name, component_names, total_components)
121
122	! process_list starts from 1, while proc rank starts from 0
123	MPH_global_id = components(temp) % process_list(local_id+1)
124
125	end function MPH_global_id
126
127
128	!------ integer function MPH_find_name(name, namelist, num) ------
129
130	integer function MPH_find_name(name, namelist, num)
131	implicit none
132
133	! find name in component_names
134	character() name
135	integer i, num
136	character*16 namelist(num)
137
138	do i = 1, num
139	if (name == namelist(i)) then
140	! print *, i, name, namelist(i)
141	goto 100
142	endif
143	enddo
144
145	! name is not found
146	MPH_find_name = -1
147	print *, "ERROR: ", name, " not found in components.in"
148	stop
149
150	100 MPH_find_name = i
151	return
152	end function MPH_find_name
153
154
155	!---------- subroutine MPH_redirect_output (name) ---------
156
157	subroutine MPH_redirect_output (name)
158	character() name
159	integer lenname, lenval, rcode
160	character*16 output_name_env
161	character*64 output_name, temp_value
162
163	output_name = ' '
164	output_name_env = trim (name) // "_out_env"
165
166	#if (defined AIX)
167	call getenv (trim(output_name_env), temp_value)
168	output_name = trim (temp_value)
169	if (len_trim(output_name) == 0) then
170	write(,)'output file names not preset by env varibales'
171	write(,)'so output not redirected'
172	else
173	open (unit=6, file=output_name, position='append')
174	call flush_(6)
175	endif
176	#endif
177
178	#if (defined SUPERUX)
179	call getenv (trim(output_name_env), temp_value)
180	output_name = trim (temp_value)
181	if (len_trim(output_name) == 0) then
182	write(,)'output file names not preset by env varibales'
183	write(,)'so output not redirected'
184	else
185	open (unit=6, file=output_name, position='append')
186	call flush(6)
187	endif
188	#endif
189
190	#if (defined IRIX64 \|\| defined CRAY \|\| defined sn6711)
191	lenname = len_trim (output_name_env)
192	call pxfgetenv (output_name_env,lenname,output_name,lenval,rcode)
193	if (len_trim(output_name) == 0) then
194	write(,)'output file names not preset by env varibales'
195	write(,)'so output not redirected'
196	else
197	open (unit=6, file=output_name, position='append')
198	call flush(6)
199	endif
200	#endif
201
202	#if (!defined AIX && !defined IRIX64 && !defined CRAY && !defined sn6711 && !defined SUPERUX)
203	write(,) 'No implementation for this architecture'
204	write(,) 'output redirect is not performed by getenv'
205	#endif
206
207	end subroutine MPH_redirect_output
208
209
210	!----------- subroutine MPH_help (arg) --------------
211
212	subroutine MPH_help (arg)
213	implicit none
214
215	character() arg
216	write(,)'Message from MPH_help:'
217
218	if (arg .eq. 'off') then
219	write(,)'off'
220
221	else if (arg .eq. 'Multi_Exec') then
222	write(,)'Multiple executables'
223	write(,)'Required setup function for pop is: '
224	write(,)' call MPH_setup_ME ("ocean", POP_World)'
225	write(,)'Required input file is "components.in"'
226
227	write(,)'Subroutine call to join two communicators is:'
228	write(,)' MPH_comm_join_ME_SE(name1,name2,comm_joined)'
229
230	write(,)'Available inquiry functions are:'
231	write(,)' character*16 MPH_component_name(id)'
232	write(,)' integer MPH_get_component_id(name)'
233	write(,)' integer MPH_total_components()'
234	write(,)' integer MPH_global_proc_id()'
235	write(,)' character*16 MPH_myName_ME_SE()'
236	write(,)' integer MPH_component_id_ME_SE()'
237	write(,)' integer MPH_local_proc_id_ME_SE()'
238	write(,)' integer MPH_local_world_ME_SE()'
239
240	else if (arg .eq. 'Single_Exec') then
241	write(,)'Single executable, processors non-overlap'
242	write(,)'Required setup function is: '
243	write(,)' call MPH_setup_SE (atmosphere=ccm3_8,&
244	& ocean=pop2_2, coupler=cpl5_1)'
245	write(,)'Required input file is "processors_map.in"'
246
247	write(,)'Subroutine call to join two communicators is:'
248	write(,)' MPH_comm_join_ME_SE(name1,name2,comm_joined)'
249
250	write(,)'Available inquiry functions are:'
251	write(,)' character*16 MPH_component_name(id)'
252	write(,)' integer MPH_get_component_id(name)'
253	write(,)' integer MPH_total_components()'
254	write(,)' integer MPH_global_proc_id()'
255	write(,)' character*16 MPH_myName_ME_SE()'
256	write(,)' integer MPH_component_id_ME_SE()'
257	write(,)' integer MPH_local_proc_id_ME_SE()'
258	write(,)' integer MPH_local_world_ME_SE()'
259	write(,)' integer MPH_low_proc_limit(id)'
260	write(,)' integer MPH_up_proc_limit(id)'
261
262	else if (arg .eq. 'Single_Exec_Overlap') then
263	write(,)'Single executable, processors overlap'
264	write(,)'Required setup function is: '
265	write(,)' call MPH_setup_SE_overlap ("atmosphere",&
266	& "ocean", "coupler")'
267	write(,)'Required input file is "processors_map.in"'
268
269	write(,)'Subroutine call to join two communicators is:'
270	write(,)' MPH_comm_join_SE_overlap (name1, name2,&
271	& comm_joined)'
272
273	write(,)'Available inquiry functions are:'
274	write(,)' character*16 MPH_component_name(id)'
275	write(,)' integer MPH_get_component_id(name)'
276	write(,)' integer MPH_total_components()'
277	write(,)' integer MPH_global_proc_id()'
278	write(,)' integer MPH_local_proc_id_SE_overlap(id)'
279	write(,)' integer MPH_local_world_SE_overlap(id)'
280	write(,)' integer MPH_low_proc_limit(id)'
281	write(,)' integer MPH_up_proc_limit(id)'
282
283	else
284	write(,)'wrong argument for MPH_help'
285	endif
286
287	end subroutine MPH_help
288
289
290	!----------- function MPH_timer (flag, channel) ------------
291
292	! Usage:
293
294	! channel 0 is the default channel, using init_time.
295
296	! ---------------------------------------------------------
297	! timer calls to walk-clock dclock(), and do the following:
298	! ---------------------------------------------------------
299	! flag=0 : Sets initial time; init all channels.
300	!
301	! flag =1 : Calculates the most recent time interval; accure it to the
302	! specified channel;
303	! Returns it to calling process.
304	! Channel 0 is the default channel, which is automatically accrued.
305
306	! flag =2 : Calculates the most recent time interval; accure it to the
307	! specified channel;
308	! Returns the curent total time in the specified channel;
309	! Channel 0 is the default channel, which is automatically accrued.
310	! ---------------------------------------------------------
311
312	real (kind=8) function MPH_timer (flag, channel)
313	integer flag, channel
314	real (kind=8) :: new_time, delta_time, MPI_Wtime
315
316	new_time = MPI_Wtime()
317
318	if (flag == 0) then
319	init_time = new_time
320	last_time = new_time
321	tot_time = 0.0
322	MPH_timer = new_time - init_time
323	else if (init_time == -1.0) then
324	! Error Condition
325	MPH_timer = init_time
326	endif
327
328	! Timer is initialized and flag != 0
329
330	delta_time = new_time - last_time
331	last_time = new_time
332
333	! For channel=0 or other undefined channels which is treated as 0
334	if ( channel < 0 .or. channel > N_CHANNELS) then
335	write(,) 'Timer channel is not properly specified!'
336	endif
337
338	! channel != 0
339
340	if (flag == 1) then
341	tot_time(channel) = tot_time(channel) + delta_time
342	MPH_timer = delta_time
343	else if (flag == 2) then
344	tot_time(channel) = tot_time(channel) + delta_time
345	MPH_timer = tot_time(channel)
346	else
347	! Error Condition
348	MPH_timer = -1.0
349	endif
350
351	end function MPH_timer
352
353
354	!-------- common inquiry functions for MPH1, MPH2 and MPH3 -------
355
356	character*16 function MPH_component_name(id)
357	integer id
358	MPH_component_name = component_names (id)
359	end function MPH_component_name
360
361	integer function MPH_get_component_id(name)
362	character() name
363	MPH_get_component_id = MPH_find_name (name, component_names,&
364	total_components)
365	end function MPH_get_component_id
366
367	integer function MPH_total_components()
368	MPH_total_components = total_components
369	end function MPH_total_components
370
371	integer function MPH_global_proc_id()
372	MPH_global_proc_id = global_proc_id
373	end function MPH_global_proc_id
374
375	end module comm_sub123
376
377
378	! ===============================================================
379	! common subroutines used by MPH_Multi_Exec and MPH_Single_Exec
380	! ===============================================================
381
382	module comm_sub12
383	use comm_data123
384	use comm_data12
385	use comm_sub123
386
387	contains
388
389	!--------------- subroutine MPH_global_ME_SE () ------------
390
391	! global hand-shaking among root processors of each component.
392
393	subroutine MPH_global_ME_SE ()
394	implicit none
395	integer sendtag, recvtag, i, color, key
396	type(Acomponent) sendbuf
397
398	! create a MPI communicator COMM_master for all submasters
399	! arrange the rank of the submasters in COMM_master by their component_id
400	! i.e., their rank of the component model in "components.in"
401	if (local_proc_id == 0) then
402	color = 1
403	else
404	color = 2
405	endif
406	key = component_id
407	call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,COMM_master,ierr)
408
409	! gather Acomponents to 0th proc in COMM_master
410	if (local_proc_id == 0) then
411	! cannot send and recv from same buffer anymore
412	! copy sendbuf local variable
413	sendbuf = components(component_id)
414	call MPI_GATHER (sendbuf, 1, MPI_Acomponent,&
415	components, 1, MPI_Acomponent,&
416	0, COMM_master, ierr)
417
418	! 0th proc in COMM_master broadcast Acomponents to all submasters
419	call MPI_BCAST (components, total_components,&
420	MPI_Acomponent, 0, COMM_master, ierr)
421	endif
422
423	! submaster broadcast AComponents to all process in the components
424	call MPI_BCAST (components, total_components,&
425	MPI_Acomponent, 0, local_world, ierr)
426
427	! everybody lists the complete info
428	! write(,)'I am proc ', local_proc_id, ' in ',
429	! & component_names(component_id), ' , which is proc ',
430	! & global_proc_id, ' in global_world'
431	! write(,)'infos I have for all proc of all components are:'
432	! do i = 1, total_components
433	! write(,)' ', components(i)%name
434	! write(,)' ', components(i)%num_process
435	! write(,)' ', components(i)%process_list(1:8) ! partial list
436	! enddo
437
438	end subroutine MPH_global_ME_SE
439
440
441	!------- subroutine MPH_comm_join_ME_SE (name1, name2, comm_joined) ---
442
443	subroutine MPH_comm_join_ME_SE (name1, name2, comm_joined)
444	implicit none
445
446	character() name1, name2
447	integer temp1, temp2
448	integer comm_joined, color, key
449
450	temp1 = MPH_find_name(name1,component_names,total_components)
451	temp2 = MPH_find_name(name2,component_names,total_components)
452
453	! the order of two components does matter: first one has lower ranks in
454	! the new joined communicator, and second one has higher ranks.
455
456	if (component_id==temp1 .or. component_id==temp2) then
457	color = 1
458	if (component_id == temp1) then
459	key = local_proc_id
460	else
461	key = global_totProcs + local_proc_id
462	endif
463	else
464	color = 2
465	key = 0
466	endif
467
468	call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,comm_joined,ierr)
469
470	end subroutine MPH_comm_join_ME_SE
471
472
473	!-------- common inquiry functions for MPH1 and MPH2 ---------
474
475	character*16 function MPH_myName_ME_SE()
476	MPH_myName_ME_SE = component_names (component_id)
477	end function MPH_myName_ME_SE
478
479	integer function MPH_component_id_ME_SE()
480	MPH_component_id_ME_SE = component_id
481	end function MPH_component_id_ME_SE
482
483	integer function MPH_local_proc_id_ME_SE()
484	MPH_local_proc_id_ME_SE = local_proc_id
485	end function MPH_local_proc_id_ME_SE
486
487	integer function MPH_local_world_ME_SE()
488	MPH_local_world_ME_SE = local_world
489	end function MPH_local_world_ME_SE
490
491	end module comm_sub12
492
493
494	! ==============================================================
495	! module MPH_Multi_Exec
496	! ==============================================================
497
498	! Multi-Process Handshaking utility
499	! to facilitate a plug & play style programming on
500	! using multiple component executables.
501
502	module MPH_Multi_Exec
503	use comm_data123
504	use comm_data12
505	use comm_sub123
506	use comm_sub12
507	character*16 myName
508
509	contains
510
511	!------------- subroutine MPH_setup_ME (name, comm_world) ---------
512
513	subroutine MPH_setup_ME (name, comm_world)
514	implicit none
515
516	character() name
517	integer comm_world
518
519	myName = name
520	call MPH_init ()
521	call MPH_local_ME ()
522	call MPH_global_ME_SE ()
523	call MPI_COMM_DUP (local_world, comm_world, ierr)
524
525	end subroutine MPH_setup_ME
526
527
528	!--------------- subroutine MPH_local_ME () ------------
529
530	! local hand-shaking
531
532	subroutine MPH_local_ME ()
533	implicit none
534	integer key
535
536	total_components = MPH_read_list_ME("components.in",&
537	"COMPONENT_LIST", component_names, max_num_comps)
538
539	component_id = MPH_find_name (myName, component_names,&
540	total_components)
541	key = 0
542	call MPI_COMM_SPLIT (MPI_COMM_WORLD, component_id, key,&
543	local_world,ierr)
544
545	! setup local_world, local_proc_id, local_totProcs
546	call MPI_COMM_RANK (local_world, local_proc_id, ierr)
547	call MPI_COMM_SIZE (local_world, local_totProcs, ierr)
548
549	components(component_id)%name = myName
550	components(component_id)%num_process = local_totProcs
551
552	! gather processor ids to 0th proc in this component.
553	call MPI_GATHER (global_proc_id, 1, MPI_INTEGER,&
554	components(component_id)%process_list,&
555	1, MPI_INTEGER, 0, local_world, ierr)
556
557	end subroutine MPH_local_ME
558
559
560	!--- function MPH_read_list_ME(filename, filetag, namelist, num) ---
561
562	integer function MPH_read_list_ME(filename,filetag,namelist,num)
563	implicit none
564	integer i, num
565	character() filename, filetag
566	character*16 namelist(num), firstline, temp
567
568	open(10, file=filename, status='unknown')
569	read(10, '(a16)', end=200) firstline
570	if (firstline .ne. filetag) then
571	print *, 'ERROR: filetag inconsistent', filename
572	print *, 'ERROR: ', filetag, '!=', firstline
573	stop
574	endif
575
576	read(10, '(a16)', end=200) temp
577	if (temp .ne. 'BEGIN') then
578	print *, 'ERROR: no BEGIN in ', filename
579	stop
580	endif
581
582	do i = 1, num
583	read(10, '(a16)', end=100) temp
584	if (temp .ne. 'END') then
585	namelist(i) = temp
586	else
587	goto 200
588	endif
589	enddo
590
591	100 print *, 'ERROR: no END in ', filename
592	stop
593
594	200 MPH_read_list_ME = i - 1
595	close(10)
596
597	return
598	end function MPH_read_list_ME
599
600	end module MPH_Multi_Exec
601
602
603	! ==============================================================
604	! module MPH_Single_Exec
605	! ==============================================================
606
607	! Multi-Process Handshaking utility
608	! to facilitate a plug & play style programming using single executable.
609	! each processor only execute one component model once.
610
611	module MPH_Single_Exec
612	use comm_data123
613	use comm_data12
614	use comm_sub123
615	use comm_sub12
616	integer low_proc_limit(max_num_comps)
617	integer up_proc_limit(max_num_comps)
618
619	contains
620
621
622	!---- subroutine MPH_setup_SE (atmosphere, ocean, coupler, land) ------
623
624	subroutine MPH_setup_SE (atmosphere, ocean, coupler, land,&
625	ice, biosphere, io)
626	implicit none
627
628	optional atmosphere, ocean, coupler, land, ice, biosphere, io
629	external atmosphere, ocean, coupler, land, ice, biosphere, io
630	integer id
631
632	call MPH_init ()
633
634	total_components = MPH_read_list_SE ("processors_map.in",&
635	"PROCESSORS_MAP", component_names,&
636	low_proc_limit, up_proc_limit, max_num_comps)
637
638	if (present(atmosphere)) then
639	id=MPH_find_name("atmosphere",component_names,total_components)
640	if (low_proc_limit(id) .le. global_proc_id .and.&
641	global_proc_id .le. up_proc_limit(id)) then
642	call MPH_local_SE (id)
643	call MPH_global_ME_SE ()
644	call atmosphere (local_world)
645	endif
646	endif
647
648	if (present(ocean)) then
649	id=MPH_find_name("ocean",component_names,total_components)
650	if (low_proc_limit(id) .le. global_proc_id .and.&
651	global_proc_id .le. up_proc_limit(id)) then
652	call MPH_local_SE (id)
653	call MPH_global_ME_SE ()
654	call ocean (local_world)
655	endif
656	endif
657
658	if (present(coupler)) then
659	id=MPH_find_name("coupler",component_names,total_components)
660	if (low_proc_limit(id) .le. global_proc_id .and.&
661	global_proc_id .le. up_proc_limit(id)) then
662	call MPH_local_SE (id)
663	call MPH_global_ME_SE ()
664	call coupler (local_world)
665	endif
666	endif
667
668	! add more component models as follows:
669	if (present(land)) then
670	id=MPH_find_name("land",component_names,total_components)
671	if (low_proc_limit(id) .le. global_proc_id .and.&
672	global_proc_id .le. up_proc_limit(id)) then
673	call MPH_local_SE (id)
674	call MPH_global_ME_SE ()
675	call land (local_world)
676	endif
677	endif
678
679	if (present(ice)) then
680	id=MPH_find_name("ice",component_names,total_components)
681	if (low_proc_limit(id) .le. global_proc_id .and.&
682	global_proc_id .le. up_proc_limit(id)) then
683	call MPH_local_SE (id)
684	call MPH_global_ME_SE ()
685	call ice (local_world)
686	endif
687	endif
688
689	if (present(biosphere)) then
690	id=MPH_find_name("biosphere",component_names,total_components)
691	if (low_proc_limit(id) .le. global_proc_id .and.&
692	global_proc_id .le. up_proc_limit(id)) then
693	call MPH_local_SE (id)
694	call MPH_global_ME_SE ()
695	call biosphere (local_world)
696	endif
697	endif
698
699	if (present(io)) then
700	id=MPH_find_name("io",component_names,total_components)
701	if (low_proc_limit(id) .le. global_proc_id .and.&
702	global_proc_id .le. up_proc_limit(id)) then
703	call MPH_local_SE (id)
704	call MPH_global_ME_SE ()
705	call io (local_world)
706	endif
707	endif
708
709	end subroutine MPH_setup_SE
710
711
712	!--------------- subroutine MPH_local_SE (id) ------------
713
714	! local hand-shaking
715
716	subroutine MPH_local_SE (id)
717	implicit none
718	integer id, key
719
720	component_id = id
721	key = 0
722	call MPI_COMM_SPLIT (MPI_COMM_WORLD, component_id,&
723	key, local_World, ierr)
724
725	! setup local_world, local_proc_id, local_totProcs
726	call MPI_COMM_RANK (local_world, local_proc_id, ierr)
727	call MPI_COMM_SIZE (local_world, local_totProcs, ierr)
728
729	components(component_id)%name = component_names(component_id)
730	components(component_id)%num_process = local_totProcs
731
732	! gather processor ids to 0th proc in this component.
733	call MPI_GATHER (global_proc_id, 1, MPI_INTEGER,&
734	components(component_id)%process_list, 1,&
735	MPI_INTEGER, 0, local_world, ierr)
736
737	end subroutine MPH_local_SE
738
739
740	!---- function MPH_read_list_SE (filename, filetag, namelist,
741	!---- low, up, num) --------
742
743	integer function MPH_read_list_SE (filename, filetag,&
744	namelist, low, up, num)
745	implicit none
746	integer i, num
747	character() filename, filetag
748	character*16 namelist(num), firstline, temp
749	integer itemp1, itemp2
750	integer low(num), up(num)
751
752	open(10, file=filename, status='unknown')
753	read(10, *, end=100) firstline
754	if (firstline .ne. filetag) then
755	print *, 'ERROR: filetag inconsistent', filename
756	print *, 'ERROR: ', filetag, '!=', firstline
757	stop
758	endif
759
760	read(10, *, end=200) temp
761	if (temp .ne. "BEGIN") then
762	print *, 'ERROR: no BEGIN in ', filename
763	stop
764	endif
765
766	do i = 1, num
767	read(10, *, err=300, end=400) temp, itemp1, itemp2
768	if (temp .eq. "END") goto 500
769	namelist(i) = temp
770	low(i) = itemp1
771	up(i) = itemp2
772	enddo
773
774	100 print *, 'ERROR: no filetag in ', filename
775	stop
776
777	200 print *, 'ERROR: no BEGIN in ', filename
778	stop
779
780	300 if (temp .eq. "END") then
781	goto 500
782	else
783	print *, 'ERROR: either: no END in ', filename
784	print *, ' or: does not provide correct format as'
785	print *, ' in input example: ocean 11 18'
786	stop
787	endif
788
789	400 print *, 'ERROR: no END in ', filename
790	stop
791
792	500 MPH_read_list_SE = i - 1
793	close(10)
794
795	return
796	end function MPH_read_list_SE
797
798
799	!---- the following two functions are common for MPH2 and MPH3 -------
800
801	integer function MPH_low_proc_limit(id)
802	integer id
803	MPH_low_proc_limit = low_proc_limit(id)
804	end function MPH_low_proc_limit
805
806	integer function MPH_up_proc_limit(id)
807	integer id
808	MPH_up_proc_limit = up_proc_limit(id)
809	end function MPH_up_proc_limit
810
811	end module MPH_Single_Exec
812
813
814	! ==============================================================
815	! module MPH_Single_Exec_Overlap
816	! ==============================================================
817
818	! Multi-Process Handshaking utility
819	! to facilitate a plug & play style programming using single executable.
820	! each processor could execute more than one component model (processor
821	! overlap) in any flexible way (any order).
822
823
824	module MPH_Single_Exec_Overlap
825	use comm_data123
826	use comm_sub123
827
828	integer local_world(max_num_comps) ! communicator for this component
829	integer local_proc_id(max_num_comps) ! proc id in this component
830	integer local_totProcs(max_num_comps) ! total procs for this component
831	integer low_proc_limit(max_num_comps)
832	integer up_proc_limit(max_num_comps)
833
834	contains
835
836	!---- subroutine MPH_setup_SE_overlap (model1, model2, ...) ------
837
838	subroutine MPH_setup_SE_overlap (model1, model2, model3, model4,&
839	model5, model6, model7, model8, model9, model10)
840	implicit none
841
842	character() model1, model2, model3, model4, model5
843	character() model6, model7, model8, model9, model10
844	optional model1, model2, model3, model4, model5
845	optional model6, model7, model8, model9, model10
846
847	integer id, i
848
849	call MPH_init ()
850	call MPH_local_SE_overlap ()
851	call MPH_global_SE_overlap ()
852
853	end subroutine MPH_setup_SE_overlap
854
855
856	!--------------- subroutine MPH_local_SE_overlap () ------------
857
858	subroutine MPH_local_SE_overlap ()
859	implicit none
860	integer id, color, key
861
862	total_components=MPH_read_list_SE_overlap("processors_map.in",&
863	"PROCESSORS_MAP", component_names,&
864	low_proc_limit, up_proc_limit, max_num_comps,&
865	local_totProcs)
866
867	! setup local_world, local_proc_id, local_totProcs
868	do id = 1, total_components
869	if (low_proc_limit(id) .le. global_proc_id .and.&
870	global_proc_id .le. up_proc_limit(id)) then
871	color = 1
872	else
873	color = 2
874	endif
875	key = 0
876	call MPI_COMM_SPLIT (MPI_COMM_WORLD, color, key,&
877	local_World(id), ierr)
878	call MPI_COMM_RANK(local_world(id),local_proc_id(id),ierr)
879	enddo
880
881	end subroutine MPH_local_SE_overlap
882
883
884	!--------------- subroutine MPH_global_SE_overlap () ------------
885
886	subroutine MPH_global_SE_overlap()
887	implicit none
888	integer id, i
889
890	! record Acomponent for each component
891	do id = 1, total_components
892	components(id)%name = component_names(id)
893	components(id)%num_process = local_totProcs(id)
894	do i = low_proc_limit(id), up_proc_limit(id)
895	components(id)%process_list(i-low_proc_limit(id)+1)=i
896	enddo
897	enddo
898
899	! everybody lists the complete info
900	do id = 1, total_components
901	if (low_proc_limit(id) .le. global_proc_id .and.&
902	global_proc_id .le. up_proc_limit(id)) then
903	write(,)'I am proc ', local_proc_id(id), ' in ',&
904	component_names(id), ' , which is proc ',&
905	global_proc_id, ' in global_world'
906	write(,)'infos I have for all proc of all components are:'
907	do i = 1, total_components
908	write(,)' ', components(i)%name
909	write(,)' ', components(i)%num_process
910	write(,)' ', components(i)%process_list(1:9)
911	enddo
912	endif
913	enddo
914
915	end subroutine MPH_global_SE_overlap
916
917
918	!----------- subroutine PE_in_component (name, comm) ------------
919
920	logical function PE_in_component (name, comm)
921	implicit none
922	character() name
923	integer id, comm
924
925	id = MPH_find_name(name, component_names, total_components)
926	if (low_proc_limit(id) .le. global_proc_id .and.&
927	global_proc_id .le. up_proc_limit(id)) then
928	comm = local_world(id)
929	PE_in_component = .true.
930	else
931	PE_in_component = .false.
932	endif
933
934	end function PE_in_component
935
936
937	!------ subroutine MPH_comm_join_SE_overlap (name1, name2, comm_joined) ---
938
939	subroutine MPH_comm_join_SE_overlap (name1, name2, comm_joined)
940	implicit none
941	integer id1, id2
942
943	character() name1, name2
944	integer comm_joined, color, key
945	logical con1, con2
946
947	id1 = MPH_find_name(name1,component_names,total_components)
948	id2 = MPH_find_name(name2,component_names,total_components)
949
950	! the order of two components does matter: first one has lower ranks in
951	! the new joined communicator, and second one has higher ranks.
952
953	con1 = (low_proc_limit(id1) .le. global_proc_id) .and.&
954	(global_proc_id .le. up_proc_limit(id1))
955	con2 = (low_proc_limit(id2) .le. global_proc_id).and.&
956	(global_proc_id .le. up_proc_limit(id2))
957
958	if (con1 .or. con2) then
959	color = 1
960	if (con1) then
961	key = local_proc_id(id1)
962	else
963	key = global_totProcs + local_proc_id(id2)
964	endif
965	else
966	color = 2
967	key = 0
968	endif
969
970	call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,comm_joined,ierr)
971
972	end subroutine MPH_comm_join_SE_overlap
973
974
975	!---- function MPH_read_list_SE_overlap (filename, filetag, namelist,
976	!---- low, up, num, local_num) ------
977
978	integer function MPH_read_list_SE_overlap (filename, filetag,&
979	namelist, low, up, num, local_num)
980	implicit none
981	integer i, num
982	character() filename, filetag
983	character*16 namelist(num), firstline, temp
984	integer itemp1, itemp2
985	integer low(num), up(num), local_num(num)
986
987	open(10, file=filename, status='unknown')
988	read(10, *, end=100) firstline
989	if (firstline .ne. filetag) then
990	print *, 'ERROR: filetag inconsistent', filename
991	print *, 'ERROR: ', filetag, '!=', firstline
992	stop
993	endif
994
995	read(10, *, end=200) temp
996	if (temp .ne. "BEGIN") then
997	print *, 'ERROR: no BEGIN in ', filename
998	stop
999	endif
1000
1001	do i = 1, num
1002	read(10, *, err=300, end=400) temp, itemp1, itemp2
1003	if (temp .eq. "END") goto 500
1004	namelist(i) = temp
1005	low(i) = itemp1
1006	up(i) = itemp2
1007	local_num(i) = itemp2 - itemp1 + 1
1008	enddo
1009
1010	100 print *, 'ERROR: no filetag in ', filename
1011	stop
1012
1013	200 print *, 'ERROR: no BEGIN in ', filename
1014	stop
1015
1016	300 if (temp .eq. "END") then
1017	goto 500
1018	else
1019	print *, 'ERROR: either: no END in ', filename
1020	print *, ' or: does not provide correct format as'
1021	print *, ' in input example: ocean 11 18'
1022	stop
1023	endif
1024
1025	400 print *, 'ERROR: no END in ', filename
1026	stop
1027
1028	500 MPH_read_list_SE_overlap = i - 1
1029	close(10)
1030
1031	return
1032	end function MPH_read_list_SE_overlap
1033
1034
1035	!--------- some special inquiry functions for MPH3 -----------
1036
1037	integer function MPH_local_proc_id_SE_overlap(id)
1038	integer id
1039	MPH_local_proc_id_SE_overlap = local_proc_id(id)
1040	end function MPH_local_proc_id_SE_overlap
1041
1042	integer function MPH_local_world_SE_overlap(id)
1043	integer id
1044	MPH_local_world_SE_overlap = local_world(id)
1045	end function MPH_local_world_SE_overlap
1046
1047	! -- the following two functions are common for MPH2 and MPH3
1048
1049	integer function MPH_low_proc_limit(id)
1050	integer id
1051	MPH_low_proc_limit = low_proc_limit(id)
1052	end function MPH_low_proc_limit
1053
1054	integer function MPH_up_proc_limit(id)
1055	integer id
1056	MPH_up_proc_limit = up_proc_limit(id)
1057	end function MPH_up_proc_limit
1058
1059	end module MPH_Single_Exec_Overlap
1060
1061
1062	! ==============================================================
1063	! module MPH_all
1064	! ==============================================================
1065
1066	module MPH_all
1067
1068	use MPH_Multi_Exec
1069	use MPH_Single_Exec
1070	use MPH_Single_Exec_Overlap
1071
1072	end module MPH_all

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: CPL/oasis3-mct/branches/OASIS3-MCT_5.0_branch/lib/mct/testsystem/testall/mph.F90 @ 6331

Download in other formats: