phys/module_firebrand_spotting_mpi.F

   1 ! MPI functions for lagrangian transport in Module Firebrand Spotting
   2 !
   3 !-------------------------------------------------------------------------------
   4 !
   5 !-------------------------------------------------------------------------------
   6 ! ATTENTION TO:
   7 ! Capitals vs. lower-case: In FORTRAN words use CAPITAL case
   8 ! Indent by 4 spaces
   9 ! Operators: use >, <, >=, <=, == (instead of .GT., .EQ., .GE. etc)
  10 ! Ordering of DO loops for fast memory access:
  11 !     The innermost loop goes over the 1st array dimension (fastest changing dimension)
  12 !     do j = 1, Jend; do k = 1, Kend; do i = 1, Iend; A(i, k, j); end do; end do; end do
  13 !-------------------------------------------------------------------------------
  14
  15 MODULE module_firebrand_spotting_mpi
  16
  17     USE module_domain,       ONLY : get_ijk_from_grid, domain               ! grid
  18     USE module_configure,    ONLY : grid_config_rec_type                    ! config_flags
  19     !USE module_symbols_util, ONLY : WRFU_TimeInterval, WRFU_TimeIntervalGet, WRFU_TimeIntervalSet
  20 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
  21     USE MPI
  22 #endif
  23     IMPLICIT NONE
  24
  25     PRIVATE
  26
  27 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
  28     PUBLIC &
  29         ! Module Variables:
  30         neighbors, my_id, task_id, mpiprocs, &
  31         left_id, right_id, up_id, down_id, &
  32         upleft_id, upright_id, downleft_id, downright_id, &
  33         ! Functions:
  34         fs_mpi_recvfrompatch_real, &
  35         fs_mpi_recvfrompatch_int, &
  36         fs_mpi_recvbuffsize, &
  37         fs_mpi_recvbuff1_real, &
  38         fs_mpi_recvbuff1_int, &
  39         fs_mpi_checkreceive, &
  40         ! Subroutines:
  41         fs_mpi_send2neighbors, & ! (task_id, mask, p_x, p_y, p_z, fs_p_m, fs_p_d, fs_p_e, fs_p_t, fs_p_v, p_id, p_dt)
  42         fs_mpi_init, &
  43         fs_mpi_nothing2send, &
  44         fs_mpi_recv, & ! (np_id, task_id, r_x, r_y, r_z, r_p_m, r_p_d, r_p_e, r_p_t, r_p_v, r_id, r_dt)
  45         fs_mpi_sendbuff_real, &
  46         fs_mpi_sendbuff_int, &
  47         fs_mpi_sendbuffsize, &
  48         fs_mpi_sendbuff1_real, &
  49         fs_mpi_sendbuff1_int
  50 #endif
  51
  52     ! THESE VARIABLES ARE IN MODULE SCOPE ! Careful with reassignments - don't reassign
  53     ! SAVE attribute is default
  54
  55     !-------------------------------------------------------------------------------
  56     ! variables in module scope: private, only available module-wide (host association)
  57     !-------------------------------------------------------------------------------
  58     ! They should not be declared again in suboutines (may not compile)
  59     !  and must not be among routine dummy arguments. Consequently, cannot be IO variables
  60     !
  61     ! Runtime variables are not available at module level (e.g., namelist, tile dependent variables).
  62     ! Include here only what can be set during compilation:
  63     ! fixed parameters, allocatables, declarions (without initialization)
  64
  65     !-------------------------------------------------------------------------------
  66     ! Fixed parameters ***MODULE SCOPE***
  67     !-------------------------------------------------------------------------------
  68
  69 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
  70     INTEGER, PARAMETER :: wrfdbg = 0
  71
  72     INTEGER, PARAMETER :: dp = KIND(0.d0)      ! double precision
  73     REAL,    PARAMETER :: ZERO_dp = 0.0_dp ! this is a real type variable, not a double precision type
  74     REAL,    PARAMETER :: dp05 = 0.5_dp
  75     REAL,    PARAMETER :: dp1 = 1.0_dp
  76
  77     !-------------------------------------------------------------------------------
  78     ! Generic variables for multiple use within module ***MODULE SCOPE***
  79     !-------------------------------------------------------------------------------
  80
  81     CHARACTER (LEN=200), SAVE     :: msg
  82     CHARACTER (LEN=256), SAVE     :: fmt
  83     CHARACTER (LEN=200), DIMENSION(10) :: amsg
  84     INTEGER, SAVE :: imsg ! loop counters
  85
  86     !-------------------------------------------------------------------------------
  87     ! MPI variables - Move particles between tiles - ***MODULE SCOPE***
  88     !-------------------------------------------------------------------------------
  89
  90     INTEGER, PARAMETER :: neighbors = 8 ! number of neighbor tasks - includes diagonals
  91     INTEGER, PARAMETER :: mpi_datapack_nreal = 8 ! number of real type arrays packed together: 3 (xyz) + 5 (p_properties)
  92     INTEGER, PARAMETER :: mpi_datapack_nint = 3  ! number of integer type arrays packed together 2 (id, src, dt)
  93
  94     INTEGER, SAVE :: my_id, left_id, right_id, up_id, down_id
  95     INTEGER, SAVE :: upleft_id, upright_id, downleft_id, downright_id
  96     INTEGER, SAVE, DIMENSION(neighbors) :: task_id
  97
  98     INTEGER, SAVE :: mpiprocs = 0
  99     !-------------------------------------------------------------------------------
 100     ! grid and cf are not here because dimensions are given at runtime (derived types)
 101     ! grid values change at every interaction,
 102     ! therefore, it needs to be a dummy argument
 103     !-------------------------------------------------------------------------------
 104
 105     !-------------------------------------------------------------------------------
 106     ! Variable bounds - Initialized in init, used in dummy arguments in driver
 107     ! ***MODULE SCOPE***
 108     !-------------------------------------------------------------------------------
 109     INTEGER, SAVE :: ids, jds, ide, jde, kde      ! domain bounds
 110     INTEGER, SAVE :: ims, jms, ime, jme, kms, kme ! memory bounds
 111     INTEGER, SAVE :: is, ie, js, je, ks, ke       ! patch start/end
 112     INTEGER, SAVE :: ifps, jfps, ifpe, jfpe       ! refined fire grid bounds
 113 #endif
 114
 115 CONTAINS
 116 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
 117 !=============================================================
 118 !=============================================================
 119
 120
 121 !******************************************************************
 122 !******************************************************************
 123 !*                                                                *
 124 !*                         MPI Routines                           *
 125 !*                                                                *
 126 !******************************************************************
 127 !******************************************************************
 128
 129 !=============================================================
 130     FUNCTION fs_mpi_recvfrompatch_real(bsz, fromid) RESULT (buff)
 131 !=============================================================
 132
 133         IMPLICIT NONE
 134
 135         INTEGER, INTENT(IN) :: bsz, fromid
 136         REAL,    DIMENSION(bsz) :: buff ! p_x, p_y, p_z
 137         INTEGER :: ierr, recvtag, ii
 138         INTEGER :: stat(MPI_STATUS_SIZE)
 139
 140         !-------------------------------------------------------------------------------
 141         ! Receive a real type array of size bsz
 142         !-------------------------------------------------------------------------------
 143
 144         buff = ZERO_dp
 145         recvtag = 2000 + fromid ! 2000: tag real type data
 146         CALL mpi_recv(buff, bsz, MPI_FLOAT, fromid, recvtag, MPI_COMM_WORLD, stat, ierr)
 147
 148     END FUNCTION fs_mpi_recvfrompatch_real
 149 !=============================================================
 150 !=============================================================
 151
 152
 153 !=============================================================
 154     FUNCTION fs_mpi_recvfrompatch_int(bsz, fromid) RESULT (buff)
 155 !=============================================================
 156
 157         IMPLICIT NONE
 158         INTEGER, INTENT(IN) :: bsz, fromid
 159         INTEGER, DIMENSION(bsz) :: buff
 160         INTEGER :: ierr, recvtag, ii
 161         INTEGER :: stat(MPI_STATUS_SIZE)
 162
 163         !-------------------------------------------------------------------------------
 164         ! Receive an int type array of size bsz
 165         !-------------------------------------------------------------------------------
 166
 167         buff = 0
 168         recvtag = 3000 + fromid ! 3000: tag int type data
 169         CALL mpi_recv(buff, bsz, MPI_INTEGER, fromid, recvtag, MPI_COMM_WORLD, stat, ierr)
 170
 171     END FUNCTION fs_mpi_recvfrompatch_int
 172 !=============================================================
 173 !=============================================================
 174
 175
 176 !=============================================================
 177     FUNCTION fs_mpi_recvbuffsize(fromid) RESULT(recvbuffsz)
 178 !=============================================================
 179
 180         IMPLICIT NONE
 181
 182         INTEGER, INTENT(IN) :: fromid
 183         INTEGER :: recvbuffsz
 184         INTEGER :: ierr, recvtag, sz , tag
 185         INTEGER :: stat(MPI_STATUS_SIZE)
 186
 187         !-------------------------------------------------------------------------------
 188         ! Receive the buffer size (zero or nbr)
 189         !-------------------------------------------------------------------------------
 190
 191         recvbuffsz = 0
 192         sz = 1  ! one value corresponding to nbr (must send a number, receive is blocking)
 193         tag = 1000 ! tag for communicating nbr
 194         recvtag = tag + fromid
 195         ierr = 0
 196
 197         !-------------------------------------------------------------------------------
 198         IF (fromid > -1) THEN
 199             CALL mpi_recv(recvbuffsz, sz, MPI_INTEGER, fromid, recvtag, MPI_COMM_WORLD, stat, ierr)
 200         ENDIF
 201
 202         END FUNCTION fs_mpi_recvbuffsize
 203 !=============================================================
 204 !=============================================================
 205
 206 !=============================================================
 207     FUNCTION fs_mpi_recvbuff1_real(fromid) RESULT(recvbuffsz)
 208 !=============================================================
 209
 210         IMPLICIT NONE
 211
 212         INTEGER, INTENT(IN) :: fromid
 213         REAL    :: recvbuffsz
 214         INTEGER :: ierr, recvtag, sz , tag
 215         INTEGER :: stat(MPI_STATUS_SIZE)
 216
 217         !-------------------------------------------------------------------------------
 218         ! Receive a real type scalar
 219         !-------------------------------------------------------------------------------
 220
 221         recvbuffsz = 0
 222         sz = 1  ! one value corresponding to nbr (must send a number, receive is blocking)
 223         tag = 4000 ! tag for communicating nbr
 224         recvtag = tag + fromid
 225         ierr = 0
 226
 227         !-------------------------------------------------------------------------------
 228         !IF (fromid > -1) THEN
 229             CALL mpi_recv(recvbuffsz, sz, MPI_FLOAT, fromid, recvtag, MPI_COMM_WORLD, stat, ierr)
 230         !ENDIF
 231
 232         END FUNCTION fs_mpi_recvbuff1_real
 233 !=============================================================
 234 !=============================================================
 235
 236
 237 !=============================================================
 238     FUNCTION fs_mpi_recvbuff1_int(fromid) RESULT(recvbuffsz)
 239 !=============================================================
 240
 241         IMPLICIT NONE
 242
 243         INTEGER, INTENT(IN) :: fromid
 244         INTEGER :: recvbuffsz
 245         INTEGER :: ierr, recvtag, sz , tag
 246         INTEGER :: stat(MPI_STATUS_SIZE)
 247
 248         !-------------------------------------------------------------------------------
 249         ! Receive a real type scalar
 250         !-------------------------------------------------------------------------------
 251
 252         recvbuffsz = 0
 253         sz = 1  ! one value corresponding to nbr (must send a number, receive is blocking)
 254         tag = 5000 ! tag for communicating nbr
 255         recvtag = tag + fromid
 256         ierr = 0
 257
 258         !-------------------------------------------------------------------------------
 259         !IF (fromid > -1) THEN
 260             CALL mpi_recv(recvbuffsz, sz, MPI_INTEGER, fromid, recvtag, MPI_COMM_WORLD, stat, ierr)
 261         !ENDIF
 262
 263         END FUNCTION fs_mpi_recvbuff1_int
 264 !=============================================================
 265 !=============================================================
 266
 267
 268
 269 !=============================================================
 270     SUBROUTINE fs_mpi_send2neighbors(task_id, mask, p_x, p_y, p_z, p_id, p_src, p_dt, fs_p_m, fs_p_d, fs_p_e, fs_p_t, fs_p_v)
 271 !=============================================================
 272
 273         IMPLICIT NONE
 274
 275         INTEGER, PARAMETER :: np = neighbors ! number or neighbor tasks
 276         INTEGER, PARAMETER :: nreal = mpi_datapack_nreal ! number of real type arrays packed together
 277         INTEGER, PARAMETER :: nint  = mpi_datapack_nint  ! number of integer type arrays packed together
 278
 279         INTEGER, INTENT(IN), DIMENSION(:) :: task_id
 280         LOGICAL, INTENT(IN), DIMENSION(:) :: mask
 281         INTEGER, INTENT(IN), DIMENSION(:) :: p_id, p_dt, p_src
 282         REAL,    INTENT(IN), DIMENSION(:) :: p_x, p_y, p_z, fs_p_m, fs_p_d, fs_p_e, fs_p_t, fs_p_v
 283
 284         LOGICAL, ALLOCATABLE, DIMENSION(:) :: masksendto
 285         LOGICAL, ALLOCATABLE, DIMENSION(:) :: ml, mr, mu, md
 286         INTEGER, ALLOCATABLE, DIMENSION(:) :: p_int
 287         REAL,    ALLOCATABLE, DIMENSION(:) :: p_real
 288
 289         INTEGER :: ierr, nbr, ii, sendto, k
 290
 291         !-------------------------------------------------------------------------------
 292
 293         !task_id = [left_id, right_id, up_id, down_id, upleft_id, upright_id, downleft_id, downright_id]
 294         ALLOCATE(masksendto(SIZE(mask)), ml(SIZE(mask)), mr(SIZE(mask)), mu(SIZE(mask)), md(SIZE(mask)))
 295
 296         ml = .FALSE.
 297         mr = .FALSE.
 298         mu = .FALSE.
 299         md = .FALSE.
 300
 301         ml = (FLOOR(p_x) < is) ! MASK LEFT
 302         mr = (FLOOR(p_x) > ie) ! MASK RIGHT
 303         mu = (FLOOR(p_y) > je) ! MASK UP
 304         md = (FLOOR(p_y) < js) ! MASK DONW
 305
 306         !-------------------------------------------------------------------------------
 307         ! Send to adjacent patch boundaries
 308         !-------------------------------------------------------------------------------
 309
 310         DO ii=1,np
 311             sendto = task_id(ii)
 312
 313             masksendto = .FALSE.
 314
 315             IF (sendto > -1) THEN
 316                 IF (sendto == left_id)  masksendto = ((mask .AND. ml) .AND. (.NOT. ( md .OR. mu) )) ! LEFT
 317                 IF (sendto == right_id) masksendto = ((mask .AND. mr) .AND. (.NOT. ( md .OR. mu) )) ! RIGHT
 318                 IF (sendto == up_id)    masksendto = ((mask .AND. mu) .AND. (.NOT. ( ml .OR. mr) )) ! UP
 319                 IF (sendto == down_id)  masksendto = ((mask .AND. md) .AND. (.NOT. ( ml .OR. mr) )) ! DONW
 320
 321                 IF (sendto == upleft_id)    masksendto = (mask .AND. (mu .AND. ml) ) ! UPLEFT
 322                 IF (sendto == upright_id)   masksendto = (mask .AND. (mu .AND. mr) ) ! UPRIGHT
 323                 IF (sendto == downleft_id)  masksendto = (mask .AND. (md .AND. ml) ) ! DOWNLEFT
 324                 IF (sendto == downright_id) masksendto = (mask .AND. (md .AND. mr) ) ! DOWNRIGHT
 325
 326                 nbr = COUNT(masksendto)
 327
 328                 IF (nbr == 0) &
 329                     CALL fs_mpi_nothing2send(sendto=sendto)
 330
 331                 IF (nbr > 0) THEN
 332
 333                     ! WRITE (msg,'(2(i6,1x))') sendto, nbr
 334                     ! CALL wrf_debug (wrfdbg, 'SPFire_mpi_sendaway sendto_id nbr:  '//msg)
 335
 336                     ALLOCATE(p_real(nreal*nbr), p_int(nint*nbr))
 337
 338                     p_real = [PACK(p_x,masksendto),&
 339                                PACK(p_y,masksendto),&
 340                                PACK(p_z,masksendto),&
 341                                PACK(fs_p_m,masksendto),&
 342                                PACK(fs_p_d,masksendto),&
 343                                PACK(fs_p_e,masksendto),&
 344                                PACK(fs_p_t,masksendto),&
 345                                PACK(fs_p_v,masksendto)]
 346                     p_int  = [PACK(p_id,masksendto),&
 347                               PACK(p_src,masksendto),&
 348                                PACK(p_dt,masksendto)]
 349
 350                     CALL fs_mpi_sendbuffsize(sendto=sendto, nbr=nbr)
 351                     CALL fs_mpi_sendbuff_real(sendto=sendto, bsz=nbr*nreal, buff=p_real)
 352                     CALL fs_mpi_sendbuff_int(sendto=sendto, bsz=nbr*nint, buff=p_int)
 353
 354                     ! DO k=1,MIN(nbr,5)
 355                     !     WRITE(msg,'(3(i6,1x),6(f12.6,1x))') sendto, p_int(k), p_int(k+nbr), p_real(k), p_real(k+nbr), p_real(k+2*nbr), p_real(k+4*nbr), p_real(k+6*nbr), p_real(k+7*nbr)
 356                     !     CALL wrf_debug (wrfdbg, 'SPFire_mpi send  >>> '// msg)
 357                     ! ENDDO
 358
 359
 360                     DEALLOCATE(p_real, p_int)
 361                 ENDIF
 362             ENDIF
 363         ENDDO
 364
 365         DEALLOCATE(masksendto, ml, mr, mu, md)
 366
 367 !=============================================================
 368     END SUBROUTINE fs_mpi_send2neighbors
 369 !=============================================================
 370
 371
 372
 373
 374 !=============================================================
 375     SUBROUTINE fs_mpi_init(grid)
 376 !=============================================================
 377
 378         USE module_dm, ONLY : ntasks_x, ntasks_y, mytask_x, mytask_y ! total tasks in x,y dimensions, this task i,j
 379
 380         IMPLICIT NONE
 381         INCLUDE "mpif.h"
 382
 383         TYPE(domain), INTENT(IN)    :: grid ! input data **Note: Intent IN**
 384
 385         INTEGER :: ierr, numprocs
 386         LOGICAL :: mpi_inited
 387         CHARACTER (LEN=10) :: envval
 388
 389         my_id    = -1
 390         left_id  = -1
 391         right_id = -1
 392         up_id    = -1
 393         down_id  = -1
 394         upleft_id   = -1
 395         upright_id  = -1
 396         downleft_id = -1
 397         downright_id = -1
 398
 399         CALL MPI_INITIALIZED( mpi_inited, ierr)
 400
 401         IF ( .NOT. mpi_inited ) &
 402             CALL wrf_error_fatal( "failed to initialize MPI")
 403
 404         !-------------------------------------------------------------------------------
 405         ! Who am I ?
 406         !-------------------------------------------------------------------------------
 407
 408         CALL MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr)
 409         CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr)
 410         mpiprocs = numprocs ! mpiprocs and my_id are in module scope
 411
 412         WRITE (msg,'(2(i6,1x))') my_id, numprocs
 413         CALL wrf_debug (wrfdbg, 'SPFire_mpi mpi initialized. myid, nproc: '//msg)
 414
 415         ! WRITE (msg,'(4(i6,1x))') ntasks_x, ntasks_y, mytask_x, mytask_y
 416         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi tasks: '//msg)
 417
 418         ! WRITE (msg,'(5(i9,1x))') my_id, is, ie, js, je
 419         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi my_id, tile bounds: '//msg)
 420
 421         ! CALL get_environment_variable ("WRF_NUM_TILES_X",envval, status=ierr)
 422         ! WRITE (msg,'(1(a10,1x))') envval
 423         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi: '//msg)
 424
 425         !-------------------------------------------------------------------------------
 426         ! Who are my neighbors? all neighbors *_id are declared in module scope
 427         !-------------------------------------------------------------------------------
 428
 429         ! get neighbors  (-1 at domain bounds)
 430         down_id = my_id - ntasks_x
 431         up_id =   my_id + ntasks_x
 432         IF( mytask_y == 0) down_id = -1
 433         IF( mytask_y == (ntasks_y-1) ) up_id = -1
 434
 435         downleft_id  = down_id - 1
 436         downright_id = down_id + 1
 437         upleft_id    = up_id - 1
 438         upright_id   = up_id + 1
 439
 440         IF (down_id == -1) downleft_id  = -1
 441         IF (down_id == -1) downright_id = -1
 442         IF (up_id == -1)   upleft_id    = -1
 443         IF (up_id == -1)   upright_id   = -1
 444
 445         left_id = my_id - 1
 446         right_id = my_id + 1
 447         IF( mytask_x == 0) left_id = -1
 448         IF( mytask_x == (ntasks_x-1) ) right_id =-1
 449
 450         IF (left_id == -1)  downleft_id  = -1
 451         IF (left_id == -1)  upleft_id    = -1
 452         IF (right_id == -1) downright_id = -1
 453         IF (right_id == -1) upright_id   = -1
 454
 455         ! WRITE (msg,'(5(i6,1x))') my_id, left_id, right_id, up_id, down_id
 456         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi   id, L, R, U, D:     '//msg)
 457
 458         ! WRITE (msg,'(4(i6,1x))') downleft_id, downright_id, upleft_id, upright_id
 459         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi diag, DL, DR, UL, UR: '//msg)
 460
 461         ! task_id is in module scope
 462         task_id = [left_id, right_id, up_id, down_id, upleft_id, upright_id, downleft_id, downright_id]
 463
 464
 465         ! row and column of the current process within the domain:
 466         ! left_right ( 0 : ntasks_x -1 )
 467         ! up_down    ( 0 : ntasks_y    -1 )
 468
 469         ! my_task_i = MOD(my_id , ntasks_x)
 470         ! my_task_j = my_id / ntasks_x
 471
 472         !-------------------------------------------------------------------------------
 473         ! Set bounds for finding the tiles to send and receive
 474         ! *** variables declared in MODULE SCOPE ***
 475         !-------------------------------------------------------------------------------
 476
 477         CALL get_local_ijk(grid, &
 478                            ips=is,  jps=js,  ipe=ie,  jpe=je,  kps=ks,  kpe=ke)
 479
 480         ! WRITE (msg,'(6(i6,1x))') is, ie, js, je, ks, ke
 481         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi_init tile bounds: '//msg)
 482
 483     END SUBROUTINE fs_mpi_init
 484 !=============================================================
 485 !=============================================================
 486
 487
 488
 489 !=============================================================
 490     SUBROUTINE fs_mpi_nothing2send(sendto)
 491 !=============================================================
 492
 493         IMPLICIT NONE
 494
 495         INTEGER, INTENT(IN) :: sendto
 496         INTEGER :: ierr, tag, nbr, sz
 497
 498         !-------------------------------------------------------------------------------
 499         ! Send a signal with value zero
 500         !-------------------------------------------------------------------------------
 501
 502         sz = 1 ! one value corresponding to nbr (must send a number, receive is blocking)
 503         nbr = 0
 504         tag = 1000 + my_id ! tag for communicating nbr
 505
 506         IF (sendto > -1) THEN
 507             CALL mpi_send(nbr, sz, MPI_INTEGER, sendto, tag, MPI_COMM_WORLD, ierr)
 508         ENDIF
 509
 510     END SUBROUTINE fs_mpi_nothing2send
 511
 512 !=============================================================
 513 !=============================================================
 514
 515
 516 !=============================================================
 517     FUNCTION fs_mpi_checkreceive(task_list, np) RESULT(buffsz)
 518 !=============================================================
 519
 520         IMPLICIT NONE
 521
 522         INTEGER  :: np
 523         INTEGER, DIMENSION(np) :: buffsz
 524         INTEGER, INTENT(IN), DIMENSION(:) :: task_list
 525         INTEGER :: ii, tmp2
 526
 527         buffsz(:) = 0
 528
 529         !-------------------------------------------------------------------------------
 530         ! Anything to receive from any tile?
 531         !-------------------------------------------------------------------------------
 532
 533         DO ii=1,np
 534             tmp2 = 0
 535             tmp2 = fs_mpi_recvbuffsize(fromid=task_list(ii))
 536             buffsz(ii) = tmp2
 537         ENDDO
 538
 539     END FUNCTION fs_mpi_checkreceive
 540
 541 !=============================================================
 542 !=============================================================
 543
 544
 545 !=============================================================
 546         SUBROUTINE fs_mpi_recv(np_id, task_id, r_x, r_y, r_z, r_p_m, r_p_d, r_p_e, r_p_t, r_p_v, r_id, r_src, r_dt)
 547 !=============================================================
 548
 549         IMPLICIT NONE
 550
 551         INTEGER, PARAMETER :: nreal = mpi_datapack_nreal ! number of real type arrays packed together
 552         INTEGER, PARAMETER :: nint  = mpi_datapack_nint  ! number of integer type arrays packed together
 553         INTEGER, PARAMETER :: np = neighbors
 554
 555         INTEGER, INTENT(IN), DIMENSION(:) :: task_id, np_id
 556         REAL,    INTENT(OUT),DIMENSION(:) :: r_x, r_y, r_z
 557         INTEGER, INTENT(OUT),DIMENSION(:) :: r_id, r_dt, r_src
 558         REAL,    INTENT(OUT),DIMENSION(:) :: r_p_m, r_p_d, r_p_e, r_p_t, r_p_v
 559
 560         INTEGER :: np_sum, istart, iend, ii
 561         INTEGER, ALLOCATABLE, DIMENSION(:,:) :: arr_int
 562         REAL,    ALLOCATABLE, DIMENSION(:,:) :: arr_real
 563
 564         !-------------------------------------------------------------------------------
 565
 566         np_sum = SUM(np_id)
 567         ALLOCATE(arr_real(np_sum,nreal))
 568         ALLOCATE(arr_int(np_sum, nint))
 569
 570         arr_real = ZERO_dp
 571         arr_int  = 0
 572
 573         ! WRITE (msg,'(8(i4,1x))') (np_id(ii), ii=1,np)
 574         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi_recv_all np_id  >>> '// msg)
 575         ! WRITE (msg,'(8(i4,1x))') (task_id(ii), ii=1,np)
 576         ! CALL wrf_debug (wrfdbg, 'SPFire_mpi_recv_all task_id >>> '// msg)
 577
 578         istart = 1
 579         DO ii=1,np
 580
 581             IF (np_id(ii) > 0) THEN
 582
 583                 iend = istart + np_id(ii) -1
 584
 585                 ! WRITE (msg,'(4(i4,1x))') ii, np_id(ii), istart, iend
 586                 ! CALL wrf_debug (wrfdbg, 'SPFire_mpi recv all id, nbr, istart:iend >>> '// msg)
 587 !                 WRITE (msg,*) SHAPE(arr_real)
 588 !                 CALL wrf_debug (wrfdbg, 'SPFire_mpi_recv_all shape arr_real >>> '// msg)
 589
 590                 arr_real(istart:iend,:) = RESHAPE( &
 591                     fs_mpi_recvfrompatch_real(bsz=np_id(ii)*nreal, fromid=task_id(ii)), &
 592                                                          [np_id(ii),nreal])
 593
 594                 arr_int(istart:iend,:)  = RESHAPE( &
 595                     fs_mpi_recvfrompatch_int(bsz=np_id(ii)*nint, fromid=task_id(ii)), &
 596                                                          [np_id(ii), nint])
 597
 598                 istart = istart + np_id(ii)
 599
 600             ENDIF
 601         ENDDO
 602
 603         r_x = arr_real(:,1)
 604         r_y = arr_real(:,2)
 605         r_z = arr_real(:,3)
 606
 607         r_p_m = arr_real(:,4)
 608         r_p_d = arr_real(:,5)
 609         r_p_e = arr_real(:,6)
 610         r_p_t = arr_real(:,7)
 611         r_p_v = arr_real(:,8)
 612
 613         r_id = arr_int(:,1)
 614         r_src = arr_int(:,2)
 615         r_dt = arr_int(:,3)
 616
 617     END SUBROUTINE fs_mpi_recv
 618
 619 !=============================================================
 620 !=============================================================
 621
 622
 623
 624 !=============================================================
 625     SUBROUTINE fs_mpi_sendbuff_real(bsz, sendto, buff)
 626 !=============================================================
 627
 628         IMPLICIT NONE
 629
 630         INTEGER, INTENT(IN) :: bsz, sendto
 631         REAL,    INTENT(IN), DIMENSION(bsz) :: buff ! p_x, p_y, p_z
 632         INTEGER :: ierr, tag
 633
 634         !-------------------------------------------------------------------------------
 635         ! Send the type-real buffer:
 636         ! a 1-d packed array composed of "nreal" flattened arrays, each of size "nbr"
 637         !-------------------------------------------------------------------------------
 638
 639         ierr = 0
 640         tag = 2000 + my_id ! 2000: tag real type data
 641         CALL mpi_send(buff, bsz, MPI_FLOAT, sendto, tag, MPI_COMM_WORLD, ierr)
 642
 643     END SUBROUTINE fs_mpi_sendbuff_real
 644 !=============================================================
 645
 646 !=============================================================
 647
 648
 649
 650 !=============================================================
 651     SUBROUTINE fs_mpi_sendbuff_int(bsz, sendto, buff)
 652 !=============================================================
 653
 654         IMPLICIT NONE
 655
 656         INTEGER, INTENT(IN) :: bsz, sendto
 657         INTEGER, INTENT(IN), DIMENSION(bsz) :: buff  ! p_id, p_dt
 658         INTEGER :: ierr, tag
 659
 660         !-------------------------------------------------------------------------------
 661         ! Send the integer buffer:
 662         ! a 1-d packed array composed of "nint" flattened arrays, each of size "nbr"
 663         !-------------------------------------------------------------------------------
 664
 665         ierr = 0
 666         tag = 3000 + my_id ! 3000: tag int type data
 667         CALL mpi_send(buff, bsz, MPI_INTEGER, sendto, tag, MPI_COMM_WORLD, ierr)
 668
 669     END SUBROUTINE fs_mpi_sendbuff_int
 670 !=============================================================
 671 !=============================================================
 672
 673
 674
 675 !=============================================================
 676     SUBROUTINE fs_mpi_sendbuffsize(nbr, sendto)
 677 !=============================================================
 678
 679         IMPLICIT NONE
 680
 681         INTEGER, INTENT(IN) :: nbr
 682         INTEGER, INTENT(IN) :: sendto
 683         INTEGER :: ierr, tag, sz
 684
 685         !-------------------------------------------------------------------------------
 686         ! Send an integer scalar or
 687         ! Send the buffer size for an incoming array:
 688         !    the number of elements in each array (real or int) that will be packed into one data buffer
 689         !    and sent over by fs_mpi_sendbuff_real/int
 690         !-------------------------------------------------------------------------------
 691
 692         ierr = 0
 693         sz = 1 ! one value corresponding to nbr (must send a number, receive is blocking)
 694         tag = 1000+my_id ! tag for communicating nbr
 695
 696         CALL mpi_send(nbr, sz, MPI_INTEGER, sendto, tag, MPI_COMM_WORLD, ierr)
 697
 698     END SUBROUTINE fs_mpi_sendbuffsize
 699 !=============================================================
 700 !=============================================================
 701
 702
 703
 704 !=============================================================
 705     SUBROUTINE fs_mpi_sendbuff1_real(nbr, sendto)
 706 !=============================================================
 707
 708         IMPLICIT NONE
 709
 710         REAL,    INTENT(IN) :: nbr
 711         INTEGER, INTENT(IN) :: sendto
 712         INTEGER :: ierr, tag, sz
 713
 714         !-------------------------------------------------------------------------------
 715         ! Send a real type scalar
 716         !-------------------------------------------------------------------------------
 717
 718         ierr = 0
 719         sz = 1 ! one value corresponding to nbr (must send a number, receive is blocking)
 720         tag = 4000+my_id ! tag for communicating nbr
 721
 722         CALL mpi_send(nbr, sz, MPI_FLOAT, sendto, tag, MPI_COMM_WORLD, ierr)
 723
 724     END SUBROUTINE fs_mpi_sendbuff1_real
 725 !=============================================================
 726 !=============================================================
 727
 728
 729 !=============================================================
 730     SUBROUTINE fs_mpi_sendbuff1_int(nbr, sendto)
 731 !=============================================================
 732
 733         IMPLICIT NONE
 734
 735         INTEGER, INTENT(IN) :: nbr
 736         INTEGER, INTENT(IN) :: sendto
 737         INTEGER :: ierr, tag, sz
 738
 739         !-------------------------------------------------------------------------------
 740         ! Send an integer scalar or
 741         ! Send the buffer size for an incoming array:
 742         !    the number of elements in each array (real or int) that will be packed into one data buffer
 743         !    and sent over by fs_mpi_sendbuff_real/int
 744         !-------------------------------------------------------------------------------
 745
 746         ierr = 0
 747         sz = 1 ! one value corresponding to nbr (must send a number, receive is blocking)
 748         tag = 5000+my_id ! tag for communicating nbr
 749
 750         CALL mpi_send(nbr, sz, MPI_INTEGER, sendto, tag, MPI_COMM_WORLD, ierr)
 751
 752     END SUBROUTINE fs_mpi_sendbuff1_int
 753
 754 !=============================================================
 755 !=============================================================
 756
 757 !=============================================================
 758     SUBROUTINE get_local_ijk(grid, ips, ipe, jps, jpe, kps, kpe)
 759 !=============================================================
 760
 761         USE module_domain, ONLY: get_ijk_from_grid
 762
 763         IMPLICIT NONE
 764
 765         TYPE(DOMAIN), INTENT(IN) :: grid
 766         INTEGER,      INTENT(OUT), OPTIONAL :: ips, ipe, jps, jpe, kps, kpe
 767
 768         INTEGER :: iips, iipe, jjps, jjpe, kkps, kkpe
 769         INTEGER :: iims, iime, jjms, jjme, kkms, kkme
 770         INTEGER :: iids, iide, jjds, jjde, kkds, kkde
 771
 772
 773         IF (&
 774             (.NOT. PRESENT(ips)) .AND. &
 775             (.NOT. PRESENT(jps)) .AND. &
 776             (.NOT. PRESENT(kps)) .AND. &
 777             (.NOT. PRESENT(ipe)) .AND. &
 778             (.NOT. PRESENT(jpe)) .AND. &
 779             (.NOT. PRESENT(kpe))) &
 780             CALL wrf_debug ( 1, 'get_local_ijk function is NOT requesting a result' )
 781
 782         CALL get_ijk_from_grid (  grid ,        &
 783             iids, iide, jjds, jjde, kkds, kkde, &
 784             iims, iime, jjms, jjme, kkms, kkme, &
 785             iips, iipe, jjps, jjpe, kkps, kkpe)
 786
 787         IF (PRESENT(ips)) ips = iips
 788         IF (PRESENT(jps)) jps = jjps
 789         IF (PRESENT(kps)) kps = kkps
 790         IF (PRESENT(ipe)) ipe = iipe
 791         IF (PRESENT(jpe)) jpe = jjpe
 792         IF (PRESENT(kpe)) kpe = kkpe
 793
 794     END SUBROUTINE get_local_ijk
 795
 796 !=============================================================
 797 !=============================================================
 798 #endif
 799 END MODULE module_firebrand_spotting_mpi
 800