frame/module_machine.F

   1 !WRF:DRIVER_LAYER:DECOMPOSITION
   2 !
   3
   4 MODULE module_machine
   5
   6    USE module_driver_constants
   7
   8    !  Machine characteristics and utilities here.
   9
  10    ! Tile strategy defined constants
  11    INTEGER, PARAMETER :: TILE_NONE = 0, TILE_X = 1, TILE_Y = 2, TILE_XY = 3
  12
  13    CONTAINS
  14
  15    RECURSIVE SUBROUTINE rlocproc(p,maxi,nproc,ml,mr,ret)
  16    IMPLICIT NONE
  17    INTEGER, INTENT(IN)  :: p, maxi, nproc, ml, mr
  18    INTEGER, INTENT(OUT) :: ret
  19    INTEGER              :: width, rem, ret2, bl, br, mid, adjust, &
  20                            p_r, maxi_r, nproc_r, zero
  21    adjust = 0
  22    rem = mod( maxi, nproc )
  23    width = maxi / nproc
  24    mid = maxi / 2
  25    IF ( rem>0 .AND. (((mod(rem,2).EQ.0).OR.(rem.GT.2)).OR.(p.LE.mid))) THEN
  26      width = width + 1
  27    END IF
  28    IF ( p.LE.mid .AND. mod(rem,2).NE.0 ) THEN
  29      adjust = adjust + 1
  30    END IF
  31    bl = max(width,ml) ;
  32    br = max(width,mr) ;
  33    IF      (p<bl) THEN
  34      ret = 0
  35    ELSE IF (p>maxi-br-1) THEN
  36      ret = nproc-1
  37    ELSE
  38      p_r = p - bl
  39      maxi_r = maxi-bl-br+adjust
  40      nproc_r = max(nproc-2,1)
  41      zero = 0
  42      CALL rlocproc( p_r, maxi_r, nproc_r, zero, zero, ret2 )  ! Recursive
  43      ret = ret2 + 1
  44    END IF
  45    RETURN
  46    END SUBROUTINE rlocproc
  47
  48    INTEGER FUNCTION locproc( i, m, numpart )
  49    implicit none
  50    integer, intent(in) :: i, m, numpart
  51    integer             :: retval, ii, im, inumpart, zero
  52    ii = i
  53    im = m
  54    inumpart = numpart
  55    zero = 0
  56    CALL rlocproc( ii, im, inumpart, zero, zero, retval )
  57    locproc = retval
  58    RETURN
  59    END FUNCTION locproc
  60
  61    SUBROUTINE patchmap( res, y, x, py, px )
  62    implicit none
  63    INTEGER, INTENT(IN)                    :: y, x, py, px
  64    INTEGER, DIMENSION(x,y), INTENT(OUT)   :: res
  65    INTEGER                                :: i, j, p_min, p_maj
  66    DO j = 0,y-1
  67      p_maj = locproc( j, y, py )
  68      DO i = 0,x-1
  69        p_min = locproc( i, x, px )
  70        res(i+1,j+1) = p_min + px*p_maj
  71      END DO
  72    END DO
  73    RETURN
  74    END SUBROUTINE patchmap
  75
  76    SUBROUTINE region_bounds( region_start, region_end, &
  77                              num_p, p,                 &
  78                              patch_start, patch_end )
  79    ! 1-D decomposition routine: Given starting and ending indices of a
  80    ! vector, the number of patches dividing the vector, and the number of
  81    ! the patch, give the start and ending indices of the patch within the
  82    ! vector.  This will work with tiles too.  Implementation note.  This is
  83    ! implemented somewhat inefficiently, now, with a loop, so we can use the
  84    ! locproc function above, which returns processor number for a given
  85    ! index, whereas what we want is index for a given processor number.
  86    ! With a little thought and a lot of debugging, we can come up with a
  87    ! direct expression for what we want.  For time being, we loop...
  88    ! Remember that processor numbering starts with zero.
  89
  90    IMPLICIT NONE
  91    INTEGER, INTENT(IN)                    :: region_start, region_end, num_p, p
  92    INTEGER, INTENT(OUT)                   :: patch_start, patch_end
  93    INTEGER                                :: offset, i
  94    patch_end = -999999999
  95    patch_start = 999999999
  96    offset = region_start
  97    do i = 0, region_end - offset
  98      if ( locproc( i, region_end-region_start+1, num_p ) == p ) then
  99        patch_end = max(patch_end,i)
 100        patch_start = min(patch_start,i)
 101      endif
 102    enddo
 103    patch_start = patch_start + offset
 104    patch_end   = patch_end   + offset
 105    RETURN
 106    END SUBROUTINE region_bounds
 107
 108    SUBROUTINE least_aspect( nparts, minparts_y, minparts_x, nparts_y, nparts_x )
 109    IMPLICIT NONE
 110    !  Input data.
 111    INTEGER, INTENT(IN)           :: nparts,                &
 112                                     minparts_y, minparts_x
 113    ! Output data.
 114    INTEGER, INTENT(OUT)          :: nparts_y, nparts_x
 115    ! Local data.
 116    INTEGER                       :: x, y, mini
 117    mini = 2*nparts
 118    nparts_y = 1
 119    nparts_x = nparts
 120    DO y = 1, nparts
 121       IF ( mod( nparts, y ) .eq. 0 ) THEN
 122          x = nparts / y
 123          IF (       abs( y-x ) .LT. mini       &
 124               .AND. y .GE. minparts_y                &
 125               .AND. x .GE. minparts_x    ) THEN
 126             mini = abs( y-x )
 127             nparts_y = y
 128             nparts_x = x
 129          END IF
 130       END IF
 131    END DO
 132    END SUBROUTINE least_aspect
 133
 134    SUBROUTINE init_module_machine
 135      RETURN
 136    END SUBROUTINE init_module_machine
 137
 138 END MODULE module_machine
 139
 140 SUBROUTINE wrf_sizeof_integer( retval )
 141   IMPLICIT NONE
 142   INTEGER retval
 143 ! IWORDSIZE is defined by CPP
 144   retval = IWORDSIZE
 145   RETURN
 146 END SUBROUTINE wrf_sizeof_integer
 147
 148 SUBROUTINE wrf_sizeof_real( retval )
 149   IMPLICIT NONE
 150   INTEGER retval
 151 ! RWORDSIZE is defined by CPP
 152   retval = RWORDSIZE
 153   RETURN
 154 END SUBROUTINE wrf_sizeof_real
 155
 156 SUBROUTINE wrf_sizeof_doubleprecision( retval )
 157   IMPLICIT NONE
 158   INTEGER retval
 159 ! DWORDSIZE is defined by CPP
 160   retval = DWORDSIZE
 161   RETURN
 162 END SUBROUTINE wrf_sizeof_doubleprecision
 163
 164 SUBROUTINE wrf_sizeof_logical( retval )
 165   IMPLICIT NONE
 166   INTEGER retval
 167 ! LWORDSIZE is defined by CPP
 168   retval = LWORDSIZE
 169   RETURN
 170 END SUBROUTINE wrf_sizeof_logical
 171