28 #if defined(use_libMPI)
29 #include <mpp_util_mpi.inc>
31 #include <mpp_util_nocomm.inc>
61 character(len=11) :: this_pe
83 if( pe.EQ.root_pe )
then
84 write(this_pe,
'(a,i6.6,a)')
'.',pe,
'.out'
85 inquire( file=trim(configfile)//this_pe, opened=opened )
89 open(newunit=log_unit, status=
'UNKNOWN', file=trim(configfile)//this_pe, position=
'APPEND', err=10 )
93 inquire(unit=etc_unit, opened=opened )
97 open(newunit=etc_unit, status=
'UNKNOWN', file=trim(etcfile), position=
'APPEND', err=11 )
102 10
call mpp_error( fatal,
'STDLOG: unable to open '//trim(configfile)//this_pe//
'.' )
103 11
call mpp_error( fatal,
'STDLOG: unable to open '//trim(etcfile)//
'.' )
107 subroutine mpp_init_logfile()
110 character(len=11) :: this_pe
111 if( pe.EQ.root_pe )
then
113 write(this_pe,
'(a,i6.6,a)')
'.',p,
'.out'
114 inquire( file=trim(configfile)//this_pe, exist=exist )
116 open(newunit=log_unit, file=trim(configfile)//this_pe, status=
'REPLACE' )
121 end subroutine mpp_init_logfile
123 subroutine mpp_set_warn_level(flag)
124 integer,
intent(in) :: flag
126 if( flag.EQ.warning )
then
127 warnings_are_fatal = .false.
128 else if( flag.EQ.fatal )
then
129 warnings_are_fatal = .true.
131 call mpp_error( fatal,
'MPP_SET_WARN_LEVEL: warning flag must be set to WARNING or FATAL.' )
134 end subroutine mpp_set_warn_level
137 function mpp_error_state()
138 integer :: mpp_error_state
139 mpp_error_state = error_state
141 end function mpp_error_state
146 character(len=*),
intent(in) :: routine, errormsg
147 integer,
intent(in) :: errortype
149 call mpp_error( errortype, trim(routine)//
': '//trim(errormsg) )
154 subroutine mpp_error_noargs()
155 call mpp_error(fatal)
156 end subroutine mpp_error_noargs
159 subroutine mpp_error_is(errortype, errormsg1, mpp_ival, errormsg2)
160 integer,
intent(in) :: errortype
161 INTEGER,
intent(in) :: mpp_ival
162 character(len=*),
intent(in) :: errormsg1
163 character(len=*),
intent(in),
optional :: errormsg2
164 call mpp_error( errortype, errormsg1, (/mpp_ival/), errormsg2)
165 end subroutine mpp_error_is
167 subroutine mpp_error_rs(errortype, errormsg1, mpp_rval, errormsg2)
168 integer,
intent(in) :: errortype
169 REAL,
intent(in) :: mpp_rval
170 character(len=*),
intent(in) :: errormsg1
171 character(len=*),
intent(in),
optional :: errormsg2
172 call mpp_error( errortype, errormsg1, (/mpp_rval/), errormsg2)
173 end subroutine mpp_error_rs
175 subroutine mpp_error_ia(errortype, errormsg1, array, errormsg2)
176 integer,
intent(in) :: errortype
177 INTEGER,
dimension(:),
intent(in) :: array
178 character(len=*),
intent(in) :: errormsg1
179 character(len=*),
intent(in),
optional :: errormsg2
180 character(len=512) :: string
182 string = errormsg1//trim(array_to_char(array))
183 if(
present(errormsg2)) string = trim(string)//errormsg2
186 end subroutine mpp_error_ia
189 subroutine mpp_error_ra(errortype, errormsg1, array, errormsg2)
190 integer,
intent(in) :: errortype
191 REAL,
dimension(:),
intent(in) :: array
192 character(len=*),
intent(in) :: errormsg1
193 character(len=*),
intent(in),
optional :: errormsg2
194 character(len=512) :: string
196 string = errormsg1//trim(array_to_char(array))
197 if(
present(errormsg2)) string = trim(string)//errormsg2
200 end subroutine mpp_error_ra
203 #define _SUBNAME_ mpp_error_ia_ia
204 #define _ARRAY1TYPE_ integer
205 #define _ARRAY2TYPE_ integer
206 #include <mpp_error_a_a.fh>
211 #define _SUBNAME_ mpp_error_ia_ra
212 #define _ARRAY1TYPE_ integer
213 #define _ARRAY2TYPE_ real
214 #include <mpp_error_a_a.fh>
219 #define _SUBNAME_ mpp_error_ra_ia
220 #define _ARRAY1TYPE_ real
221 #define _ARRAY2TYPE_ integer
222 #include <mpp_error_a_a.fh>
227 #define _SUBNAME_ mpp_error_ra_ra
228 #define _ARRAY1TYPE_ real
229 #define _ARRAY2TYPE_ real
230 #include <mpp_error_a_a.fh>
235 #define _SUBNAME_ mpp_error_ia_is
236 #define _ARRAY1TYPE_ integer
237 #define _ARRAY2TYPE_ integer
238 #include <mpp_error_a_s.fh>
243 #define _SUBNAME_ mpp_error_ia_rs
244 #define _ARRAY1TYPE_ integer
245 #define _ARRAY2TYPE_ real
246 #include <mpp_error_a_s.fh>
251 #define _SUBNAME_ mpp_error_ra_is
252 #define _ARRAY1TYPE_ real
253 #define _ARRAY2TYPE_ integer
254 #include <mpp_error_a_s.fh>
259 #define _SUBNAME_ mpp_error_ra_rs
260 #define _ARRAY1TYPE_ real
261 #define _ARRAY2TYPE_ real
262 #include <mpp_error_a_s.fh>
267 #define _SUBNAME_ mpp_error_is_ia
268 #define _ARRAY1TYPE_ integer
269 #define _ARRAY2TYPE_ integer
270 #include <mpp_error_s_a.fh>
275 #define _SUBNAME_ mpp_error_is_ra
276 #define _ARRAY1TYPE_ integer
277 #define _ARRAY2TYPE_ real
278 #include <mpp_error_s_a.fh>
283 #define _SUBNAME_ mpp_error_rs_ia
284 #define _ARRAY1TYPE_ real
285 #define _ARRAY2TYPE_ integer
286 #include <mpp_error_s_a.fh>
291 #define _SUBNAME_ mpp_error_rs_ra
292 #define _ARRAY1TYPE_ real
293 #define _ARRAY2TYPE_ real
294 #include <mpp_error_s_a.fh>
299 #define _SUBNAME_ mpp_error_is_is
300 #define _ARRAY1TYPE_ integer
301 #define _ARRAY2TYPE_ integer
302 #include <mpp_error_s_s.fh>
307 #define _SUBNAME_ mpp_error_is_rs
308 #define _ARRAY1TYPE_ integer
309 #define _ARRAY2TYPE_ real
310 #include <mpp_error_s_s.fh>
315 #define _SUBNAME_ mpp_error_rs_is
316 #define _ARRAY1TYPE_ real
317 #define _ARRAY2TYPE_ integer
318 #include <mpp_error_s_s.fh>
323 #define _SUBNAME_ mpp_error_rs_rs
324 #define _ARRAY1TYPE_ real
325 #define _ARRAY2TYPE_ real
326 #include <mpp_error_s_s.fh>
331 function iarray_to_char(iarray)
result(string)
332 integer,
intent(in) :: iarray(:)
333 character(len=256) :: string
334 character(len=32) :: chtmp
335 integer :: i, len_tmp, len_string
339 write(chtmp,
'(i16)') iarray(i)
340 chtmp = adjustl(chtmp)
341 len_tmp = len_trim(chtmp)
342 len_string = len_trim(string)
343 string(len_string+1:len_string+len_tmp) = trim(chtmp)
344 string(len_string+len_tmp+1:len_string+len_tmp+1) =
','
346 len_string = len_trim(string)
347 string(len_string:len_string) =
' '
349 end function iarray_to_char
351 function rarray_to_char(rarray)
result(string)
352 real,
intent(in) :: rarray(:)
353 character(len=256) :: string
354 character(len=32) :: chtmp
355 integer :: i, len_tmp, len_string
359 write(chtmp,
'(G16.9)') rarray(i)
360 chtmp = adjustl(chtmp)
361 len_tmp = len_trim(chtmp)
362 len_string = len_trim(string)
363 string(len_string+1:len_string+len_tmp) = trim(chtmp)
364 string(len_string+len_tmp+1:len_string+len_tmp+1) =
','
366 len_string = len_trim(string)
367 string(len_string:len_string) =
' '
369 end function rarray_to_char
380 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_PE: You must first call mpp_init.' )
394 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_NPES: You must first call mpp_init.' )
395 mpp_npes =
size(peset(current_peset_num)%list(:))
400 function mpp_root_pe()
401 integer :: mpp_root_pe
403 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_ROOT_PE: You must first call mpp_init.' )
404 mpp_root_pe = root_pe
406 end function mpp_root_pe
409 subroutine mpp_set_root_pe(num)
410 integer,
intent(in) :: num
412 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_SET_ROOT_PE: You must first call mpp_init.' )
413 if( .NOT.(any(num.EQ.peset(current_peset_num)%list(:))) ) &
414 call mpp_error( fatal,
'MPP_SET_ROOT_PE: you cannot set a root PE outside the current pelist.' )
417 end subroutine mpp_set_root_pe
432 integer,
intent(in) :: pelist(:)
433 character(len=*),
intent(in),
optional :: name
434 integer,
intent(out),
optional :: commID
437 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_DECLARE_PELIST: You must first call mpp_init.' )
438 i = get_peset(pelist)
439 write( peset(i)%name,
'(a,i2.2)' )
'PElist', i
440 if(
PRESENT(name) )peset(i)%name = name
441 if(
PRESENT(commid) )commid = peset(i)%id
468 integer,
intent(in),
optional :: pelist(:)
469 logical,
intent(in),
optional :: no_sync
471 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_SET_CURRENT_PELIST: You must first call mpp_init.' )
472 if(
PRESENT(pelist) )
then
473 if( .NOT.any(pe.EQ.pelist) )
call mpp_error( fatal,
'MPP_SET_CURRENT_PELIST: pe must be in pelist.' )
474 current_peset_num = get_peset(pelist)
476 current_peset_num = world_peset_num
478 call mpp_set_root_pe( minval(peset(current_peset_num)%list(:)) )
479 if(.not.
PRESENT(no_sync))
call mpp_sync()
485 function mpp_get_current_pelist_name()
487 character(len=len(peset(current_peset_num)%name)) :: mpp_get_current_pelist_name
489 mpp_get_current_pelist_name = peset(current_peset_num)%name
490 end function mpp_get_current_pelist_name
495 subroutine mpp_get_current_pelist( pelist, name, commID )
496 integer,
intent(out) :: pelist(:)
497 character(len=*),
intent(out),
optional :: name
498 integer,
intent(out),
optional :: commID
500 if(
size(pelist(:)).NE.
size(peset(current_peset_num)%list(:)) ) &
501 call mpp_error( fatal,
'MPP_GET_CURRENT_PELIST: size(pelist) is wrong.' )
502 pelist(:) = peset(current_peset_num)%list(:)
503 if(
PRESENT(name) )name = peset(current_peset_num)%name
505 if(
PRESENT(commid) )commid = peset(current_peset_num)%id
509 end subroutine mpp_get_current_pelist
612 integer,
intent(in) :: grain
617 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_CLOCK_SET_GRAIN: You must first call mpp_init.' )
624 subroutine clock_init( id, name, flags, grain )
625 integer,
intent(in) :: id
626 character(len=*),
intent(in) :: name
627 integer,
intent(in),
optional :: flags, grain
630 clocks(id)%name = name
633 clocks(id)%total_ticks = 0
634 clocks(id)%sync_on_begin = .false.
635 clocks(id)%detailed = .false.
636 clocks(id)%peset_num = current_peset_num
637 if(
PRESENT(flags) )
then
638 if( btest(flags,0) )clocks(id)%sync_on_begin = .true.
639 if( btest(flags,1) )clocks(id)%detailed = .true.
642 if(
PRESENT(grain) )clocks(id)%grain = grain
643 if( clocks(id)%detailed )
then
644 allocate( clocks(id)%events(max_event_types) )
645 clocks(id)%events(event_allreduce)%name =
'ALLREDUCE'
646 clocks(id)%events(event_broadcast)%name =
'BROADCAST'
647 clocks(id)%events(event_recv)%name =
'RECV'
648 clocks(id)%events(event_send)%name =
'SEND'
649 clocks(id)%events(event_wait)%name =
'WAIT'
650 do i=1,max_event_types
651 clocks(id)%events(i)%ticks(:) = 0
652 clocks(id)%events(i)%bytes(:) = 0
653 clocks(id)%events(i)%calls = 0
655 clock_summary(id)%name = name
656 clock_summary(id)%event(event_allreduce)%name =
'ALLREDUCE'
657 clock_summary(id)%event(event_broadcast)%name =
'BROADCAST'
658 clock_summary(id)%event(event_recv)%name =
'RECV'
659 clock_summary(id)%event(event_send)%name =
'SEND'
660 clock_summary(id)%event(event_wait)%name =
'WAIT'
661 do i=1,max_event_types
662 clock_summary(id)%event(i)%msg_size_sums(:) = 0.0
663 clock_summary(id)%event(i)%msg_time_sums(:) = 0.0
664 clock_summary(id)%event(i)%total_data = 0.0
665 clock_summary(id)%event(i)%total_time = 0.0
666 clock_summary(id)%event(i)%msg_size_cnts(:) = 0
667 clock_summary(id)%event(i)%total_cnts = 0
671 end subroutine clock_init
677 character(len=*),
intent(in) :: name
678 integer,
intent(in),
optional :: flags, grain
680 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_CLOCK_ID: You must first call mpp_init.')
686 if(
PRESENT(grain) )
then
687 if( grain.GT.clock_grain )
then
694 if( clock_num.EQ.0 )
then
698 find_clock:
do while( trim(name).NE.trim(clocks(
mpp_clock_id)%name) )
702 call mpp_error( fatal,
'MPP_CLOCK_ID: too many clock requests, ' // &
703 'check your clock id request or increase MAX_CLOCKS.')
716 subroutine mpp_clock_begin(id)
717 integer,
intent(in) :: id
719 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_CLOCK_BEGIN: You must first call mpp_init.' )
720 if( .not. mpp_record_timing_data)
return
722 if( id.LT.0 .OR. id.GT.clock_num )
call mpp_error( fatal,
'MPP_CLOCK_BEGIN: invalid id.' )
725 if( clocks(id)%peset_num.NE.current_peset_num ) &
726 call mpp_error( fatal,
'MPP_CLOCK_BEGIN: cannot change pelist context of a clock.' )
727 if( clocks(id)%is_on)
call mpp_error(fatal,
'MPP_CLOCK_BEGIN: mpp_clock_begin is called again '// &
728 'before calling mpp_clock_end for the clock '//trim(clocks(id)%name) )
729 if( clocks(id)%sync_on_begin .OR. sync_all_clocks )
then
737 num_clock_ids = num_clock_ids+1
738 if(num_clock_ids > max_clocks)
call mpp_error(fatal,
'MPP_CLOCK_BEGIN: max num previous_clock exceeded.' )
739 previous_clock(num_clock_ids) = current_clock
742 call system_clock( clocks(id)%tick )
743 clocks(id)%hits = clocks(id)%hits + 1
744 clocks(id)%is_on = .true.
747 end subroutine mpp_clock_begin
750 subroutine mpp_clock_end(id)
751 integer,
intent(in) :: id
752 integer(i8_kind) :: delta
755 if( .NOT.module_is_initialized )
call mpp_error( fatal,
'MPP_CLOCK_END: You must first call mpp_init.' )
756 if( .not. mpp_record_timing_data)
return
758 if( id.LT.0 .OR. id.GT.clock_num )
call mpp_error( fatal,
'MPP_CLOCK_BEGIN: invalid id.' )
760 if( .NOT. clocks(id)%is_on)
call mpp_error(fatal,
'MPP_CLOCK_END: mpp_clock_end is called '// &
761 'before calling mpp_clock_begin for the clock '//trim(clocks(id)%name) )
763 call system_clock(end_tick)
764 if( clocks(id)%peset_num.NE.current_peset_num ) &
765 call mpp_error( fatal,
'MPP_CLOCK_END: cannot change pelist context of a clock.' )
766 delta = end_tick - clocks(id)%tick
769 write( errunit,* )
'pe, id, start_tick, end_tick, delta, max_ticks=', pe, id, clocks(id)%tick, end_tick, &
771 delta = delta + max_ticks + 1
772 call mpp_error( warning,
'MPP_CLOCK_END: Clock rollover, assumed single roll.' )
774 clocks(id)%total_ticks = clocks(id)%total_ticks + delta
776 if(num_clock_ids < 1)
call mpp_error(note,
'MPP_CLOCK_END: min num previous_clock < 1.' )
777 current_clock = previous_clock(num_clock_ids)
778 num_clock_ids = num_clock_ids-1
780 clocks(id)%is_on = .false.
783 end subroutine mpp_clock_end
786 subroutine mpp_record_time_start()
788 mpp_record_timing_data = .true.
790 end subroutine mpp_record_time_start
793 subroutine mpp_record_time_end()
795 mpp_record_timing_data = .false.
797 end subroutine mpp_record_time_end
801 subroutine increment_current_clock( event_id, bytes )
802 integer,
intent(in) :: event_id
803 integer,
intent(in),
optional :: bytes
805 integer(i8_kind) :: delta
808 if( .not. mpp_record_timing_data )
return
809 if( .not.debug .or. (current_clock.EQ.0) )
return
810 if( current_clock.LT.0 .OR. current_clock.GT.clock_num )
call mpp_error( fatal, &
811 &
'MPP_CLOCK_BEGIN: invalid current_clock.' )
812 if( .NOT.clocks(current_clock)%detailed )
return
813 call system_clock(end_tick)
814 n = clocks(current_clock)%events(event_id)%calls + 1
816 if( n.EQ.max_events )
call mpp_error( warning, &
817 'MPP_CLOCK: events exceed MAX_EVENTS, ignore detailed profiling data for clock '// &
818 & trim(clocks(current_clock)%name) )
819 if( n.GT.max_events )
return
821 clocks(current_clock)%events(event_id)%calls = n
822 delta = end_tick - start_tick
825 write( errunit,* )
'pe, event_id, start_tick, end_tick, delta, max_ticks=', &
826 pe, event_id, start_tick, end_tick, delta, max_ticks
827 delta = delta + max_ticks + 1
828 call mpp_error( warning,
'MPP_CLOCK_END: Clock rollover, assumed single roll.' )
830 clocks(current_clock)%events(event_id)%ticks(n) = delta
831 if(
PRESENT(bytes) )clocks(current_clock)%events(event_id)%bytes(n) = bytes
833 end subroutine increment_current_clock
837 subroutine dump_clock_summary()
839 real :: total_time,total_time_all,total_data
840 real :: msg_size,eff_bw,s
841 integer :: sd_unit, total_calls
842 integer :: j,k,ct, msg_cnt
843 character(len=2) :: u
844 character(len=20) :: filename
845 character(len=20),
dimension(MAX_BINS),
save :: bin
847 data bin( 1) /
' 0 - 8 B: '/
848 data bin( 2) /
' 8 - 16 B: '/
849 data bin( 3) /
' 16 - 32 B: '/
850 data bin( 4) /
' 32 - 64 B: '/
851 data bin( 5) /
' 64 - 128 B: '/
852 data bin( 6) /
'128 - 256 B: '/
853 data bin( 7) /
'256 - 512 B: '/
854 data bin( 8) /
'512 - 1024 B: '/
855 data bin( 9) /
' 1.0 - 2.1 KB: '/
856 data bin(10) /
' 2.1 - 4.1 KB: '/
857 data bin(11) /
' 4.1 - 8.2 KB: '/
858 data bin(12) /
' 8.2 - 16.4 KB: '/
859 data bin(13) /
' 16.4 - 32.8 KB: '/
860 data bin(14) /
' 32.8 - 65.5 KB: '/
861 data bin(15) /
' 65.5 - 131.1 KB: '/
862 data bin(16) /
'131.1 - 262.1 KB: '/
863 data bin(17) /
'262.1 - 524.3 KB: '/
864 data bin(18) /
'524.3 - 1048.6 KB: '/
865 data bin(19) /
' 1.0 - 2.1 MB: '/
866 data bin(20) /
' >2.1 MB: '/
868 if( .NOT.any(clocks(1:clock_num)%detailed) )
return
869 write( filename,
'(a,i6.6)' )
'mpp_clock.out.', pe
871 open(newunit=sd_unit,file=trim(filename),form=
'formatted')
873 comm_type:
do ct = 1,clock_num
875 if( .NOT.clocks(ct)%detailed )cycle
877 clock_summary(ct)%name(1:15),
' Communication Data for PE ',pe
883 event_type:
do k = 1,max_event_types-1
885 if(clock_summary(ct)%event(k)%total_time == 0.0)cycle
887 total_time = clock_summary(ct)%event(k)%total_time
888 total_time_all = total_time_all + total_time
889 total_data = clock_summary(ct)%event(k)%total_data
890 total_calls = int(clock_summary(ct)%event(k)%total_cnts)
892 write(sd_unit,1000) clock_summary(ct)%event(k)%name(1:9) //
':'
894 write(sd_unit,1001)
'Total Data: ',total_data*1.0e-6, &
895 'MB; Total Time: ', total_time, &
896 'secs; Total Calls: ',total_calls
899 write(sd_unit,1002)
' Bin Counts Avg Size Eff B/W'
902 bin_loop:
do j=1,max_bins
904 if(clock_summary(ct)%event(k)%msg_size_cnts(j)==0)cycle
917 msg_cnt = int(clock_summary(ct)%event(k)%msg_size_cnts(j))
919 s*(clock_summary(ct)%event(k)%msg_size_sums(j)/real(msg_cnt))
920 eff_bw = (1.0e-6)*( clock_summary(ct)%event(k)%msg_size_sums(j) / &
921 clock_summary(ct)%event(k)%msg_time_sums(j) )
923 write(sd_unit,1003) bin(j),msg_cnt,msg_size,u,eff_bw
933 if(clock_summary(ct)%event(max_event_types)%total_time>0.0)
then
935 total_time = clock_summary(ct)%event(max_event_types)%total_time
936 total_time_all = total_time_all + total_time
937 total_calls = int(clock_summary(ct)%event(max_event_types)%total_cnts)
939 write(sd_unit,1000) clock_summary(ct)%event(max_event_types)%name(1:9) //
':'
941 write(sd_unit,1004)
'Total Calls: ',total_calls,
'; Total Time: ', &
947 write(sd_unit,1005)
'Total communication time spent for ' // &
948 clock_summary(ct)%name(1:9) //
': ',total_time_all,
'secs'
958 1001
format(a,f8.2,a,f8.2,a,i6)
960 1003
format(a,i6,
' ',
' ',f9.1,a,
' ',f9.2,
'MB/sec')
961 1004
format(a,i8,a,f9.2,a)
962 1005
format(a,f9.2,a)
964 end subroutine dump_clock_summary
968 integer function get_unit()
973 if (pe == root_pe)
call mpp_error(warning, &
974 'get_unit is deprecated and will be removed in a future release, please use the Fortran intrinsic newunit')
976 inquire(unit=i,opened=l_open)
981 call mpp_error(fatal,
'Unable to get I/O unit')
987 end function get_unit
991 subroutine sum_clock_data()
993 integer :: i,j,k,ct,event_size,event_cnt
996 clock_type:
do ct=1,clock_num
997 if( .NOT.clocks(ct)%detailed )cycle
998 event_type:
do j=1,max_event_types-1
999 event_cnt = clocks(ct)%events(j)%calls
1000 event_summary:
do i=1,event_cnt
1002 clock_summary(ct)%event(j)%total_cnts = &
1003 clock_summary(ct)%event(j)%total_cnts + 1
1005 event_size = int(clocks(ct)%events(j)%bytes(i))
1007 k = find_bin(event_size)
1009 clock_summary(ct)%event(j)%msg_size_cnts(k) = &
1010 clock_summary(ct)%event(j)%msg_size_cnts(k) + 1
1012 clock_summary(ct)%event(j)%msg_size_sums(k) = &
1013 clock_summary(ct)%event(j)%msg_size_sums(k) &
1014 + clocks(ct)%events(j)%bytes(i)
1016 clock_summary(ct)%event(j)%total_data = &
1017 clock_summary(ct)%event(j)%total_data &
1018 + clocks(ct)%events(j)%bytes(i)
1020 msg_time = clocks(ct)%events(j)%ticks(i)
1021 msg_time = tick_rate * real( clocks(ct)%events(j)%ticks(i) )
1023 clock_summary(ct)%event(j)%msg_time_sums(k) = &
1024 clock_summary(ct)%event(j)%msg_time_sums(k) + msg_time
1026 clock_summary(ct)%event(j)%total_time = &
1027 clock_summary(ct)%event(j)%total_time + msg_time
1029 end do event_summary
1036 event_cnt = clocks(ct)%events(j)%calls
1037 clock_summary(ct)%event(j)%msg_size_cnts(1) = event_cnt
1038 clock_summary(ct)%event(j)%total_cnts = event_cnt
1040 msg_time = tick_rate * real( sum( clocks(ct)%events(j)%ticks(1:event_cnt) ) )
1041 clock_summary(ct)%event(j)%msg_time_sums(1) = &
1042 clock_summary(ct)%event(j)%msg_time_sums(1) + msg_time
1044 clock_summary(ct)%event(j)%total_time = clock_summary(ct)%event(j)%msg_time_sums(1)
1050 integer function find_bin(event_size)
1052 integer,
intent(in) :: event_size
1053 integer :: k,msg_size
1057 do while(event_size>msg_size .and. k<max_bins)
1059 msg_size = msg_size*2
1063 end function find_bin
1065 end subroutine sum_clock_data
1071 integer :: old_peset_max,n
1072 type(communicator),
allocatable :: peset_old(:)
1074 old_peset_max = current_peset_max
1075 if(old_peset_max .GE. peset_max)
call mpp_error(fatal, &
1076 "mpp_mod(expand_peset): the number of peset reached PESET_MAX, increase PESET_MAX or contact developer")
1079 allocate(peset_old(0:old_peset_max))
1080 do n = 0, old_peset_max
1081 peset_old(n)%count = peset(n)%count
1082 peset_old(n)%id = peset(n)%id
1083 peset_old(n)%group = peset(n)%group
1084 peset_old(n)%name = peset(n)%name
1085 peset_old(n)%start = peset(n)%start
1086 peset_old(n)%log2stride = peset(n)%log2stride
1088 if(
ASSOCIATED(peset(n)%list) )
then
1089 allocate(peset_old(n)%list(
size(peset(n)%list(:))) )
1090 peset_old(n)%list(:) = peset(n)%list(:)
1091 deallocate(peset(n)%list)
1097 current_peset_max = min(peset_max, 2*old_peset_max)
1098 allocate(peset(0:current_peset_max))
1103 peset(:)%log2stride = -1
1105 do n = 0, old_peset_max
1106 peset(n)%count = peset_old(n)%count
1107 peset(n)%id = peset_old(n)%id
1108 peset(n)%group = peset_old(n)%group
1109 peset(n)%name = peset_old(n)%name
1110 peset(n)%start = peset_old(n)%start
1111 peset(n)%log2stride = peset_old(n)%log2stride
1113 if(
ASSOCIATED(peset_old(n)%list) )
then
1114 allocate(peset(n)%list(
size(peset_old(n)%list(:))) )
1115 peset(n)%list(:) = peset_old(n)%list(:)
1116 deallocate(peset_old(n)%list)
1119 deallocate(peset_old)
1121 call mpp_error(note,
"mpp_mod(expand_peset): size of peset is expanded to ", current_peset_max)
1126 function uppercase (cs)
1127 character(len=*),
intent(in) :: cs
1128 character(len=len(cs)),
target :: uppercase
1130 character,
pointer :: ca
1131 integer,
parameter :: co=iachar(
'A')-iachar(
'a')
1137 uppercase = cs(1:tlen)
1139 ca => uppercase(k:k)
1140 if(ca >=
"a" .and. ca <=
"z") ca = achar(ichar(ca)+co)
1143 end function uppercase
1147 function lowercase (cs)
1148 character(len=*),
intent(in) :: cs
1149 character(len=len(cs)),
target :: lowercase
1150 integer,
parameter :: co=iachar(
'a')-iachar(
'A')
1152 character,
pointer :: ca
1158 lowercase = cs(1:tlen)
1160 ca => lowercase(k:k)
1161 if(ca >=
"A" .and. ca <=
"Z") ca = achar(ichar(ca)+co)
1164 end function lowercase
1192 #include<file_version.h>
1194 character(len=*),
intent(in),
optional :: pelist_name_in
1195 character(len=*),
intent(in),
optional :: alt_input_nml_path
1199 integer,
dimension(2) :: lines_and_length
1200 logical :: file_exist
1201 character(len=len(peset(current_peset_num)%name)) :: pelist_name
1202 character(len=128) :: filename
1205 if (
allocated(input_nml_file) )
then
1206 deallocate(input_nml_file)
1210 if (
PRESENT(pelist_name_in))
then
1212 if (len(pelist_name_in) > len(pelist_name))
then
1213 call mpp_error(fatal, &
1214 "mpp_util.inc: read_input_nml optional argument pelist_name_in has size greater than local pelist_name")
1216 pelist_name = pelist_name_in
1219 pelist_name = mpp_get_current_pelist_name()
1221 filename=
'input_'//trim(pelist_name)//
'.nml'
1222 inquire(file=filename, exist=file_exist)
1223 if (.not. file_exist )
then
1224 if (
present(alt_input_nml_path))
then
1225 filename = alt_input_nml_path
1227 filename =
'input.nml'
1231 allocate(
character(len=lines_and_length(2))::input_nml_file(lines_and_length(1)))
1235 if (pe == root_pe)
then
1237 write(log_unit,
'(a)')
'========================================================================'
1238 write(log_unit,
'(a)')
'READ_INPUT_NML: '//trim(version)
1239 write(log_unit,
'(a)')
'READ_INPUT_NML: '//trim(filename)//
' '
1240 do i = 1, lines_and_length(1)
1241 write(log_unit,*) trim(input_nml_file(i))
1249 function get_ascii_file_num_lines(FILENAME, LENGTH, PELIST)
1250 character(len=*),
intent(in) :: FILENAME
1251 integer,
intent(in) :: LENGTH
1252 integer,
intent(in),
optional,
dimension(:) :: PELIST
1254 integer :: num_lines, get_ascii_file_num_lines
1255 character(len=LENGTH) :: str_tmp
1256 character(len=5) :: text
1257 integer :: status, f_unit, from_pe
1258 logical :: file_exist
1260 if( read_ascii_file_on)
then
1261 call mpp_error(fatal, &
1262 "mpp_util.inc: get_ascii_file_num_lines is called again before calling read_ascii_file")
1264 read_ascii_file_on = .true.
1267 get_ascii_file_num_lines = -1
1269 if ( pe == root_pe )
then
1270 inquire(file=filename, exist=file_exist)
1272 if ( file_exist )
then
1273 open(newunit=f_unit, file=filename, action=
'READ', status=
'OLD', iostat=status)
1275 if ( status .ne. 0 )
then
1276 write (unit=text, fmt=
'(I5)') status
1277 call mpp_error(fatal,
'get_ascii_file_num_lines: Error opening file:' //trim(filename)// &
1278 '. (IOSTAT = '//trim(text)//
')')
1282 read (unit=f_unit, fmt=
'(A)', iostat=status) str_tmp
1283 if ( status .lt. 0 )
then
1285 num_lines = max(num_lines - 1, 1)
1288 if ( status .gt. 0 )
then
1289 write (unit=text, fmt=
'(I5)') num_lines
1290 call mpp_error(fatal,
'get_ascii_file_num_lines: Error reading line '//trim(text)// &
1291 ' in file '//trim(filename)//
'.')
1293 if ( len_trim(str_tmp) == length )
then
1294 write(unit=text, fmt=
'(I5)') length
1295 call mpp_error(fatal,
'get_ascii_file_num_lines: Length of output string ('//trim(text)//&
1296 &
' is too small. Increase the LENGTH value.')
1298 num_lines = num_lines + 1
1303 call mpp_error(fatal,
'get_ascii_file_num_lines: File '//trim(filename)//
' does not exist.')
1308 call mpp_broadcast(num_lines, from_pe, pelist=pelist)
1309 get_ascii_file_num_lines = num_lines
1311 end function get_ascii_file_num_lines
1316 character(len=*),
intent(in) :: filename
1317 integer,
intent(in),
optional,
dimension(:) :: pelist
1321 integer :: num_lines, max_length
1322 integer,
parameter :: length=1024
1323 character(len=LENGTH) :: str_tmp
1324 character(len=5) :: text
1325 integer :: status, f_unit, from_pe
1326 logical :: file_exist
1328 if( read_ascii_file_on)
then
1329 call mpp_error(fatal, &
1330 "mpp_util.inc: get_ascii_file_num_lines is called again before calling read_ascii_file")
1332 read_ascii_file_on = .true.
1338 if ( pe == root_pe )
then
1339 inquire(file=filename, exist=file_exist)
1341 if ( file_exist )
then
1342 open(newunit=f_unit, file=filename, action=
'READ', status=
'OLD', iostat=status)
1344 if ( status .ne. 0 )
then
1345 write (unit=text, fmt=
'(I5)') status
1346 call mpp_error(fatal,
'get_ascii_file_num_lines: Error opening file:' //trim(filename)// &
1347 '. (IOSTAT = '//trim(text)//
')')
1352 read (unit=f_unit, fmt=
'(A)', iostat=status) str_tmp
1353 if ( status .lt. 0 )
then
1355 num_lines = max(num_lines - 1, 1)
1358 if ( status .gt. 0 )
then
1359 write (unit=text, fmt=
'(I5)') num_lines
1360 call mpp_error(fatal,
'get_ascii_file_num_lines: Error reading line '//trim(text)// &
1361 ' in file '//trim(filename)//
'.')
1363 if ( len_trim(str_tmp) == length )
then
1364 write(unit=text, fmt=
'(I5)') length
1365 call mpp_error(fatal,
'get_ascii_file_num_lines: Length of output string ('//trim(text)//&
1366 &
' is too small. Increase the LENGTH value.')
1368 if (len_trim(str_tmp) > max_length) max_length = len_trim(str_tmp)
1369 num_lines = num_lines + 1
1374 call mpp_error(fatal,
'get_ascii_file_num_lines: File '//trim(filename)//
' does not exist.')
1376 max_length = max_length+1
1380 call mpp_broadcast(num_lines, from_pe, pelist=pelist)
1381 call mpp_broadcast(max_length, from_pe, pelist=pelist)
1409 character(len=*),
intent(in) :: FILENAME
1410 integer,
intent(in) :: LENGTH
1411 character(len=*),
intent(inout),
dimension(:) :: Content
1412 integer,
intent(in),
optional,
dimension(:) :: PELIST
1415 #include<file_version.h>
1417 character(len=5) :: text
1418 logical :: file_exist
1419 integer :: status, f_unit, log_unit
1421 integer :: pnum_lines, num_lines
1422 character(len=LENGTH) :: str_tmp
1424 if( .NOT. read_ascii_file_on)
then
1425 call mpp_error(fatal, &
1426 "mpp_util.inc: get_ascii_file_num_lines needs to be called before calling read_ascii_file")
1428 read_ascii_file_on = .false.
1431 num_lines =
size(content(:))
1433 if ( pe == root_pe )
then
1436 write(log_unit,
'(a)')
'========================================================================'
1437 write(log_unit,
'(a)')
'READ_ASCII_FILE: '//trim(version)
1438 write(log_unit,
'(a)')
'READ_ASCII_FILE: File: '//trim(filename)
1440 inquire(file=filename, exist=file_exist)
1442 if ( file_exist )
then
1443 open(newunit=f_unit, file=filename, action=
'READ', status=
'OLD', iostat=status)
1445 if ( status .ne. 0 )
then
1446 write (unit=text, fmt=
'(I5)') status
1447 call mpp_error(fatal,
'READ_ASCII_FILE: Error opening file: '// &
1448 & trim(filename)//
'. (IOSTAT = '//trim(text)//
')')
1451 if ( num_lines .gt. 0 )
then
1454 rewind(unit=f_unit, iostat=status)
1455 if ( status .ne. 0 )
then
1456 write (unit=text, fmt=
'(I5)') status
1457 call mpp_error(fatal,
'READ_ASCII_FILE: Unable to re-read file '//trim(filename)//
'. (IOSTAT = '&
1464 read (unit=f_unit, fmt=
'(A)', iostat=status) str_tmp
1466 if ( status .lt. 0 )
then
1468 pnum_lines = max(pnum_lines - 1, 1)
1471 if ( status .gt. 0 )
then
1472 write (unit=text, fmt=
'(I5)') pnum_lines
1473 call mpp_error(fatal,
'READ_ASCII_FILE: Error reading line '// &
1474 & trim(text)//
' in file '//trim(filename)//
'.')
1476 if(pnum_lines > num_lines)
then
1477 call mpp_error(fatal,
'READ_ASCII_FILE: number of lines in file '//trim(filename)// &
1478 ' is greater than size(Content(:)). ')
1480 if ( len_trim(str_tmp) == length )
then
1481 write(unit=text, fmt=
'(I5)') length
1482 call mpp_error(fatal,
'READ_ASCII_FILE: Length of output string ('//trim(text)// &
1483 &
' is too small. Increase the LENGTH value.')
1485 content(pnum_lines) = str_tmp
1486 pnum_lines = pnum_lines + 1
1488 if(num_lines .NE. pnum_lines)
then
1489 call mpp_error(fatal,
'READ_ASCII_FILE: number of lines in file '//trim(filename)// &
1490 ' does not equal to size(Content(:)) ' )
1497 call mpp_error(fatal,
'READ_ASCII_FILE: File '//trim(filename)//
' does not exist.')
1502 call mpp_broadcast(content, length, from_pe, pelist=pelist)
subroutine mpp_error_basic(errortype, errormsg)
A very basic error handler uses ABORT and FLUSH calls, may need to use cpp to rename.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
subroutine read_ascii_file(FILENAME, LENGTH, Content, PELIST)
Reads any ascii file into a character array and broadcasts it to the non-root mpi-tasks....
subroutine mpp_error_mesg(routine, errormsg, errortype)
overloads to mpp_error_basic, support for error_mesg routine in FMS
subroutine mpp_set_current_pelist(pelist, no_sync)
Set context pelist.
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
subroutine read_input_nml(pelist_name_in, alt_input_nml_path)
Reads an existing input nml file into a character array and broadcasts it to the non-root mpi-tasks....
subroutine mpp_clock_set_grain(grain)
Set the level of granularity of timing measurements.
subroutine mpp_declare_pelist(pelist, name, commID)
Declare a pelist.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_npes()
Returns processor count for current pelist.
integer function, dimension(2) get_ascii_file_num_lines_and_length(FILENAME, PELIST)
Function to determine the maximum line length and number of lines from an ascii file.
integer function mpp_pe()
Returns processor ID.
subroutine mpp_sync(pelist, do_self)
Synchronize PEs in list.
integer function mpp_clock_id(name, flags, grain)
Return an ID for a new or existing clock.
integer function stdin()
This function returns the current standard fortran unit numbers for input.
subroutine expand_peset()
This routine will double the size of peset and copy the original peset data into the expanded one....