module mod_xc_global implicit none c c --- HYCOM communication interface. c --- A subset of the serial interface for setup only. c c --- tital array dimensions integer, public, save :: idm,jdm c c --- halo size always zero for setup integer nbdy parameter (nbdy=0) c c --- line printer unit (stdout) integer lp common/linepr/ lp save /linepr/ c c --- tile number (counting from 1) integer, public, save :: mnproc c c --- xcsync stdout flushing options logical, public, parameter :: flush_lp=.true., & no_flush=.false. c c --- private timer variables, see xctmri character*6, private, dimension(97), save :: cc integer, private, dimension(97), save :: nc real*8, private, dimension(97), save :: tc,t0 c c --- actual module subroutines contains subroutine xcspmd implicit none c c********** c* c 1) initialize data structures that identify the domain and tiles. c c 2) data structures: c idm - 1st total array dimension c jdm - 2nd total array dimension c mnproc - 1-D node index c c 3) Total array dimensions from global.grid.b c* c********** c character cvarin*6 c c shared memory version, mnproc=1. c mnproc = 1 lp = 6 c c total array dimensions from global.grid.b c open(unit=11,file='global.grid.b',form='formatted', & status='old',action='read') c read( 11,*) idm,cvarin if (cvarin.ne.'idm ') then write(lp,*) write(lp,*) 'error in xcspmd - global.grid.b input ',cvarin, & ' but should be idm ' write(lp,*) stop endif read( 11,*) jdm,cvarin if (cvarin.ne.'jdm ') then write(lp,*) write(lp,*) 'error in xcspmd - global.grid.b input ',cvarin, & ' but should be jdm ' write(lp,*) call flush(lp) stop endif c write(lp,'(/ a,2i5 /)') 'xcspmd: idm,jdm =',idm,jdm c close(unit=11) c c initialize timers. c call xctmri return end subroutine xcspmd subroutine xcstop(cerror) implicit none c character*(*), intent(in) :: cerror c c********** c* c 1) stop all processes. c c 2) all processes must call this routine. c use 'xchalt' for emergency stops. c c 3) parameters: c name type usage description c ---------- ---------- ------- ---------------------------- c cerror char*(*) input error message c* c********** c c print active timers. c call xctmrp c c shared memory version, just stop. c if (cerror.ne.' ') then write(lp,*) '**************************************************' write(lp,*) cerror write(lp,*) '**************************************************' call flush(lp) endif stop '(xcstop)' end subroutine xcstop subroutine xcsync(lflush) implicit none c logical, intent(in) :: lflush c c********** c* c 1) barrier, no processor exits until all arrive (and flush stdout). c c 2) some MPI implementations only flush stdout as a collective c operation, and hence the lflush=.true. option to flush stdout. c c 3) Only one processor, so the barrier is a no-op in this case. c* c********** c if (lflush) then call flush(lp) endif return end subroutine xcsync subroutine xctmri implicit none c c c********** c* c 1) initialize timers. c c 2) timers 1:32 are for message passing routines, c timers 33:80 are for general hycom routines, c timers 81:96 are for user selected routines. c timer 97 is the total time. c c 3) call xctmri to initialize timers (called in xcspmd), c call xctmr0(n) to start timer n, c call xctmr1(n) to stop timer n and add event to timer sum, c call xctnrn(n,cname) to register a name for timer n, c call xctmrp to printout timer statistics (called by xcstop). c* c********** c integer i c real*8 zero8 parameter (zero8=0.0) c do 110 i= 1,97 cc(i) = ' ' nc(i) = 0 tc(i) = zero8 110 continue c call xctmrn(97,'total ') call xctmr0(97) return end subroutine xctmri subroutine xctmr0(n) implicit none c integer, intent(in) :: n c c********** c* c 1) start timer n. c c 2) parameters: c name type usage description c ---------- ---------- ------- ---------------------------- c n integer input timer number c* c********** c real*8 wtime c #if defined(DEBUG_TIMER) if (n.gt.24 .and. cc(n).ne.' ') then write(lp,*) 'call ',cc(n) call flush(lp) endif #endif t0(n) = wtime() return end subroutine xctmr0 subroutine xctmr1(n) implicit none c integer, intent(in) :: n c c********** c* c 1) add time since call to xctim0 to timer n. c c 2) parameters: c name type usage description c ---------- ---------- ------- ---------------------------- c n integer input timer number c* c********** c real*8 wtime c nc(n) = nc(n) + 1 tc(n) = tc(n) + (wtime() - t0(n)) #if defined(DEBUG_TIMER) if (n.gt.24 .and. cc(n).ne.' ') then write(lp,*) 'exit ',cc(n) call flush(lp) endif #endif return end subroutine xctmr1 subroutine xctmrn(n,cname) implicit none c character*6, intent(in) :: cname integer, intent(in) :: n c c********** c* c 1) register name of timer n. c c 2) parameters: c name type usage description c ---------- ---------- ------- ---------------------------- c n integer input timer number c cname char*(8) input timer name c* c********** c cc(n) = cname return end subroutine xctmrn subroutine xctmrp implicit none c c********** c* c 1) print all active timers. c c 2) on exit all timers are reset to zero. c* c********** c integer i c real*8 zero8 parameter (zero8=0.0) c c get total time. c call xctmr1(97) c c print timers. c write(lp,6000) do i= 1,97 if (nc(i).ne.0) then if (cc(i).ne.' ') then write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i) else write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i) endif endif enddo write(lp,6200) call flush(lp) c c reset timers to zero. c do i= 1,97 nc(i) = 0 tc(i) = zero8 enddo c c start a new total time measurement. c call xctmr0(97) return c 6000 format(/ / + 4x,' timer statistics ' / + 4x,'------------------' /) 6100 format(5x,a6, + ' calls =',i9, + ' time =',f11.5, + ' time/call =',f14.8) 6150 format(5x,' #',i2, + ' calls =',i9, + ' time =',f11.5, + ' time/call =',f14.8) 6200 format(/ /) end subroutine xctmrp end module mod_xc_global