mod_xc.F

      module mod_xc
      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 regional.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 regional.grid.b
c
      open(unit=11,file='regional.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 - regional.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 - regional.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