[3614] | 1 | MODULE icblbc |
---|
| 2 | !!====================================================================== |
---|
| 3 | !! *** MODULE icblbc *** |
---|
| 4 | !! Ocean physics: routines to handle boundary exchanges for icebergs |
---|
| 5 | !!====================================================================== |
---|
[9190] | 6 | !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code |
---|
| 7 | !! - ! 2011-03 (Madec) Part conversion to NEMO form |
---|
| 8 | !! - ! Removal of mapping from another grid |
---|
| 9 | !! - ! 2011-04 (Alderson) Split into separate modules |
---|
| 10 | !! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp |
---|
| 11 | !! - ! 2011-05 (Alderson) MPP and single processor boundary conditions added |
---|
[3614] | 12 | !!---------------------------------------------------------------------- |
---|
[9190] | 13 | |
---|
[3614] | 14 | !!---------------------------------------------------------------------- |
---|
| 15 | !! icb_lbc : - Pass icebergs across cyclic boundaries |
---|
| 16 | !! icb_lbc_mpp : - In MPP pass icebergs from linked list between processors |
---|
| 17 | !! as they advect around |
---|
| 18 | !! - Lagrangian processes cannot be handled by existing NEMO MPP |
---|
| 19 | !! routines because they do not lie on regular jpi,jpj grids |
---|
| 20 | !! - Processor exchanges are handled as in lib_mpp whenever icebergs step |
---|
| 21 | !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) |
---|
| 22 | !! so that iceberg does not exist in more than one processor |
---|
| 23 | !! - North fold exchanges controlled by three arrays: |
---|
| 24 | !! nicbflddest - unique processor numbers that current one exchanges with |
---|
| 25 | !! nicbfldproc - processor number that current grid point exchanges with |
---|
| 26 | !! nicbfldpts - packed i,j point in exchanging processor |
---|
| 27 | !!---------------------------------------------------------------------- |
---|
| 28 | USE par_oce ! ocean parameters |
---|
| 29 | USE dom_oce ! ocean domain |
---|
| 30 | USE in_out_manager ! IO parameters |
---|
| 31 | USE lib_mpp ! MPI code and lk_mpp in particular |
---|
| 32 | USE icb_oce ! define iceberg arrays |
---|
| 33 | USE icbutl ! iceberg utility routines |
---|
| 34 | |
---|
| 35 | IMPLICIT NONE |
---|
| 36 | PRIVATE |
---|
| 37 | |
---|
| 38 | #if defined key_mpp_mpi |
---|
| 39 | |
---|
| 40 | !$AGRIF_DO_NOT_TREAT |
---|
| 41 | INCLUDE 'mpif.h' |
---|
| 42 | !$AGRIF_END_DO_NOT_TREAT |
---|
| 43 | |
---|
| 44 | TYPE, PUBLIC :: buffer |
---|
[9190] | 45 | INTEGER :: size = 0 |
---|
| 46 | REAL(wp), DIMENSION(:,:), POINTER :: data |
---|
[3614] | 47 | END TYPE buffer |
---|
| 48 | |
---|
[9190] | 49 | TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL() |
---|
| 50 | TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL() |
---|
| 51 | TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL() |
---|
| 52 | TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL() |
---|
[3614] | 53 | |
---|
| 54 | ! north fold exchange buffers |
---|
[9190] | 55 | TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() |
---|
[3614] | 56 | |
---|
[9190] | 57 | INTEGER, PARAMETER, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers |
---|
[10679] | 58 | INTEGER, PARAMETER, PRIVATE :: jp_buffer_width = 47+nkounts ! items to store for each berg |
---|
[3614] | 59 | |
---|
| 60 | #endif |
---|
| 61 | |
---|
| 62 | PUBLIC icb_lbc |
---|
| 63 | PUBLIC icb_lbc_mpp |
---|
| 64 | |
---|
| 65 | !!---------------------------------------------------------------------- |
---|
[9598] | 66 | !! NEMO/OCE 4.0 , NEMO Consortium (2018) |
---|
[5215] | 67 | !! $Id$ |
---|
[10068] | 68 | !! Software governed by the CeCILL license (see ./LICENSE) |
---|
[3614] | 69 | !!---------------------------------------------------------------------- |
---|
| 70 | CONTAINS |
---|
| 71 | |
---|
| 72 | SUBROUTINE icb_lbc() |
---|
| 73 | !!---------------------------------------------------------------------- |
---|
| 74 | !! *** SUBROUTINE icb_lbc *** |
---|
| 75 | !! |
---|
| 76 | !! ** Purpose : in non-mpp case need to deal with cyclic conditions |
---|
| 77 | !! including north-fold |
---|
| 78 | !!---------------------------------------------------------------------- |
---|
| 79 | TYPE(iceberg), POINTER :: this |
---|
| 80 | TYPE(point) , POINTER :: pt |
---|
| 81 | INTEGER :: iine |
---|
| 82 | !!---------------------------------------------------------------------- |
---|
| 83 | |
---|
| 84 | !! periodic east/west boundaries |
---|
| 85 | !! ============================= |
---|
| 86 | |
---|
[9667] | 87 | IF( l_Iperio ) THEN |
---|
[3614] | 88 | |
---|
| 89 | this => first_berg |
---|
| 90 | DO WHILE( ASSOCIATED(this) ) |
---|
| 91 | pt => this%current_point |
---|
[10679] | 92 | iine = INT( pt%xi + 0.5_wp ) |
---|
[3614] | 93 | IF( iine > mig(nicbei) ) THEN |
---|
| 94 | pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp |
---|
| 95 | ELSE IF( iine < mig(nicbdi) ) THEN |
---|
| 96 | pt%xi = ricb_left + MOD(pt%xi, 1._wp ) |
---|
| 97 | ENDIF |
---|
| 98 | this => this%next |
---|
| 99 | END DO |
---|
| 100 | ! |
---|
| 101 | ENDIF |
---|
| 102 | |
---|
| 103 | !! north/south boundaries |
---|
| 104 | !! ====================== |
---|
[9667] | 105 | IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') |
---|
[3614] | 106 | ! north fold |
---|
[9667] | 107 | IF( npolj /= 0 ) CALL icb_lbc_nfld() |
---|
[3614] | 108 | ! |
---|
| 109 | END SUBROUTINE icb_lbc |
---|
| 110 | |
---|
| 111 | |
---|
| 112 | SUBROUTINE icb_lbc_nfld() |
---|
| 113 | !!---------------------------------------------------------------------- |
---|
| 114 | !! *** SUBROUTINE icb_lbc_nfld *** |
---|
| 115 | !! |
---|
| 116 | !! ** Purpose : single processor north fold exchange |
---|
| 117 | !!---------------------------------------------------------------------- |
---|
| 118 | TYPE(iceberg), POINTER :: this |
---|
| 119 | TYPE(point) , POINTER :: pt |
---|
| 120 | INTEGER :: iine, ijne, ipts |
---|
| 121 | INTEGER :: iiglo, ijglo |
---|
| 122 | !!---------------------------------------------------------------------- |
---|
| 123 | ! |
---|
| 124 | this => first_berg |
---|
| 125 | DO WHILE( ASSOCIATED(this) ) |
---|
| 126 | pt => this%current_point |
---|
[10679] | 127 | ijne = INT( pt%yj + 0.5_wp ) |
---|
[3614] | 128 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 129 | ! |
---|
[10679] | 130 | iine = INT( pt%xi + 0.5_wp ) |
---|
[3614] | 131 | ipts = nicbfldpts (mi1(iine)) |
---|
| 132 | ! |
---|
| 133 | ! moving across the cut line means both position and |
---|
| 134 | ! velocity must change |
---|
| 135 | ijglo = INT( ipts/nicbpack ) |
---|
| 136 | iiglo = ipts - nicbpack*ijglo |
---|
| 137 | pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) |
---|
| 138 | pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) |
---|
| 139 | pt%uvel = -1._wp * pt%uvel |
---|
| 140 | pt%vvel = -1._wp * pt%vvel |
---|
| 141 | ENDIF |
---|
| 142 | this => this%next |
---|
| 143 | END DO |
---|
| 144 | ! |
---|
| 145 | END SUBROUTINE icb_lbc_nfld |
---|
| 146 | |
---|
| 147 | #if defined key_mpp_mpi |
---|
| 148 | !!---------------------------------------------------------------------- |
---|
| 149 | !! 'key_mpp_mpi' MPI massively parallel processing library |
---|
| 150 | !!---------------------------------------------------------------------- |
---|
| 151 | |
---|
| 152 | SUBROUTINE icb_lbc_mpp() |
---|
| 153 | !!---------------------------------------------------------------------- |
---|
| 154 | !! *** SUBROUTINE icb_lbc_mpp *** |
---|
| 155 | !! |
---|
| 156 | !! ** Purpose : multi processor exchange |
---|
| 157 | !! |
---|
| 158 | !! ** Method : identify direction for exchange, pack into a buffer |
---|
| 159 | !! which is basically a real array and delete from linked list |
---|
| 160 | !! length of buffer is exchanged first with receiving processor |
---|
| 161 | !! then buffer is sent if necessary |
---|
| 162 | !!---------------------------------------------------------------------- |
---|
| 163 | TYPE(iceberg) , POINTER :: tmpberg, this |
---|
| 164 | TYPE(point) , POINTER :: pt |
---|
| 165 | INTEGER :: ibergs_to_send_e, ibergs_to_send_w |
---|
| 166 | INTEGER :: ibergs_to_send_n, ibergs_to_send_s |
---|
| 167 | INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w |
---|
| 168 | INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s |
---|
| 169 | INTEGER :: i, ibergs_start, ibergs_end |
---|
| 170 | INTEGER :: iine, ijne |
---|
| 171 | INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E |
---|
| 172 | REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs |
---|
| 173 | INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 |
---|
| 174 | INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err |
---|
| 175 | INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat |
---|
| 176 | |
---|
| 177 | ! set up indices of neighbouring processors |
---|
| 178 | ipe_N = -1 |
---|
| 179 | ipe_S = -1 |
---|
| 180 | ipe_W = -1 |
---|
| 181 | ipe_E = -1 |
---|
| 182 | IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe |
---|
| 183 | IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea |
---|
| 184 | IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso |
---|
| 185 | IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono |
---|
| 186 | ! |
---|
| 187 | ! at northern line of processors with north fold handle bergs differently |
---|
| 188 | IF( npolj > 0 ) ipe_N = -1 |
---|
| 189 | |
---|
| 190 | ! if there's only one processor in x direction then don't let mpp try to handle periodicity |
---|
| 191 | IF( jpni == 1 ) THEN |
---|
| 192 | ipe_E = -1 |
---|
| 193 | ipe_W = -1 |
---|
| 194 | ENDIF |
---|
| 195 | |
---|
| 196 | IF( nn_verbose_level >= 2 ) THEN |
---|
| 197 | WRITE(numicb,*) 'processor west : ', ipe_W |
---|
| 198 | WRITE(numicb,*) 'processor east : ', ipe_E |
---|
| 199 | WRITE(numicb,*) 'processor north : ', ipe_N |
---|
| 200 | WRITE(numicb,*) 'processor south : ', ipe_S |
---|
| 201 | WRITE(numicb,*) 'processor nimpp : ', nimpp |
---|
| 202 | WRITE(numicb,*) 'processor njmpp : ', njmpp |
---|
| 203 | WRITE(numicb,*) 'processor nbondi: ', nbondi |
---|
| 204 | WRITE(numicb,*) 'processor nbondj: ', nbondj |
---|
| 205 | CALL flush( numicb ) |
---|
| 206 | ENDIF |
---|
| 207 | |
---|
| 208 | ! periodicity is handled here when using mpp when there is more than one processor in |
---|
| 209 | ! the i direction, but it also has to happen when jpni=1 case so this is dealt with |
---|
| 210 | ! in icb_lbc and called here |
---|
| 211 | |
---|
| 212 | IF( jpni == 1 ) CALL icb_lbc() |
---|
| 213 | |
---|
| 214 | ! Note that xi is adjusted when swapping because of periodic condition |
---|
| 215 | |
---|
| 216 | IF( nn_verbose_level > 0 ) THEN |
---|
| 217 | ! store the number of icebergs on this processor at start |
---|
| 218 | ibergs_start = icb_utl_count() |
---|
| 219 | ENDIF |
---|
| 220 | |
---|
| 221 | ibergs_to_send_e = 0 |
---|
| 222 | ibergs_to_send_w = 0 |
---|
| 223 | ibergs_to_send_n = 0 |
---|
| 224 | ibergs_to_send_s = 0 |
---|
| 225 | ibergs_rcvd_from_e = 0 |
---|
| 226 | ibergs_rcvd_from_w = 0 |
---|
| 227 | ibergs_rcvd_from_n = 0 |
---|
| 228 | ibergs_rcvd_from_s = 0 |
---|
| 229 | |
---|
| 230 | IF( ASSOCIATED(first_berg) ) THEN ! Find number of bergs that headed east/west |
---|
| 231 | this => first_berg |
---|
| 232 | DO WHILE (ASSOCIATED(this)) |
---|
| 233 | pt => this%current_point |
---|
[10679] | 234 | iine = INT( pt%xi + 0.5_wp ) |
---|
[3614] | 235 | IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN |
---|
| 236 | tmpberg => this |
---|
| 237 | this => this%next |
---|
| 238 | ibergs_to_send_e = ibergs_to_send_e + 1 |
---|
| 239 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 240 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' |
---|
| 241 | CALL flush( numicb ) |
---|
| 242 | ENDIF |
---|
| 243 | ! deal with periodic case |
---|
[10679] | 244 | tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp |
---|
| 245 | tmpberg%current_point%xRK1(1) = ricb_right + MOD(tmpberg%current_point%xRK1(1), 1._wp ) - 1._wp |
---|
| 246 | tmpberg%current_point%xRK2(1) = ricb_right + MOD(tmpberg%current_point%xRK2(1), 1._wp ) - 1._wp |
---|
| 247 | tmpberg%current_point%xRK3(1) = ricb_right + MOD(tmpberg%current_point%xRK3(1), 1._wp ) - 1._wp |
---|
| 248 | tmpberg%current_point%xRK4(1) = ricb_right + MOD(tmpberg%current_point%xRK4(1), 1._wp ) - 1._wp |
---|
[3614] | 249 | ! now pack it into buffer and delete from list |
---|
| 250 | CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) |
---|
| 251 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 252 | ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN |
---|
| 253 | tmpberg => this |
---|
| 254 | this => this%next |
---|
| 255 | ibergs_to_send_w = ibergs_to_send_w + 1 |
---|
| 256 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 257 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' |
---|
| 258 | CALL flush( numicb ) |
---|
| 259 | ENDIF |
---|
| 260 | ! deal with periodic case |
---|
[10679] | 261 | tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) |
---|
| 262 | tmpberg%current_point%xRK1(1) = ricb_left + MOD(tmpberg%current_point%xRK1(1), 1._wp ) |
---|
| 263 | tmpberg%current_point%xRK2(1) = ricb_left + MOD(tmpberg%current_point%xRK2(1), 1._wp ) |
---|
| 264 | tmpberg%current_point%xRK3(1) = ricb_left + MOD(tmpberg%current_point%xRK3(1), 1._wp ) |
---|
| 265 | tmpberg%current_point%xRK4(1) = ricb_left + MOD(tmpberg%current_point%xRK4(1), 1._wp ) |
---|
[3614] | 266 | ! now pack it into buffer and delete from list |
---|
| 267 | CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) |
---|
| 268 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 269 | ELSE |
---|
| 270 | this => this%next |
---|
| 271 | ENDIF |
---|
| 272 | END DO |
---|
| 273 | ENDIF |
---|
| 274 | IF( nn_verbose_level >= 3) THEN |
---|
| 275 | WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w |
---|
| 276 | CALL flush(numicb) |
---|
| 277 | ENDIF |
---|
| 278 | |
---|
| 279 | ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa |
---|
| 280 | |
---|
| 281 | ! pattern here is copied from lib_mpp code |
---|
| 282 | |
---|
| 283 | SELECT CASE ( nbondi ) |
---|
| 284 | CASE( -1 ) |
---|
| 285 | zwebergs(1) = ibergs_to_send_e |
---|
| 286 | CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) |
---|
[4990] | 287 | CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) |
---|
[3614] | 288 | IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 289 | ibergs_rcvd_from_e = INT( zewbergs(2) ) |
---|
| 290 | CASE( 0 ) |
---|
| 291 | zewbergs(1) = ibergs_to_send_w |
---|
| 292 | zwebergs(1) = ibergs_to_send_e |
---|
| 293 | CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) |
---|
| 294 | CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) |
---|
[4990] | 295 | CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) |
---|
| 296 | CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) |
---|
[3614] | 297 | IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 298 | IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 299 | ibergs_rcvd_from_e = INT( zewbergs(2) ) |
---|
| 300 | ibergs_rcvd_from_w = INT( zwebergs(2) ) |
---|
| 301 | CASE( 1 ) |
---|
| 302 | zewbergs(1) = ibergs_to_send_w |
---|
| 303 | CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) |
---|
[4990] | 304 | CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) |
---|
[3614] | 305 | IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 306 | ibergs_rcvd_from_w = INT( zwebergs(2) ) |
---|
| 307 | END SELECT |
---|
| 308 | IF( nn_verbose_level >= 3) THEN |
---|
| 309 | WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e |
---|
| 310 | CALL flush(numicb) |
---|
| 311 | ENDIF |
---|
| 312 | |
---|
| 313 | SELECT CASE ( nbondi ) |
---|
| 314 | CASE( -1 ) |
---|
| 315 | IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) |
---|
| 316 | IF( ibergs_rcvd_from_e > 0 ) THEN |
---|
| 317 | CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) |
---|
| 318 | CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) |
---|
| 319 | ENDIF |
---|
| 320 | IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 321 | DO i = 1, ibergs_rcvd_from_e |
---|
| 322 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 323 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' |
---|
| 324 | CALL flush( numicb ) |
---|
| 325 | ENDIF |
---|
| 326 | CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) |
---|
| 327 | ENDDO |
---|
| 328 | CASE( 0 ) |
---|
| 329 | IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) |
---|
| 330 | IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) |
---|
| 331 | IF( ibergs_rcvd_from_e > 0 ) THEN |
---|
| 332 | CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) |
---|
| 333 | CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) |
---|
| 334 | ENDIF |
---|
| 335 | IF( ibergs_rcvd_from_w > 0 ) THEN |
---|
| 336 | CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) |
---|
| 337 | CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) |
---|
| 338 | ENDIF |
---|
| 339 | IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 340 | IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 341 | DO i = 1, ibergs_rcvd_from_e |
---|
| 342 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 343 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' |
---|
| 344 | CALL flush( numicb ) |
---|
| 345 | ENDIF |
---|
| 346 | CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) |
---|
| 347 | END DO |
---|
| 348 | DO i = 1, ibergs_rcvd_from_w |
---|
| 349 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 350 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' |
---|
| 351 | CALL flush( numicb ) |
---|
| 352 | ENDIF |
---|
| 353 | CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) |
---|
| 354 | ENDDO |
---|
| 355 | CASE( 1 ) |
---|
| 356 | IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) |
---|
| 357 | IF( ibergs_rcvd_from_w > 0 ) THEN |
---|
| 358 | CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) |
---|
| 359 | CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) |
---|
| 360 | ENDIF |
---|
| 361 | IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 362 | DO i = 1, ibergs_rcvd_from_w |
---|
| 363 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 364 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' |
---|
| 365 | CALL flush( numicb ) |
---|
| 366 | ENDIF |
---|
| 367 | CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) |
---|
| 368 | END DO |
---|
| 369 | END SELECT |
---|
| 370 | |
---|
| 371 | ! Find number of bergs that headed north/south |
---|
| 372 | ! (note: this block should technically go ahead of the E/W recv block above |
---|
| 373 | ! to handle arbitrary orientation of PEs. But for simplicity, it is |
---|
| 374 | ! here to accomodate diagonal transfer of bergs between PEs -AJA) |
---|
| 375 | |
---|
| 376 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 377 | this => first_berg |
---|
| 378 | DO WHILE (ASSOCIATED(this)) |
---|
| 379 | pt => this%current_point |
---|
[10679] | 380 | ijne = INT( pt%yj + 0.5_wp ) |
---|
[3614] | 381 | IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN |
---|
| 382 | tmpberg => this |
---|
| 383 | this => this%next |
---|
| 384 | ibergs_to_send_n = ibergs_to_send_n + 1 |
---|
| 385 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 386 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' |
---|
| 387 | CALL flush( numicb ) |
---|
| 388 | ENDIF |
---|
| 389 | CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) |
---|
| 390 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 391 | ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN |
---|
| 392 | tmpberg => this |
---|
| 393 | this => this%next |
---|
| 394 | ibergs_to_send_s = ibergs_to_send_s + 1 |
---|
| 395 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 396 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' |
---|
| 397 | CALL flush( numicb ) |
---|
| 398 | ENDIF |
---|
| 399 | CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) |
---|
| 400 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 401 | ELSE |
---|
| 402 | this => this%next |
---|
| 403 | ENDIF |
---|
| 404 | END DO |
---|
| 405 | ENDIF |
---|
| 406 | if( nn_verbose_level >= 3) then |
---|
| 407 | write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s |
---|
| 408 | call flush(numicb) |
---|
| 409 | endif |
---|
| 410 | |
---|
| 411 | ! send bergs north |
---|
| 412 | ! and receive bergs from south (ie ones sent north) |
---|
| 413 | |
---|
| 414 | SELECT CASE ( nbondj ) |
---|
| 415 | CASE( -1 ) |
---|
| 416 | zsnbergs(1) = ibergs_to_send_n |
---|
| 417 | CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) |
---|
[4990] | 418 | CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) |
---|
[3614] | 419 | IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 420 | ibergs_rcvd_from_n = INT( znsbergs(2) ) |
---|
| 421 | CASE( 0 ) |
---|
| 422 | znsbergs(1) = ibergs_to_send_s |
---|
| 423 | zsnbergs(1) = ibergs_to_send_n |
---|
| 424 | CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) |
---|
| 425 | CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) |
---|
[4990] | 426 | CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) |
---|
| 427 | CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) |
---|
[3614] | 428 | IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 429 | IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 430 | ibergs_rcvd_from_n = INT( znsbergs(2) ) |
---|
| 431 | ibergs_rcvd_from_s = INT( zsnbergs(2) ) |
---|
| 432 | CASE( 1 ) |
---|
| 433 | znsbergs(1) = ibergs_to_send_s |
---|
| 434 | CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) |
---|
[4990] | 435 | CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) |
---|
[3614] | 436 | IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 437 | ibergs_rcvd_from_s = INT( zsnbergs(2) ) |
---|
| 438 | END SELECT |
---|
| 439 | if( nn_verbose_level >= 3) then |
---|
| 440 | write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n |
---|
| 441 | call flush(numicb) |
---|
| 442 | endif |
---|
| 443 | |
---|
| 444 | SELECT CASE ( nbondj ) |
---|
| 445 | CASE( -1 ) |
---|
| 446 | IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) |
---|
| 447 | IF( ibergs_rcvd_from_n > 0 ) THEN |
---|
| 448 | CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) |
---|
| 449 | CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) |
---|
| 450 | ENDIF |
---|
| 451 | IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 452 | DO i = 1, ibergs_rcvd_from_n |
---|
| 453 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 454 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' |
---|
| 455 | CALL flush( numicb ) |
---|
| 456 | ENDIF |
---|
| 457 | CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) |
---|
| 458 | END DO |
---|
| 459 | CASE( 0 ) |
---|
| 460 | IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) |
---|
| 461 | IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) |
---|
| 462 | IF( ibergs_rcvd_from_n > 0 ) THEN |
---|
| 463 | CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) |
---|
| 464 | CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) |
---|
| 465 | ENDIF |
---|
| 466 | IF( ibergs_rcvd_from_s > 0 ) THEN |
---|
| 467 | CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) |
---|
| 468 | CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) |
---|
| 469 | ENDIF |
---|
| 470 | IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 471 | IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 472 | DO i = 1, ibergs_rcvd_from_n |
---|
| 473 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 474 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' |
---|
| 475 | CALL flush( numicb ) |
---|
| 476 | ENDIF |
---|
| 477 | CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) |
---|
| 478 | END DO |
---|
| 479 | DO i = 1, ibergs_rcvd_from_s |
---|
| 480 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 481 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' |
---|
| 482 | CALL flush( numicb ) |
---|
| 483 | ENDIF |
---|
| 484 | CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) |
---|
| 485 | ENDDO |
---|
| 486 | CASE( 1 ) |
---|
| 487 | IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) |
---|
| 488 | IF( ibergs_rcvd_from_s > 0 ) THEN |
---|
| 489 | CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) |
---|
| 490 | CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) |
---|
| 491 | ENDIF |
---|
| 492 | IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 493 | DO i = 1, ibergs_rcvd_from_s |
---|
| 494 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 495 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' |
---|
| 496 | CALL flush( numicb ) |
---|
| 497 | ENDIF |
---|
| 498 | CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) |
---|
| 499 | END DO |
---|
| 500 | END SELECT |
---|
| 501 | |
---|
| 502 | IF( nn_verbose_level > 0 ) THEN |
---|
| 503 | ! compare the number of icebergs on this processor from the start to the end |
---|
| 504 | ibergs_end = icb_utl_count() |
---|
| 505 | i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & |
---|
| 506 | ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) |
---|
| 507 | IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN |
---|
| 508 | WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' |
---|
| 509 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & |
---|
| 510 | ibergs_end,' on PE',narea |
---|
| 511 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & |
---|
| 512 | ibergs_start,' on PE',narea |
---|
| 513 | WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & |
---|
| 514 | i,' on PE',narea |
---|
| 515 | WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & |
---|
| 516 | ibergs_end-(ibergs_start+i),' on PE',narea |
---|
| 517 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & |
---|
| 518 | ibergs_to_send_n,' on PE',narea |
---|
| 519 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & |
---|
| 520 | ibergs_to_send_s,' on PE',narea |
---|
| 521 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & |
---|
| 522 | ibergs_to_send_e,' on PE',narea |
---|
| 523 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & |
---|
| 524 | ibergs_to_send_w,' on PE',narea |
---|
| 525 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & |
---|
| 526 | ibergs_rcvd_from_n,' on PE',narea |
---|
| 527 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & |
---|
| 528 | ibergs_rcvd_from_s,' on PE',narea |
---|
| 529 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & |
---|
| 530 | ibergs_rcvd_from_e,' on PE',narea |
---|
| 531 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & |
---|
| 532 | ibergs_rcvd_from_w,' on PE',narea |
---|
| 533 | 1000 FORMAT(a,i5,a,i4) |
---|
| 534 | CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') |
---|
| 535 | ENDIF |
---|
| 536 | ENDIF |
---|
| 537 | |
---|
| 538 | ! deal with north fold if we necessary when there is more than one top row processor |
---|
| 539 | ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc |
---|
| 540 | IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) |
---|
| 541 | |
---|
| 542 | IF( nn_verbose_level > 0 ) THEN |
---|
| 543 | i = 0 |
---|
| 544 | this => first_berg |
---|
| 545 | DO WHILE (ASSOCIATED(this)) |
---|
| 546 | pt => this%current_point |
---|
[10679] | 547 | iine = INT( pt%xi + 0.5_wp ) |
---|
| 548 | ijne = INT( pt%yj + 0.5_wp ) |
---|
[3614] | 549 | IF( iine .LT. mig(nicbdi) .OR. & |
---|
| 550 | iine .GT. mig(nicbei) .OR. & |
---|
| 551 | ijne .LT. mjg(nicbdj) .OR. & |
---|
| 552 | ijne .GT. mjg(nicbej)) THEN |
---|
| 553 | i = i + 1 |
---|
[10679] | 554 | WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne, pt%xi, pt%yj |
---|
| 555 | WRITE(numicb,*) 'nimpp, njmpp ', nimpp, njmpp |
---|
| 556 | WRITE(numicb,*) 'nicb di, ei, dj, ej ', nicbdi , nicbei , nicbdj , nicbej |
---|
| 557 | WRITE(numicb,*) 'mijg di, ei, dj, ej ', mig(nicbdi), mig(nicbei), mjg(nicbdj), mjg(nicbej) |
---|
[3614] | 558 | CALL flush( numicb ) |
---|
| 559 | ENDIF |
---|
| 560 | this => this%next |
---|
| 561 | ENDDO ! WHILE |
---|
[10425] | 562 | CALL mpp_sum('icblbc', i) |
---|
[3614] | 563 | IF( i .GT. 0 ) THEN |
---|
| 564 | WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i |
---|
| 565 | CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') |
---|
| 566 | ENDIF ! root_pe |
---|
| 567 | ENDIF ! debug |
---|
| 568 | ! |
---|
| 569 | CALL mppsync() |
---|
| 570 | ! |
---|
| 571 | END SUBROUTINE icb_lbc_mpp |
---|
| 572 | |
---|
| 573 | |
---|
| 574 | SUBROUTINE icb_lbc_mpp_nfld() |
---|
| 575 | !!---------------------------------------------------------------------- |
---|
| 576 | !! *** SUBROUTINE icb_lbc_mpp_nfld *** |
---|
| 577 | !! |
---|
| 578 | !! ** Purpose : north fold treatment in multi processor exchange |
---|
| 579 | !! |
---|
| 580 | !! ** Method : |
---|
| 581 | !!---------------------------------------------------------------------- |
---|
| 582 | TYPE(iceberg) , POINTER :: tmpberg, this |
---|
| 583 | TYPE(point) , POINTER :: pt |
---|
| 584 | INTEGER :: ibergs_to_send |
---|
| 585 | INTEGER :: ibergs_to_rcv |
---|
| 586 | INTEGER :: iiglo, ijglo, jk, jn |
---|
| 587 | INTEGER :: ifldproc, iproc, ipts |
---|
| 588 | INTEGER :: iine, ijne |
---|
[4990] | 589 | INTEGER :: jjn |
---|
| 590 | REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs |
---|
[3614] | 591 | INTEGER :: iml_req1, iml_req2, iml_err |
---|
| 592 | INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat |
---|
| 593 | |
---|
| 594 | ! set up indices of neighbouring processors |
---|
| 595 | |
---|
| 596 | ! nicbfldproc is a list of unique processor numbers that this processor |
---|
| 597 | ! exchanges with (including itself), so we loop over this array; since |
---|
| 598 | ! its of fixed size, the first -1 marks end of list of processors |
---|
| 599 | ! |
---|
[4990] | 600 | nicbfldnsend(:) = 0 |
---|
| 601 | nicbfldexpect(:) = 0 |
---|
| 602 | nicbfldreq(:) = 0 |
---|
| 603 | ! |
---|
| 604 | ! Since each processor may be communicating with more than one northern |
---|
| 605 | ! neighbour, cycle through the sends so that the receive order can be |
---|
| 606 | ! controlled. |
---|
| 607 | ! |
---|
| 608 | ! First compute how many icebergs each active neighbour should expect |
---|
[3614] | 609 | DO jn = 1, jpni |
---|
| 610 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 611 | ifldproc = nicbfldproc(jn) |
---|
[4990] | 612 | nicbfldnsend(jn) = 0 |
---|
| 613 | |
---|
| 614 | ! Find number of bergs that need to be exchanged |
---|
| 615 | ! Pick out exchanges with processor ifldproc |
---|
| 616 | ! if ifldproc is this processor then don't send |
---|
| 617 | ! |
---|
| 618 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 619 | this => first_berg |
---|
| 620 | DO WHILE (ASSOCIATED(this)) |
---|
| 621 | pt => this%current_point |
---|
[10679] | 622 | iine = INT( pt%xi + 0.5_wp ) |
---|
| 623 | ijne = INT( pt%yj + 0.5_wp ) |
---|
[4990] | 624 | iproc = nicbflddest(mi1(iine)) |
---|
| 625 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 626 | IF( iproc == ifldproc ) THEN |
---|
| 627 | ! |
---|
| 628 | IF( iproc /= narea ) THEN |
---|
| 629 | tmpberg => this |
---|
| 630 | nicbfldnsend(jn) = nicbfldnsend(jn) + 1 |
---|
| 631 | ENDIF |
---|
| 632 | ! |
---|
| 633 | ENDIF |
---|
| 634 | ENDIF |
---|
| 635 | this => this%next |
---|
| 636 | END DO |
---|
| 637 | ENDIF |
---|
| 638 | ! |
---|
| 639 | ENDIF |
---|
| 640 | ! |
---|
| 641 | END DO |
---|
| 642 | ! |
---|
| 643 | ! Now tell each active neighbour how many icebergs to expect |
---|
| 644 | DO jn = 1, jpni |
---|
| 645 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 646 | ifldproc = nicbfldproc(jn) |
---|
| 647 | IF( ifldproc == narea ) CYCLE |
---|
| 648 | |
---|
| 649 | zsbergs(0) = narea |
---|
| 650 | zsbergs(1) = nicbfldnsend(jn) |
---|
[10570] | 651 | !IF ( nicbfldnsend(jn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc |
---|
[4990] | 652 | CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) |
---|
| 653 | ENDIF |
---|
| 654 | ! |
---|
| 655 | END DO |
---|
| 656 | ! |
---|
| 657 | ! and receive the heads-up from active neighbours preparing to send |
---|
| 658 | DO jn = 1, jpni |
---|
| 659 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 660 | ifldproc = nicbfldproc(jn) |
---|
| 661 | IF( ifldproc == narea ) CYCLE |
---|
| 662 | |
---|
| 663 | CALL mpprecv( 21, znbergs(1:2), 2 ) |
---|
| 664 | DO jjn = 1,jpni |
---|
| 665 | IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT |
---|
| 666 | END DO |
---|
[10570] | 667 | IF( jjn .GT. jpni .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB ERROR' |
---|
[4990] | 668 | nicbfldexpect(jjn) = INT( znbergs(2) ) |
---|
[10570] | 669 | !IF ( nicbfldexpect(jjn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) |
---|
| 670 | !IF (nn_verbose_level > 0) CALL FLUSH(numicb) |
---|
[4990] | 671 | ENDIF |
---|
| 672 | ! |
---|
| 673 | END DO |
---|
| 674 | ! |
---|
| 675 | ! post the mpi waits if using immediate send protocol |
---|
| 676 | DO jn = 1, jpni |
---|
| 677 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 678 | ifldproc = nicbfldproc(jn) |
---|
| 679 | IF( ifldproc == narea ) CYCLE |
---|
| 680 | |
---|
| 681 | IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) |
---|
| 682 | ENDIF |
---|
| 683 | ! |
---|
| 684 | END DO |
---|
| 685 | |
---|
| 686 | ! |
---|
| 687 | ! Cycle through the icebergs again, this time packing and sending any |
---|
| 688 | ! going through the north fold. They will be expected. |
---|
| 689 | DO jn = 1, jpni |
---|
| 690 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 691 | ifldproc = nicbfldproc(jn) |
---|
[3614] | 692 | ibergs_to_send = 0 |
---|
| 693 | |
---|
| 694 | ! Find number of bergs that need to be exchanged |
---|
| 695 | ! Pick out exchanges with processor ifldproc |
---|
| 696 | ! if ifldproc is this processor then don't send |
---|
| 697 | ! |
---|
| 698 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 699 | this => first_berg |
---|
| 700 | DO WHILE (ASSOCIATED(this)) |
---|
| 701 | pt => this%current_point |
---|
[10679] | 702 | iine = INT( pt%xi + 0.5_wp ) |
---|
| 703 | ijne = INT( pt%yj + 0.5_wp ) |
---|
[3614] | 704 | ipts = nicbfldpts (mi1(iine)) |
---|
| 705 | iproc = nicbflddest(mi1(iine)) |
---|
| 706 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 707 | IF( iproc == ifldproc ) THEN |
---|
| 708 | ! |
---|
| 709 | ! moving across the cut line means both position and |
---|
[10693] | 710 | ! velocity and acceleration must change for icb position but also for intermediaite RK 4th scheme value |
---|
[3614] | 711 | ijglo = INT( ipts/nicbpack ) |
---|
| 712 | iiglo = ipts - nicbpack*ijglo |
---|
[10693] | 713 | pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) ; pt%uvel = -1._wp * pt%uvel |
---|
| 714 | pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) ; pt%vvel = -1._wp * pt%vvel |
---|
| 715 | pt%xRK1(1) = iiglo - ( pt%xRK1(1) - REAL(iine,wp) ) ; pt%xRK1(2:4) = -1._wp * pt%xRK1(2:4) |
---|
| 716 | pt%xRK2(1) = iiglo - ( pt%xRK2(1) - REAL(iine,wp) ) ; pt%xRK2(2:4) = -1._wp * pt%xRK2(2:4) |
---|
| 717 | pt%xRK3(1) = iiglo - ( pt%xRK3(1) - REAL(iine,wp) ) ; pt%xRK3(2:4) = -1._wp * pt%xRK3(2:4) |
---|
| 718 | pt%xRK4(1) = iiglo - ( pt%xRK4(1) - REAL(iine,wp) ) ; pt%xRK4(2:4) = -1._wp * pt%xRK4(2:4) |
---|
| 719 | pt%yRK1(1) = ijglo - ( pt%yRK1(1) - REAL(ijne,wp) ) ; pt%yRK1(2:4) = -1._wp * pt%yRK1(2:4) |
---|
| 720 | pt%yRK2(1) = ijglo - ( pt%yRK2(1) - REAL(ijne,wp) ) ; pt%yRK2(2:4) = -1._wp * pt%yRK2(2:4) |
---|
| 721 | pt%yRK3(1) = ijglo - ( pt%yRK3(1) - REAL(ijne,wp) ) ; pt%yRK3(2:4) = -1._wp * pt%yRK3(2:4) |
---|
| 722 | pt%yRK4(1) = ijglo - ( pt%yRK4(1) - REAL(ijne,wp) ) ; pt%yRK4(2:4) = -1._wp * pt%yRK4(2:4) |
---|
[3614] | 723 | ! |
---|
| 724 | ! now remove berg from list and pack it into a buffer |
---|
| 725 | IF( iproc /= narea ) THEN |
---|
| 726 | tmpberg => this |
---|
| 727 | ibergs_to_send = ibergs_to_send + 1 |
---|
| 728 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 729 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' |
---|
| 730 | CALL flush( numicb ) |
---|
| 731 | ENDIF |
---|
| 732 | CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) |
---|
| 733 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 734 | ENDIF |
---|
| 735 | ! |
---|
| 736 | ENDIF |
---|
| 737 | ENDIF |
---|
| 738 | this => this%next |
---|
| 739 | END DO |
---|
| 740 | ENDIF |
---|
| 741 | if( nn_verbose_level >= 3) then |
---|
| 742 | write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send |
---|
| 743 | call flush(numicb) |
---|
| 744 | endif |
---|
| 745 | ! |
---|
| 746 | ! if we're in this processor, then we've done everything we need to |
---|
| 747 | ! so go on to next element of loop |
---|
| 748 | IF( ifldproc == narea ) CYCLE |
---|
| 749 | |
---|
| 750 | ! send bergs |
---|
| 751 | |
---|
| 752 | IF( ibergs_to_send > 0 ) & |
---|
[4990] | 753 | CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) |
---|
| 754 | ! |
---|
| 755 | ENDIF |
---|
| 756 | ! |
---|
| 757 | END DO |
---|
| 758 | ! |
---|
| 759 | ! Now receive the expected number of bergs from the active neighbours |
---|
| 760 | DO jn = 1, jpni |
---|
| 761 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 762 | ifldproc = nicbfldproc(jn) |
---|
| 763 | IF( ifldproc == narea ) CYCLE |
---|
| 764 | ibergs_to_rcv = nicbfldexpect(jn) |
---|
| 765 | |
---|
[3614] | 766 | IF( ibergs_to_rcv > 0 ) THEN |
---|
| 767 | CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) |
---|
[4990] | 768 | CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) |
---|
[3614] | 769 | ENDIF |
---|
[4990] | 770 | ! |
---|
[3614] | 771 | DO jk = 1, ibergs_to_rcv |
---|
| 772 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 773 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' |
---|
| 774 | CALL flush( numicb ) |
---|
| 775 | ENDIF |
---|
| 776 | CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) |
---|
| 777 | END DO |
---|
| 778 | ENDIF |
---|
| 779 | ! |
---|
| 780 | END DO |
---|
| 781 | ! |
---|
[4990] | 782 | ! Finally post the mpi waits if using immediate send protocol |
---|
| 783 | DO jn = 1, jpni |
---|
| 784 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 785 | ifldproc = nicbfldproc(jn) |
---|
| 786 | IF( ifldproc == narea ) CYCLE |
---|
| 787 | |
---|
| 788 | IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) |
---|
| 789 | ENDIF |
---|
| 790 | ! |
---|
| 791 | END DO |
---|
| 792 | ! |
---|
[3614] | 793 | END SUBROUTINE icb_lbc_mpp_nfld |
---|
| 794 | |
---|
| 795 | |
---|
| 796 | SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) |
---|
| 797 | !!---------------------------------------------------------------------- |
---|
| 798 | !!---------------------------------------------------------------------- |
---|
| 799 | TYPE(iceberg), POINTER :: berg |
---|
| 800 | TYPE(buffer) , POINTER :: pbuff |
---|
| 801 | INTEGER , INTENT(in) :: kb |
---|
| 802 | ! |
---|
| 803 | INTEGER :: k ! local integer |
---|
| 804 | !!---------------------------------------------------------------------- |
---|
| 805 | ! |
---|
| 806 | IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) |
---|
| 807 | IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) |
---|
[10679] | 808 | IF( kb .GT. pbuff%size ) PRINT *, 'SHOULD NOT SEE THIS' |
---|
[3614] | 809 | |
---|
| 810 | !! pack points into buffer |
---|
| 811 | |
---|
| 812 | pbuff%data( 1,kb) = berg%current_point%lon |
---|
| 813 | pbuff%data( 2,kb) = berg%current_point%lat |
---|
| 814 | pbuff%data( 3,kb) = berg%current_point%uvel |
---|
| 815 | pbuff%data( 4,kb) = berg%current_point%vvel |
---|
| 816 | pbuff%data( 5,kb) = berg%current_point%xi |
---|
| 817 | pbuff%data( 6,kb) = berg%current_point%yj |
---|
| 818 | pbuff%data( 7,kb) = float(berg%current_point%year) |
---|
| 819 | pbuff%data( 8,kb) = berg%current_point%day |
---|
| 820 | pbuff%data( 9,kb) = berg%current_point%mass |
---|
| 821 | pbuff%data(10,kb) = berg%current_point%thickness |
---|
| 822 | pbuff%data(11,kb) = berg%current_point%width |
---|
| 823 | pbuff%data(12,kb) = berg%current_point%length |
---|
| 824 | pbuff%data(13,kb) = berg%current_point%mass_of_bits |
---|
| 825 | pbuff%data(14,kb) = berg%current_point%heat_density |
---|
| 826 | |
---|
[10679] | 827 | pbuff%data(15:18,kb) = berg%current_point%xRK1 |
---|
| 828 | pbuff%data(19:22,kb) = berg%current_point%xRK2 |
---|
| 829 | pbuff%data(23:26,kb) = berg%current_point%xRK3 |
---|
| 830 | pbuff%data(27:30,kb) = berg%current_point%xRK4 |
---|
| 831 | |
---|
| 832 | pbuff%data(31:34,kb) = berg%current_point%yRK1 |
---|
| 833 | pbuff%data(35:38,kb) = berg%current_point%yRK2 |
---|
| 834 | pbuff%data(39:42,kb) = berg%current_point%yRK3 |
---|
| 835 | pbuff%data(43:46,kb) = berg%current_point%yRK4 |
---|
| 836 | |
---|
| 837 | pbuff%data(47,kb) = berg%mass_scaling |
---|
[3614] | 838 | DO k=1,nkounts |
---|
[10679] | 839 | pbuff%data(47+k,kb) = REAL( berg%number(k), wp ) |
---|
[3614] | 840 | END DO |
---|
| 841 | ! |
---|
| 842 | END SUBROUTINE icb_pack_into_buffer |
---|
| 843 | |
---|
| 844 | |
---|
| 845 | SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) |
---|
| 846 | !!---------------------------------------------------------------------- |
---|
| 847 | !!---------------------------------------------------------------------- |
---|
| 848 | TYPE(iceberg), POINTER :: first |
---|
| 849 | TYPE(buffer) , POINTER :: pbuff |
---|
| 850 | INTEGER , INTENT(in) :: kb |
---|
| 851 | ! |
---|
| 852 | TYPE(iceberg) :: currentberg |
---|
| 853 | TYPE(point) :: pt |
---|
| 854 | INTEGER :: ik |
---|
| 855 | !!---------------------------------------------------------------------- |
---|
| 856 | ! |
---|
| 857 | pt%lon = pbuff%data( 1,kb) |
---|
| 858 | pt%lat = pbuff%data( 2,kb) |
---|
| 859 | pt%uvel = pbuff%data( 3,kb) |
---|
| 860 | pt%vvel = pbuff%data( 4,kb) |
---|
| 861 | pt%xi = pbuff%data( 5,kb) |
---|
| 862 | pt%yj = pbuff%data( 6,kb) |
---|
| 863 | pt%year = INT( pbuff%data( 7,kb) ) |
---|
| 864 | pt%day = pbuff%data( 8,kb) |
---|
| 865 | pt%mass = pbuff%data( 9,kb) |
---|
| 866 | pt%thickness = pbuff%data(10,kb) |
---|
| 867 | pt%width = pbuff%data(11,kb) |
---|
| 868 | pt%length = pbuff%data(12,kb) |
---|
| 869 | pt%mass_of_bits = pbuff%data(13,kb) |
---|
| 870 | pt%heat_density = pbuff%data(14,kb) |
---|
| 871 | |
---|
[10679] | 872 | pt%xRK1 = pbuff%data(15:18,kb) |
---|
| 873 | pt%xRK2 = pbuff%data(19:22,kb) |
---|
| 874 | pt%xRK3 = pbuff%data(23:26,kb) |
---|
| 875 | pt%xRK4 = pbuff%data(27:30,kb) |
---|
| 876 | |
---|
| 877 | pt%yRK1 = pbuff%data(31:34,kb) |
---|
| 878 | pt%yRK2 = pbuff%data(35:38,kb) |
---|
| 879 | pt%yRK3 = pbuff%data(39:42,kb) |
---|
| 880 | pt%yRK4 = pbuff%data(43:46,kb) |
---|
| 881 | |
---|
| 882 | currentberg%mass_scaling = pbuff%data(47,kb) |
---|
[3614] | 883 | DO ik = 1, nkounts |
---|
[10679] | 884 | currentberg%number(ik) = INT( pbuff%data(47+ik,kb) ) |
---|
[3614] | 885 | END DO |
---|
| 886 | ! |
---|
| 887 | CALL icb_utl_add(currentberg, pt ) |
---|
| 888 | ! |
---|
| 889 | END SUBROUTINE icb_unpack_from_buffer |
---|
| 890 | |
---|
| 891 | |
---|
| 892 | SUBROUTINE icb_increase_buffer(old,kdelta) |
---|
| 893 | !!---------------------------------------------------------------------- |
---|
| 894 | TYPE(buffer), POINTER :: old |
---|
| 895 | INTEGER , INTENT(in) :: kdelta |
---|
| 896 | ! |
---|
| 897 | TYPE(buffer), POINTER :: new |
---|
| 898 | INTEGER :: inew_size |
---|
| 899 | !!---------------------------------------------------------------------- |
---|
| 900 | ! |
---|
| 901 | IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta |
---|
| 902 | ELSE ; inew_size = old%size + kdelta |
---|
| 903 | ENDIF |
---|
| 904 | ALLOCATE( new ) |
---|
| 905 | ALLOCATE( new%data( jp_buffer_width, inew_size) ) |
---|
| 906 | new%size = inew_size |
---|
| 907 | IF( ASSOCIATED(old) ) THEN |
---|
| 908 | new%data(:,1:old%size) = old%data(:,1:old%size) |
---|
| 909 | DEALLOCATE(old%data) |
---|
| 910 | DEALLOCATE(old) |
---|
| 911 | ENDIF |
---|
| 912 | old => new |
---|
| 913 | ! |
---|
| 914 | END SUBROUTINE icb_increase_buffer |
---|
| 915 | |
---|
| 916 | |
---|
| 917 | SUBROUTINE icb_increase_ibuffer(old,kdelta) |
---|
| 918 | !!---------------------------------------------------------------------- |
---|
| 919 | !!---------------------------------------------------------------------- |
---|
| 920 | TYPE(buffer), POINTER :: old |
---|
| 921 | INTEGER , INTENT(in) :: kdelta |
---|
| 922 | ! |
---|
| 923 | TYPE(buffer), POINTER :: new |
---|
| 924 | INTEGER :: inew_size, iold_size |
---|
| 925 | !!---------------------------------------------------------------------- |
---|
| 926 | |
---|
| 927 | IF( .NOT. ASSOCIATED(old) ) THEN |
---|
| 928 | inew_size = kdelta + jp_delta_buf |
---|
| 929 | iold_size = 0 |
---|
| 930 | ELSE |
---|
| 931 | iold_size = old%size |
---|
| 932 | IF( kdelta .LT. old%size ) THEN |
---|
| 933 | inew_size = old%size + kdelta |
---|
| 934 | ELSE |
---|
| 935 | inew_size = kdelta + jp_delta_buf |
---|
| 936 | ENDIF |
---|
| 937 | ENDIF |
---|
| 938 | |
---|
| 939 | IF( iold_size .NE. inew_size ) THEN |
---|
| 940 | ALLOCATE( new ) |
---|
| 941 | ALLOCATE( new%data( jp_buffer_width, inew_size) ) |
---|
| 942 | new%size = inew_size |
---|
| 943 | IF( ASSOCIATED(old) ) THEN |
---|
| 944 | new%data(:,1:old%size) = old%data(:,1:old%size) |
---|
| 945 | DEALLOCATE(old%data) |
---|
| 946 | DEALLOCATE(old) |
---|
| 947 | ENDIF |
---|
| 948 | old => new |
---|
[10570] | 949 | !IF (nn_verbose_level > 0) WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size |
---|
[3614] | 950 | ENDIF |
---|
| 951 | ! |
---|
| 952 | END SUBROUTINE icb_increase_ibuffer |
---|
| 953 | |
---|
| 954 | #else |
---|
| 955 | !!---------------------------------------------------------------------- |
---|
| 956 | !! Default case: Dummy module share memory computing |
---|
| 957 | !!---------------------------------------------------------------------- |
---|
| 958 | SUBROUTINE icb_lbc_mpp() |
---|
| 959 | WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' |
---|
| 960 | END SUBROUTINE icb_lbc_mpp |
---|
| 961 | #endif |
---|
| 962 | |
---|
| 963 | !!====================================================================== |
---|
| 964 | END MODULE icblbc |
---|