Changeset 4683 for palm


Ignore:
Timestamp:
Sep 18, 2020 9:23:09 AM (5 weeks ago)
Author:
pavelkrc
Message:

Add option to limit the size of MPI_Alltoall calls in radiation_model

File:
1 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/radiation_model_mod.f90

    r4679 r4683  
    2828! -----------------
    2929! $Id$
     30! Add option to limit the size of MPI_Alltoall calls
     31!
     32! 4679 2020-09-14 13:53:52Z pavelkrc
    3033! Enable warning about unrealistically large radiative fluxes by default
    3134!
     
    803806
    804807!-- configuration parameters (they can be setup in PALM config)
     808    INTEGER(iwp)                                   ::  bufsize_alltoall = 0               !< max no. of items to send in mpi_alltoall at once (0=infinite)
    805809    LOGICAL                                        ::  raytrace_mpi_rma = .TRUE.          !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
    806810    LOGICAL                                        ::  rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
     
    40094013       NAMELIST /radiation_par/   albedo, albedo_lw_dif, albedo_lw_dir,         &
    40104014                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
     4015                                  bufsize_alltoall,                             &
    40114016                                  constant_albedo, dt_radiation, emissivity,    &
    40124017                                  lw_radiation, max_raytracing_dist,            &
     
    40264031       NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir,    &
    40274032                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
     4033                                  bufsize_alltoall,                             &
    40284034                                  constant_albedo, dt_radiation, emissivity,    &
    40294035                                  lw_radiation, max_raytracing_dist,            &
     
    74097415        IMPLICIT NONE
    74107416
    7411         INTEGER(iwp)                                  :: i, j, k, d, ip, jp
     7417        INTEGER(iwp)                                  :: i, j, k, ip, jp
    74127418        INTEGER(iwp)                                  :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
    74137419        INTEGER(iwp)                                  :: sd, td
     
    74347440        INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
    74357441        INTEGER(iwp), DIMENSION(:,:), POINTER         :: kcsflt,kpcsflt
    7436         INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: icsflt,dcsflt,ipcsflt,dpcsflt
     7442        INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: icsflt
    74377443        REAL(wp), DIMENSION(3)                        :: uv
    74387444        LOGICAL                                       :: visible
     
    82828288            kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
    82838289            ALLOCATE( icsflt(0:numprocs-1) )
    8284             ALLOCATE( dcsflt(0:numprocs-1) )
    8285             ALLOCATE( ipcsflt(0:numprocs-1) )
    8286             ALLOCATE( dpcsflt(0:numprocs-1) )
    82878290
    82888291!--         fill out arrays of csf values and
     
    82908293!--         for particular precessors
    82918294            icsflt = 0
    8292             dcsflt = 0
    82938295            ip = -1
    82948296            j = -1
    8295             d = 0
    82968297            DO kcsf = 1, ncsfl
    82978298                j = j+1
     
    83008301!--                 number of elements of previous block
    83018302                    IF ( ip>=0) icsflt(ip) = j
    8302                     d = d+j
    83038303!--                 blank blocks
    83048304                    DO jp = ip+1, acsf(kcsf)%ip-1
    83058305!--                     number of elements is zero, displacement is equal to previous
    83068306                        icsflt(jp) = 0
    8307                         dcsflt(jp) = d
    83088307                    ENDDO
    83098308!--                 the actual block
    83108309                    ip = acsf(kcsf)%ip
    8311                     dcsflt(ip) = d
    83128310                    j = 0
    83138311                ENDIF
     
    83228320            j = j+1
    83238321            IF ( ip>=0 ) icsflt(ip) = j
    8324             d = d+j
    83258322            DO jp = ip+1, numprocs-1
    83268323!--             number of elements is zero, displacement is equal to previous
    83278324                icsflt(jp) = 0
    8328                 dcsflt(jp) = d
    83298325            ENDDO
    83308326
     
    83408336
    83418337#if defined( __parallel )
    8342 !--         scatter and gather the number of elements to and from all processor
    8343 !--         and calculate displacements
    8344             IF ( debug_output )  CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
    8345 
    8346             CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
    8347 
    8348             IF ( ierr /= 0 ) THEN
    8349                 WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
    8350                 FLUSH(9)
    8351             ENDIF
    8352 
    8353             npcsfl = SUM(ipcsflt)
    8354             d = 0
    8355             DO i = 0, numprocs-1
    8356                 dpcsflt(i) = d
    8357                 d = d + ipcsflt(i)
    8358             ENDDO
    8359 
    8360 !--         exchange csf fields between processors
     8338!
     8339!--         Exchange csf fields between processors
    83618340            IF ( debug_output )  CALL debug_message( 'Exchange CSF fields between processors', 'start' )
    8362             udim = max(npcsfl,1)
    8363             ALLOCATE( pcsflt_l(ndcsf*udim) )
    8364             pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
    8365             ALLOCATE( kpcsflt_l(kdcsf*udim) )
    8366             kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
    8367             CALL MPI_AlltoAllv(csflt_l, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, &
    8368                 pcsflt_l, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr)
    8369             IF ( ierr /= 0 ) THEN
    8370                 WRITE(9,*) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsf*icsflt, &
    8371                             ndcsf*dcsflt, SIZE(pcsflt_l),ndcsf*ipcsflt, ndcsf*dpcsflt
    8372                 FLUSH(9)
    8373             ENDIF
    8374             IF ( debug_output )  CALL debug_message( 'Exchange CSF fields: finished first part', 'info' )
    8375 
    8376             CALL MPI_AlltoAllv(kcsflt_l, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, &
    8377                 kpcsflt_l, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr)
    8378             IF ( ierr /= 0 ) THEN
    8379                 WRITE(9,*) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsf*icsflt, &
    8380                            kdcsf*dcsflt, SIZE(kpcsflt_l), kdcsf*ipcsflt, kdcsf*dpcsflt
    8381                 FLUSH(9)
    8382             ENDIF
     8341
     8342            CALL radiation_exchange_alltoall(icsflt, kdcsf, ndcsf, kcsflt_l, csflt_l,              &
     8343                                             npcsfl, kpcsflt_l, pcsflt_l)
     8344            pcsflt(1:ndcsf,1:npcsfl) => pcsflt_l(0:ndcsf*npcsfl-1)
     8345            kpcsflt(1:kdcsf,1:npcsfl) => kpcsflt_l(0:kdcsf*npcsfl-1)
     8346
    83838347            IF ( debug_output )  CALL debug_message( 'Exchange CSF fields between processors', 'end' )
    83848348
     
    83958359            DEALLOCATE( kcsflt_l )
    83968360            DEALLOCATE( icsflt )
    8397             DEALLOCATE( dcsflt )
    8398             DEALLOCATE( ipcsflt )
    8399             DEALLOCATE( dpcsflt )
    84008361
    84018362!--         sort csf ( a version of quicksort )
     
    100219982
    100229983
     9984!--------------------------------------------------------------------------------------------------!
     9985!
     9986! Description:
     9987! ------------
     9988!> Performs MPI alltoall exchange for integer and floating-point data, optionally splitting the
     9989!> exchange to multiple iterations with maximum number of items per iteration.
     9990!--------------------------------------------------------------------------------------------------!
     9991 SUBROUTINE radiation_exchange_alltoall(ntosend, npint, npfloat, isendbuf, fsendbuf,               &
     9992                                        nrecv, irecvbuf, frecvbuf)
     9993    IMPLICIT NONE
     9994
     9995    INTEGER(iwp), DIMENSION(0:), INTENT(IN)              ::  ntosend  !< number of records to send
     9996                                                                      !< to each process
     9997    INTEGER(iwp), INTENT(IN)                             ::  npint    !< no. of integers in a record
     9998    INTEGER(iwp), INTENT(IN)                             ::  npfloat  !< no. of floats in a record
     9999    INTEGER(iwp), DIMENSION(0:), INTENT(IN)              ::  isendbuf !< send buffer with integers
     10000    REAL(wp), DIMENSION(0:), INTENT(IN)                  ::  fsendbuf !< send buffer with floats
     10001    INTEGER(iwp), INTENT(OUT)                            ::  nrecv    !< total no. of records received
     10002    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, INTENT(OUT) ::  irecvbuf !< int receive buffer (will be
     10003                                                                      !< allocated to proper size
     10004    REAL(wp), DIMENSION(:), ALLOCATABLE, INTENT(OUT)     ::  frecvbuf !< float receive buffer
     10005
     10006    INTEGER(iwp)                            ::  i, j     !< iterators
     10007    INTEGER(iwp)                            ::  iproc    !< process iterator
     10008    INTEGER(iwp)                            ::  iter     !< current iteration
     10009    INTEGER(iwp)                            ::  niters   !< local number of iterations needed
     10010    INTEGER(iwp)                            ::  nitersg  !< global no. of iterations needed
     10011    INTEGER(iwp)                            ::  nmaxsend !< max no. of records sent to each process
     10012                                                         !< in each iteration
     10013    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  drecv    !< received data displacements per proc
     10014    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  drecvnow !< current receive displacements
     10015    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  dsend    !< sent data displacements per process
     10016    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  dsendnow !< current send displacements
     10017    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  nrecvnow !< no. of items to receive in current iteration
     10018    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  nsendnow !< no. of items to send in current iteration
     10019    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  ntorecv  !< no. of records to receive from each process
     10020
     10021    ALLOCATE( ntorecv(0:numprocs-1) )
     10022    ALLOCATE( dsend(0:numprocs) )
     10023    ALLOCATE( drecv(0:numprocs) )
     10024    ALLOCATE( dsendnow(0:numprocs-1) )
     10025    ALLOCATE( drecvnow(0:numprocs-1) )
     10026    ALLOCATE( nsendnow(0:numprocs-1) )
     10027    ALLOCATE( nrecvnow(0:numprocs-1) )
     10028!
     10029!-- Exchange send and receive sizes
     10030    CALL MPI_Alltoall(ntosend, 1, MPI_INTEGER, ntorecv, 1, MPI_INTEGER, comm2d, ierr)
     10031    IF ( ierr /= 0 )  THEN
     10032       WRITE (9,*) 'Error at MPI_Alltoall 1:', ierr, ntosend, ntorecv
     10033       FLUSH (9)
     10034    ENDIF
     10035!
     10036!-- Calculate initial displacements
     10037    i = 0
     10038    j = 0
     10039    DO  iproc = 0, numprocs-1
     10040       dsend(iproc) = i
     10041       dsendnow(iproc) = i
     10042       drecv(iproc) = j
     10043       drecvnow(iproc) = j
     10044       i = i + ntosend(iproc)
     10045       j = j + ntorecv(iproc)
     10046    ENDDO
     10047    dsend(numprocs) = i ! behind last pos = sum of all to send
     10048    drecv(numprocs) = j ! behind last pos = sum of all to receive
     10049    nrecv = j
     10050!
     10051!-- Allocate receive buffers
     10052    ALLOCATE( irecvbuf(0:nrecv*npint-1) )
     10053    ALLOCATE( frecvbuf(0:nrecv*npfloat-1) )
     10054!
     10055!-- Determine number of iterations among all processes
     10056!-- (e.g. this process may have nothing to send and receive, yet some other still might)
     10057    IF ( bufsize_alltoall <= 0 )  THEN
     10058       nitersg = 1
     10059       nmaxsend = HUGE(nitersg)
     10060    ELSE
     10061       nmaxsend = bufsize_alltoall
     10062       niters = (MAXVAL(ntosend(:)) + nmaxsend - 1) / nmaxsend
     10063       CALL MPI_Allreduce(niters, nitersg, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr)
     10064       IF ( nitersg > 1 )  THEN
     10065          WRITE( debug_string, '("The MPI AllToAll call has been split to ' //   &
     10066                               '",I8," iterations of max. ",I12," records ' //   &
     10067                               'each.")' )                                       &
     10068                 nitersg, bufsize_alltoall
     10069          CALL debug_message( debug_string, 'info' )
     10070       ENDIF
     10071    ENDIF
     10072!
     10073!-- Iterate alltoall using max-sized buffers
     10074    DO  iter = 1, nitersg
     10075       nsendnow(:) = MIN(dsend(1:) - dsendnow(:), nmaxsend)
     10076       nrecvnow(:) = MIN(drecv(1:) - drecvnow(:), nmaxsend)
     10077!
     10078!--    Send integer data
     10079       CALL MPI_Alltoallv(isendbuf, nsendnow(:)*npint, dsendnow(:)*npint, MPI_INTEGER,             &
     10080                          irecvbuf, nrecvnow(:)*npint, drecvnow(:)*npint, MPI_INTEGER,             &
     10081                          comm2d, ierr)
     10082       IF ( ierr /= 0 )  THEN
     10083          WRITE (9,*) 'Error at MPI_Alltoallv 1:', ierr, iter, nmaxsend, dsend, dsendnow, nsendnow,&
     10084                                                                         drecv, drecvnow, nrecvnow
     10085          FLUSH (9)
     10086       ENDIF
     10087!
     10088!--    Send floating point data
     10089       CALL MPI_Alltoallv(fsendbuf, nsendnow(:)*npfloat, dsendnow(:)*npfloat, MPI_REAL,            &
     10090                          frecvbuf, nrecvnow(:)*npfloat, drecvnow(:)*npfloat, MPI_REAL,            &
     10091                          comm2d, ierr)
     10092       IF ( ierr /= 0 )  THEN
     10093          WRITE (9,*) 'Error at MPI_Alltoallv 2:', ierr, iter, nmaxsend, dsend, dsendnow, nsendnow,&
     10094                                                                         drecv, drecvnow, nrecvnow
     10095          FLUSH (9)
     10096       ENDIF
     10097!
     10098!--    Shift displacements for next iteration
     10099       dsendnow(:) = dsendnow(:) + nsendnow(:)
     10100       drecvnow(:) = drecvnow(:) + nrecvnow(:)
     10101    ENDDO
     10102
     10103    DEALLOCATE( ntorecv, dsend, drecv, dsendnow, drecvnow, nsendnow, nrecvnow )
     10104 END SUBROUTINE radiation_exchange_alltoall
     10105
    1002310106!------------------------------------------------------------------------------!
    1002410107!
Note: See TracChangeset for help on using the changeset viewer.