- Timestamp:
- 2012-04-18T12:42:56+02:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
r3339 r3359 19 19 !! routines because they do not lie on regular jpi,jpj grids 20 20 !! Processor exchanges are handled as in lib_mpp whenever icebergs step 21 !! across boundary of interior domain ( icbdi-icbei, icbdj-icbej)21 !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) 22 22 !! so that iceberg does not exist in more than one processor 23 23 !! North fold exchanges controlled by three arrays: 24 !! icbflddest - unique processor numbers that current one exchanges with25 !! icbfldproc - processor number that current grid point exchanges with26 !! icbfldpts - packed i,j point in exchanging processor24 !! 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 27 !!---------------------------------------------------------------------- 28 28 … … 56 56 TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() 57 57 58 INTEGER, PARAMETER, PUBLIC :: delta_buf = 25 ! Size by which to increment buffers59 INTEGER, PARAMETER, PUBLIC :: buffer_width = 15+nkounts ! items to store for each berg58 INTEGER, PARAMETER, PUBLIC :: pp_delta_buf = 25 ! Size by which to increment buffers 59 INTEGER, PARAMETER, PUBLIC :: pp_buffer_width = 15+nkounts ! items to store for each berg 60 60 61 61 #endif … … 88 88 TYPE(iceberg), POINTER :: this 89 89 TYPE(point) , POINTER :: pt 90 INTEGER :: i ne90 INTEGER :: iine 91 91 92 92 !! periodic east/west boundaries … … 98 98 DO WHILE( ASSOCIATED(this) ) 99 99 pt => this%current_point 100 i ne = INT( pt%xi + 0.5 )101 IF( i ne .GT. nimpp+icbei-1 ) THEN102 pt%xi = icb_right + MOD(pt%xi, 1._wp ) - 1._wp103 ELSE IF( i ne .LT. nimpp+icbdi-1 ) THEN104 pt%xi = icb_left + MOD(pt%xi, 1._wp )100 iine = INT( pt%xi + 0.5 ) 101 IF( iine .GT. nimpp+nicbei-1 ) THEN 102 pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp 103 ELSE IF( iine .LT. nimpp+nicbdi-1 ) THEN 104 pt%xi = ricb_left + MOD(pt%xi, 1._wp ) 105 105 ENDIF 106 106 this => this%next … … 136 136 TYPE(iceberg), POINTER :: this 137 137 TYPE(point) , POINTER :: pt 138 INTEGER :: i ne, jne, kpts139 INTEGER :: jiglo, jjglo138 INTEGER :: iine, ijne, ipts 139 INTEGER :: iiglo, ijglo 140 140 141 141 this => first_berg 142 142 DO WHILE( ASSOCIATED(this) ) 143 143 pt => this%current_point 144 jne = INT( pt%yj + 0.5 )145 IF( jne .GT. njmpp+icbej-1 ) THEN144 ijne = INT( pt%yj + 0.5 ) 145 IF( ijne .GT. njmpp+nicbej-1 ) THEN 146 146 ! 147 i ne = INT( pt%xi + 0.5 )148 kpts = icbfldpts (ine-nimpp+1)147 iine = INT( pt%xi + 0.5 ) 148 ipts = nicbfldpts (iine-nimpp+1) 149 149 ! 150 150 ! moving across the cut line means both position and 151 151 ! velocity must change 152 jjglo = INT( kpts/icbpack )153 jiglo = kpts - icbpack*jjglo154 pt%xi = jiglo - ( pt%xi - REAL(ine,wp) )155 pt%yj = jjglo - ( pt%yj - REAL(jne,wp) )152 ijglo = INT( ipts/nicbpack ) 153 iiglo = ipts - nicbpack*ijglo 154 pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) 155 pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) 156 156 pt%uvel = -1._wp * pt%uvel 157 157 pt%vvel = -1._wp * pt%vvel … … 181 181 TYPE(iceberg) , POINTER :: tmpberg, this 182 182 TYPE(point) , POINTER :: pt 183 INTEGER :: nbergs_to_send_e, nbergs_to_send_w184 INTEGER :: nbergs_to_send_n, nbergs_to_send_s185 INTEGER :: nbergs_rcvd_from_e, nbergs_rcvd_from_w186 INTEGER :: nbergs_rcvd_from_n, nbergs_rcvd_from_s187 INTEGER :: i, nbergs_start, nbergs_end188 INTEGER :: i ne,jne189 INTEGER :: pe_N, pe_S, pe_W,pe_E190 REAL(wp), DIMENSION(2) :: ewbergs, webergs, nsbergs,snbergs191 INTEGER :: ml_req1, ml_req2, ml_req3,ml_req4192 INTEGER :: ml_req5, ml_req6, ml_req7, ml_req8,ml_err193 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat183 INTEGER :: ibergs_to_send_e, ibergs_to_send_w 184 INTEGER :: ibergs_to_send_n, ibergs_to_send_s 185 INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w 186 INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s 187 INTEGER :: i, ibergs_start, ibergs_end 188 INTEGER :: iine, ijne 189 INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E 190 REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs 191 INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 192 INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err 193 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat 194 194 195 195 ! set up indices of neighbouring processors 196 pe_N = -1197 pe_S = -1198 pe_W = -1199 pe_E = -1200 IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) pe_W = nowe201 IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) pe_E = noea202 IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) pe_S = noso203 IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) pe_N = nono196 ipe_N = -1 197 ipe_S = -1 198 ipe_W = -1 199 ipe_E = -1 200 IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe 201 IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea 202 IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso 203 IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono 204 204 ! 205 205 ! at northern line of processors with north fold handle bergs differently 206 IF( npolj > 0 ) pe_N = -1206 IF( npolj > 0 ) ipe_N = -1 207 207 208 208 ! if there's only one processor in x direction then don't let mpp try to handle periodicity 209 209 IF( jpni == 1 ) THEN 210 pe_E = -1211 pe_W = -1210 ipe_E = -1 211 ipe_W = -1 212 212 ENDIF 213 213 214 214 IF( nn_verbose_level >= 2 ) THEN 215 WRITE(numicb,*) 'processor west : ', pe_W216 WRITE(numicb,*) 'processor east : ', pe_E217 WRITE(numicb,*) 'processor north : ', pe_N218 WRITE(numicb,*) 'processor south : ', pe_S215 WRITE(numicb,*) 'processor west : ', ipe_W 216 WRITE(numicb,*) 'processor east : ', ipe_E 217 WRITE(numicb,*) 'processor north : ', ipe_N 218 WRITE(numicb,*) 'processor south : ', ipe_S 219 219 WRITE(numicb,*) 'processor nimpp : ', nimpp 220 220 WRITE(numicb,*) 'processor njmpp : ', njmpp … … 234 234 IF( nn_verbose_level > 0 ) THEN 235 235 ! store the number of icebergs on this processor at start 236 nbergs_start = count_bergs()237 ENDIF 238 239 nbergs_to_send_e = 0240 nbergs_to_send_w = 0241 nbergs_to_send_n = 0242 nbergs_to_send_s = 0243 nbergs_rcvd_from_e = 0244 nbergs_rcvd_from_w = 0245 nbergs_rcvd_from_n = 0246 nbergs_rcvd_from_s = 0236 ibergs_start = count_bergs() 237 ENDIF 238 239 ibergs_to_send_e = 0 240 ibergs_to_send_w = 0 241 ibergs_to_send_n = 0 242 ibergs_to_send_s = 0 243 ibergs_rcvd_from_e = 0 244 ibergs_rcvd_from_w = 0 245 ibergs_rcvd_from_n = 0 246 ibergs_rcvd_from_s = 0 247 247 248 248 ! Find number of bergs that headed east/west … … 251 251 DO WHILE (ASSOCIATED(this)) 252 252 pt => this%current_point 253 i ne = INT( pt%xi + 0.5 )254 IF( pe_E >= 0 .AND. ine .GT. nimpp+icbei-1 ) THEN253 iine = INT( pt%xi + 0.5 ) 254 IF( ipe_E >= 0 .AND. iine .GT. nimpp+nicbei-1 ) THEN 255 255 tmpberg => this 256 256 this => this%next 257 nbergs_to_send_e = nbergs_to_send_e + 1257 ibergs_to_send_e = ibergs_to_send_e + 1 258 258 IF( nn_verbose_level >= 4 ) THEN 259 WRITE(numicb,*) 'bergstep ', ktberg,' packing berg ',tmpberg%number(:),' for transfer to east'259 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' 260 260 CALL flush( numicb ) 261 261 ENDIF 262 262 ! deal with periodic case 263 tmpberg%current_point%xi = icb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp263 tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp 264 264 ! now pack it into buffer and delete from list 265 CALL pack_berg_into_buffer( tmpberg, obuffer_e, nbergs_to_send_e)265 CALL pack_berg_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) 266 266 CALL delete_iceberg_from_list(first_berg, tmpberg) 267 ELSE IF( pe_W >= 0 .AND. ine .LT. nimpp+icbdi-1 ) THEN267 ELSE IF( ipe_W >= 0 .AND. iine .LT. nimpp+nicbdi-1 ) THEN 268 268 tmpberg => this 269 269 this => this%next 270 nbergs_to_send_w = nbergs_to_send_w + 1270 ibergs_to_send_w = ibergs_to_send_w + 1 271 271 IF( nn_verbose_level >= 4 ) THEN 272 WRITE(numicb,*) 'bergstep ', ktberg,' packing berg ',tmpberg%number(:),' for transfer to west'272 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' 273 273 CALL flush( numicb ) 274 274 ENDIF 275 275 ! deal with periodic case 276 tmpberg%current_point%xi = icb_left + MOD(tmpberg%current_point%xi, 1._wp )276 tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) 277 277 ! now pack it into buffer and delete from list 278 CALL pack_berg_into_buffer( tmpberg, obuffer_w, nbergs_to_send_w)278 CALL pack_berg_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) 279 279 CALL delete_iceberg_from_list(first_berg, tmpberg) 280 280 ELSE … … 284 284 ENDIF 285 285 if( nn_verbose_level >= 3) then 286 write(numicb,*) 'bergstep ', ktberg,' send ew: ', nbergs_to_send_e, nbergs_to_send_w286 write(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w 287 287 call flush(numicb) 288 288 endif … … 295 295 SELECT CASE ( nbondi ) 296 296 CASE( -1 ) 297 webergs(1) = nbergs_to_send_e298 CALL mppsend( 12, webergs(1), 1, pe_E,ml_req1)299 CALL mpprecv( 11, ewbergs(2), 1 )300 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat,ml_err )301 nbergs_rcvd_from_e = INT(ewbergs(2) )297 zwebergs(1) = ibergs_to_send_e 298 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 299 CALL mpprecv( 11, zewbergs(2), 1 ) 300 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 301 ibergs_rcvd_from_e = INT( zewbergs(2) ) 302 302 CASE( 0 ) 303 ewbergs(1) = nbergs_to_send_w304 webergs(1) = nbergs_to_send_e305 CALL mppsend( 11, ewbergs(1), 1, pe_W,ml_req2)306 CALL mppsend( 12, webergs(1), 1, pe_E,ml_req3)307 CALL mpprecv( 11, ewbergs(2), 1 )308 CALL mpprecv( 12, webergs(2), 1 )309 IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat,ml_err )310 IF( l_isend ) CALL mpi_wait( ml_req3, ml_stat,ml_err )311 nbergs_rcvd_from_e = INT(ewbergs(2) )312 nbergs_rcvd_from_w = INT(webergs(2) )303 zewbergs(1) = ibergs_to_send_w 304 zwebergs(1) = ibergs_to_send_e 305 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 306 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 307 CALL mpprecv( 11, zewbergs(2), 1 ) 308 CALL mpprecv( 12, zwebergs(2), 1 ) 309 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 310 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 311 ibergs_rcvd_from_e = INT( zewbergs(2) ) 312 ibergs_rcvd_from_w = INT( zwebergs(2) ) 313 313 CASE( 1 ) 314 ewbergs(1) = nbergs_to_send_w315 CALL mppsend( 11, ewbergs(1), 1, pe_W,ml_req4)316 CALL mpprecv( 12, webergs(2), 1 )317 IF( l_isend ) CALL mpi_wait( ml_req4, ml_stat,ml_err )318 nbergs_rcvd_from_w = INT(webergs(2) )314 zewbergs(1) = ibergs_to_send_w 315 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 316 CALL mpprecv( 12, zwebergs(2), 1 ) 317 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 318 ibergs_rcvd_from_w = INT( zwebergs(2) ) 319 319 END SELECT 320 320 if( nn_verbose_level >= 3) then 321 write(numicb,*) 'bergstep ', ktberg,' recv ew: ', nbergs_rcvd_from_w, nbergs_rcvd_from_e321 write(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e 322 322 call flush(numicb) 323 323 endif … … 325 325 SELECT CASE ( nbondi ) 326 326 CASE( -1 ) 327 IF( nbergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, nbergs_to_send_e*buffer_width, pe_E,ml_req1 )328 IF( nbergs_rcvd_from_e > 0 ) THEN329 CALL increase_ibuffer(ibuffer_e, nbergs_rcvd_from_e)330 CALL mpprecv( 13, ibuffer_e%data, nbergs_rcvd_from_e*buffer_width )331 ENDIF 332 IF( nbergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( ml_req1, ml_stat,ml_err )333 DO i = 1, nbergs_rcvd_from_e327 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*pp_buffer_width, ipe_E, iml_req1 ) 328 IF( ibergs_rcvd_from_e > 0 ) THEN 329 CALL increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 330 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*pp_buffer_width ) 331 ENDIF 332 IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 333 DO i = 1, ibergs_rcvd_from_e 334 334 IF( nn_verbose_level >= 4 ) THEN 335 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'335 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 336 336 CALL flush( numicb ) 337 337 ENDIF … … 339 339 ENDDO 340 340 CASE( 0 ) 341 IF( nbergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, nbergs_to_send_w*buffer_width, pe_W,ml_req2 )342 IF( nbergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, nbergs_to_send_e*buffer_width, pe_E,ml_req3 )343 IF( nbergs_rcvd_from_e > 0 ) THEN344 CALL increase_ibuffer(ibuffer_e, nbergs_rcvd_from_e)345 CALL mpprecv( 13, ibuffer_e%data, nbergs_rcvd_from_e*buffer_width )346 ENDIF 347 IF( nbergs_rcvd_from_w > 0 ) THEN348 CALL increase_ibuffer(ibuffer_w, nbergs_rcvd_from_w)349 CALL mpprecv( 14, ibuffer_w%data, nbergs_rcvd_from_w*buffer_width )350 ENDIF 351 IF( nbergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat,ml_err )352 IF( nbergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( ml_req3, ml_stat,ml_err )353 DO i = 1, nbergs_rcvd_from_e341 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*pp_buffer_width, ipe_W, iml_req2 ) 342 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*pp_buffer_width, ipe_E, iml_req3 ) 343 IF( ibergs_rcvd_from_e > 0 ) THEN 344 CALL increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 345 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*pp_buffer_width ) 346 ENDIF 347 IF( ibergs_rcvd_from_w > 0 ) THEN 348 CALL increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 349 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*pp_buffer_width ) 350 ENDIF 351 IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 352 IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 353 DO i = 1, ibergs_rcvd_from_e 354 354 IF( nn_verbose_level >= 4 ) THEN 355 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'355 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 356 356 CALL flush( numicb ) 357 357 ENDIF 358 358 CALL unpack_berg_from_buffer(first_berg, ibuffer_e, i) 359 359 ENDDO 360 DO i = 1, nbergs_rcvd_from_w360 DO i = 1, ibergs_rcvd_from_w 361 361 IF( nn_verbose_level >= 4 ) THEN 362 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'362 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 363 363 CALL flush( numicb ) 364 364 ENDIF … … 366 366 ENDDO 367 367 CASE( 1 ) 368 IF( nbergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, nbergs_to_send_w*buffer_width, pe_W,ml_req4 )369 IF( nbergs_rcvd_from_w > 0 ) THEN370 CALL increase_ibuffer(ibuffer_w, nbergs_rcvd_from_w)371 CALL mpprecv( 14, ibuffer_w%data, nbergs_rcvd_from_w*buffer_width )372 ENDIF 373 IF( nbergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( ml_req4, ml_stat,ml_err )374 DO i = 1, nbergs_rcvd_from_w368 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*pp_buffer_width, ipe_W, iml_req4 ) 369 IF( ibergs_rcvd_from_w > 0 ) THEN 370 CALL increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 371 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*pp_buffer_width ) 372 ENDIF 373 IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 374 DO i = 1, ibergs_rcvd_from_w 375 375 IF( nn_verbose_level >= 4 ) THEN 376 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'376 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 377 377 CALL flush( numicb ) 378 378 ENDIF … … 390 390 DO WHILE (ASSOCIATED(this)) 391 391 pt => this%current_point 392 jne = INT( pt%yj + 0.5 )393 IF( pe_N >= 0 .AND. jne .GT. njmpp+icbej-1 ) THEN392 ijne = INT( pt%yj + 0.5 ) 393 IF( ipe_N >= 0 .AND. ijne .GT. njmpp+nicbej-1 ) THEN 394 394 tmpberg => this 395 395 this => this%next 396 nbergs_to_send_n = nbergs_to_send_n + 1396 ibergs_to_send_n = ibergs_to_send_n + 1 397 397 IF( nn_verbose_level >= 4 ) THEN 398 WRITE(numicb,*) 'bergstep ', ktberg,' packing berg ',tmpberg%number(:),' for transfer to north'398 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' 399 399 CALL flush( numicb ) 400 400 ENDIF 401 CALL pack_berg_into_buffer( tmpberg, obuffer_n, nbergs_to_send_n)401 CALL pack_berg_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) 402 402 CALL delete_iceberg_from_list(first_berg, tmpberg) 403 ELSE IF( pe_S >= 0 .AND. jne .LT. njmpp+icbdj-1 ) THEN403 ELSE IF( ipe_S >= 0 .AND. ijne .LT. njmpp+nicbdj-1 ) THEN 404 404 tmpberg => this 405 405 this => this%next 406 nbergs_to_send_s = nbergs_to_send_s + 1406 ibergs_to_send_s = ibergs_to_send_s + 1 407 407 IF( nn_verbose_level >= 4 ) THEN 408 WRITE(numicb,*) 'bergstep ', ktberg,' packing berg ',tmpberg%number(:),' for transfer to south'408 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' 409 409 CALL flush( numicb ) 410 410 ENDIF 411 CALL pack_berg_into_buffer( tmpberg, obuffer_s, nbergs_to_send_s)411 CALL pack_berg_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) 412 412 CALL delete_iceberg_from_list(first_berg, tmpberg) 413 413 ELSE … … 417 417 ENDIF 418 418 if( nn_verbose_level >= 3) then 419 write(numicb,*) 'bergstep ', ktberg,' send ns: ', nbergs_to_send_n, nbergs_to_send_s419 write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s 420 420 call flush(numicb) 421 421 endif … … 426 426 SELECT CASE ( nbondj ) 427 427 CASE( -1 ) 428 snbergs(1) = nbergs_to_send_n429 CALL mppsend( 16, snbergs(1), 1, pe_N,ml_req1)430 CALL mpprecv( 15, nsbergs(2), 1 )431 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat,ml_err )432 nbergs_rcvd_from_n = INT(nsbergs(2) )428 zsnbergs(1) = ibergs_to_send_n 429 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 430 CALL mpprecv( 15, znsbergs(2), 1 ) 431 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 432 ibergs_rcvd_from_n = INT( znsbergs(2) ) 433 433 CASE( 0 ) 434 nsbergs(1) = nbergs_to_send_s435 snbergs(1) = nbergs_to_send_n436 CALL mppsend( 15, nsbergs(1), 1, pe_S,ml_req2)437 CALL mppsend( 16, snbergs(1), 1, pe_N,ml_req3)438 CALL mpprecv( 15, nsbergs(2), 1 )439 CALL mpprecv( 16, snbergs(2), 1 )440 IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat,ml_err )441 IF( l_isend ) CALL mpi_wait( ml_req3, ml_stat,ml_err )442 nbergs_rcvd_from_n = INT(nsbergs(2) )443 nbergs_rcvd_from_s = INT(snbergs(2) )434 znsbergs(1) = ibergs_to_send_s 435 zsnbergs(1) = ibergs_to_send_n 436 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 437 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 438 CALL mpprecv( 15, znsbergs(2), 1 ) 439 CALL mpprecv( 16, zsnbergs(2), 1 ) 440 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 441 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 442 ibergs_rcvd_from_n = INT( znsbergs(2) ) 443 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 444 444 CASE( 1 ) 445 nsbergs(1) = nbergs_to_send_s446 CALL mppsend( 15, nsbergs(1), 1, pe_S,ml_req4)447 CALL mpprecv( 16, snbergs(2), 1 )448 IF( l_isend ) CALL mpi_wait( ml_req4, ml_stat,ml_err )449 nbergs_rcvd_from_s = INT(snbergs(2) )445 znsbergs(1) = ibergs_to_send_s 446 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 447 CALL mpprecv( 16, zsnbergs(2), 1 ) 448 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 449 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 450 450 END SELECT 451 451 if( nn_verbose_level >= 3) then 452 write(numicb,*) 'bergstep ', ktberg,' recv ns: ', nbergs_rcvd_from_s, nbergs_rcvd_from_n452 write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n 453 453 call flush(numicb) 454 454 endif … … 456 456 SELECT CASE ( nbondj ) 457 457 CASE( -1 ) 458 IF( nbergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, nbergs_to_send_n*buffer_width, pe_N,ml_req1 )459 IF( nbergs_rcvd_from_n > 0 ) THEN460 CALL increase_ibuffer(ibuffer_n, nbergs_rcvd_from_n)461 CALL mpprecv( 17, ibuffer_n%data, nbergs_rcvd_from_n*buffer_width )462 ENDIF 463 IF( nbergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( ml_req1, ml_stat,ml_err )464 DO i = 1, nbergs_rcvd_from_n458 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*pp_buffer_width, ipe_N, iml_req1 ) 459 IF( ibergs_rcvd_from_n > 0 ) THEN 460 CALL increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 461 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*pp_buffer_width ) 462 ENDIF 463 IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 464 DO i = 1, ibergs_rcvd_from_n 465 465 IF( nn_verbose_level >= 4 ) THEN 466 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'466 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 467 467 CALL flush( numicb ) 468 468 ENDIF … … 470 470 ENDDO 471 471 CASE( 0 ) 472 IF( nbergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, nbergs_to_send_s*buffer_width, pe_S,ml_req2 )473 IF( nbergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, nbergs_to_send_n*buffer_width, pe_N,ml_req3 )474 IF( nbergs_rcvd_from_n > 0 ) THEN475 CALL increase_ibuffer(ibuffer_n, nbergs_rcvd_from_n)476 CALL mpprecv( 17, ibuffer_n%data, nbergs_rcvd_from_n*buffer_width )477 ENDIF 478 IF( nbergs_rcvd_from_s > 0 ) THEN479 CALL increase_ibuffer(ibuffer_s, nbergs_rcvd_from_s)480 CALL mpprecv( 18, ibuffer_s%data, nbergs_rcvd_from_s*buffer_width )481 ENDIF 482 IF( nbergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat,ml_err )483 IF( nbergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( ml_req3, ml_stat,ml_err )484 DO i = 1, nbergs_rcvd_from_n472 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*pp_buffer_width, ipe_S, iml_req2 ) 473 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*pp_buffer_width, ipe_N, iml_req3 ) 474 IF( ibergs_rcvd_from_n > 0 ) THEN 475 CALL increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 476 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*pp_buffer_width ) 477 ENDIF 478 IF( ibergs_rcvd_from_s > 0 ) THEN 479 CALL increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 480 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*pp_buffer_width ) 481 ENDIF 482 IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 483 IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 484 DO i = 1, ibergs_rcvd_from_n 485 485 IF( nn_verbose_level >= 4 ) THEN 486 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'486 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 487 487 CALL flush( numicb ) 488 488 ENDIF 489 489 CALL unpack_berg_from_buffer(first_berg, ibuffer_n, i) 490 490 ENDDO 491 DO i = 1, nbergs_rcvd_from_s491 DO i = 1, ibergs_rcvd_from_s 492 492 IF( nn_verbose_level >= 4 ) THEN 493 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'493 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 494 494 CALL flush( numicb ) 495 495 ENDIF … … 497 497 ENDDO 498 498 CASE( 1 ) 499 IF( nbergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, nbergs_to_send_s*buffer_width, pe_S,ml_req4 )500 IF( nbergs_rcvd_from_s > 0 ) THEN501 CALL increase_ibuffer(ibuffer_s, nbergs_rcvd_from_s)502 CALL mpprecv( 18, ibuffer_s%data, nbergs_rcvd_from_s*buffer_width )503 ENDIF 504 IF( nbergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( ml_req4, ml_stat,ml_err )505 DO i = 1, nbergs_rcvd_from_s499 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*pp_buffer_width, ipe_S, iml_req4 ) 500 IF( ibergs_rcvd_from_s > 0 ) THEN 501 CALL increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 502 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*pp_buffer_width ) 503 ENDIF 504 IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 505 DO i = 1, ibergs_rcvd_from_s 506 506 IF( nn_verbose_level >= 4 ) THEN 507 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'507 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 508 508 CALL flush( numicb ) 509 509 ENDIF … … 514 514 IF( nn_verbose_level > 0 ) THEN 515 515 ! compare the number of icebergs on this processor from the start to the end 516 nbergs_end = count_bergs()517 i = ( nbergs_rcvd_from_n + nbergs_rcvd_from_s + nbergs_rcvd_from_e + nbergs_rcvd_from_w ) - &518 ( nbergs_to_send_n + nbergs_to_send_s + nbergs_to_send_e + nbergs_to_send_w )519 IF( nbergs_end-(nbergs_start+i) .NE. 0 ) THEN516 ibergs_end = count_bergs() 517 i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & 518 ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) 519 IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN 520 520 WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' 521 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_end=', &522 nbergs_end,' on PE',narea523 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_start=', &524 nbergs_start,' on PE',narea521 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & 522 ibergs_end,' on PE',narea 523 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & 524 ibergs_start,' on PE',narea 525 525 WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & 526 526 i,' on PE',narea 527 527 WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & 528 nbergs_end-(nbergs_start+i),' on PE',narea529 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_n=', &530 nbergs_to_send_n,' on PE',narea531 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_s=', &532 nbergs_to_send_s,' on PE',narea533 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_e=', &534 nbergs_to_send_e,' on PE',narea535 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_w=', &536 nbergs_to_send_w,' on PE',narea537 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_n=', &538 nbergs_rcvd_from_n,' on PE',narea539 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_s=', &540 nbergs_rcvd_from_s,' on PE',narea541 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_e=', &542 nbergs_rcvd_from_e,' on PE',narea543 WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_w=', &544 nbergs_rcvd_from_w,' on PE',narea528 ibergs_end-(ibergs_start+i),' on PE',narea 529 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & 530 ibergs_to_send_n,' on PE',narea 531 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & 532 ibergs_to_send_s,' on PE',narea 533 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & 534 ibergs_to_send_e,' on PE',narea 535 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & 536 ibergs_to_send_w,' on PE',narea 537 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & 538 ibergs_rcvd_from_n,' on PE',narea 539 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & 540 ibergs_rcvd_from_s,' on PE',narea 541 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & 542 ibergs_rcvd_from_e,' on PE',narea 543 WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & 544 ibergs_rcvd_from_w,' on PE',narea 545 545 1000 FORMAT(a,i5,a,i4) 546 546 CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') … … 557 557 DO WHILE (ASSOCIATED(this)) 558 558 pt => this%current_point 559 i ne = INT( pt%xi + 0.5 )560 jne = INT( pt%yj + 0.5 )559 iine = INT( pt%xi + 0.5 ) 560 ijne = INT( pt%yj + 0.5 ) 561 561 ! CALL check_position(grd, this, 'exchange (bot)') 562 IF( i ne .LT. nimpp+icbdi-1 .OR. &563 i ne .GT. nimpp+icbei-1 .OR. &564 jne .LT. njmpp+icbdj-1 .OR. &565 jne .GT. njmpp+icbej-1) THEN562 IF( iine .LT. nimpp+nicbdi-1 .OR. & 563 iine .GT. nimpp+nicbei-1 .OR. & 564 ijne .LT. njmpp+nicbdj-1 .OR. & 565 ijne .GT. njmpp+nicbej-1) THEN 566 566 i = i + 1 567 WRITE(numicb,*) 'berg lost in halo: ', this%number(:),i ne,jne567 WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne 568 568 WRITE(numicb,*) ' ', nimpp, njmpp 569 WRITE(numicb,*) ' ', icbdi, icbei, icbdj,icbej569 WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej 570 570 CALL flush( numicb ) 571 571 ENDIF … … 590 590 TYPE(iceberg) , POINTER :: tmpberg, this 591 591 TYPE(point) , POINTER :: pt 592 INTEGER :: nbergs_to_send593 INTEGER :: nbergs_to_rcv594 INTEGER :: jiglo, jjglo, jk, jn595 INTEGER :: jfldproc, kproc, kpts596 INTEGER :: i ne,jne597 REAL(wp), DIMENSION(2) :: sbergs,nbergs598 INTEGER :: ml_req1, ml_req2,ml_err599 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat592 INTEGER :: ibergs_to_send 593 INTEGER :: ibergs_to_rcv 594 INTEGER :: iiglo, ijglo, jk, jn 595 INTEGER :: ifldproc, iproc, ipts 596 INTEGER :: iine, ijne 597 REAL(wp), DIMENSION(2) :: zsbergs, znbergs 598 INTEGER :: iml_req1, iml_req2, iml_err 599 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat 600 600 601 601 ! set up indices of neighbouring processors 602 602 603 ! icbfldproc is a list of unique processor numbers that this processor603 ! nicbfldproc is a list of unique processor numbers that this processor 604 604 ! exchanges with (including itself), so we loop over this array; since 605 605 ! its of fixed size, the first -1 marks end of list of processors 606 606 ! 607 607 DO jn = 1, jpni 608 IF( icbfldproc(jn) == -1 ) EXIT609 jfldproc =icbfldproc(jn)610 nbergs_to_send = 0608 IF( nicbfldproc(jn) == -1 ) EXIT 609 ifldproc = nicbfldproc(jn) 610 ibergs_to_send = 0 611 611 612 612 ! Find number of bergs that need to be exchanged 613 ! Pick out exchanges with processor jfldproc614 ! if jfldproc is this processor then don't send613 ! Pick out exchanges with processor ifldproc 614 ! if ifldproc is this processor then don't send 615 615 ! 616 616 IF( ASSOCIATED(first_berg) ) THEN … … 618 618 DO WHILE (ASSOCIATED(this)) 619 619 pt => this%current_point 620 i ne = INT( pt%xi + 0.5 )621 jne = INT( pt%yj + 0.5 )622 kpts = icbfldpts (ine-nimpp+1)623 kproc = icbflddest(ine-nimpp+1)624 IF( jne .GT. njmpp+icbej-1 ) THEN625 IF( kproc == jfldproc ) THEN620 iine = INT( pt%xi + 0.5 ) 621 ijne = INT( pt%yj + 0.5 ) 622 ipts = nicbfldpts (iine-nimpp+1) 623 iproc = nicbflddest(iine-nimpp+1) 624 IF( ijne .GT. njmpp+nicbej-1 ) THEN 625 IF( iproc == ifldproc ) THEN 626 626 ! 627 627 ! moving across the cut line means both position and 628 628 ! velocity must change 629 jjglo = INT( kpts/icbpack )630 jiglo = kpts - icbpack*jjglo631 pt%xi = jiglo - ( pt%xi - REAL(ine,wp) )632 pt%yj = jjglo - ( pt%yj - REAL(jne,wp) )629 ijglo = INT( ipts/nicbpack ) 630 iiglo = ipts - nicbpack*ijglo 631 pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) 632 pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) 633 633 pt%uvel = -1._wp * pt%uvel 634 634 pt%vvel = -1._wp * pt%vvel 635 635 ! 636 636 ! now remove berg from list and pack it into a buffer 637 IF( kproc /= narea ) THEN637 IF( iproc /= narea ) THEN 638 638 tmpberg => this 639 nbergs_to_send = nbergs_to_send + 1639 ibergs_to_send = ibergs_to_send + 1 640 640 IF( nn_verbose_level >= 4 ) THEN 641 WRITE(numicb,*) 'bergstep ', ktberg,' packing berg ',tmpberg%number(:),' for north fold'641 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' 642 642 CALL flush( numicb ) 643 643 ENDIF 644 CALL pack_berg_into_buffer( tmpberg, obuffer_f, nbergs_to_send)644 CALL pack_berg_into_buffer( tmpberg, obuffer_f, ibergs_to_send) 645 645 CALL delete_iceberg_from_list(first_berg, tmpberg) 646 646 ENDIF … … 652 652 ENDIF 653 653 if( nn_verbose_level >= 3) then 654 write(numicb,*) 'bergstep ', ktberg,' send nfld: ', nbergs_to_send654 write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send 655 655 call flush(numicb) 656 656 endif … … 658 658 ! if we're in this processor, then we've done everything we need to 659 659 ! so go on to next element of loop 660 IF( jfldproc == narea ) CYCLE661 662 sbergs(1) = nbergs_to_send663 CALL mppsend( 21, sbergs(1), 1, jfldproc-1,ml_req1)664 CALL mpprecv( 21, nbergs(2), 1 )665 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat,ml_err )666 nbergs_to_rcv = INT(nbergs(2) )660 IF( ifldproc == narea ) CYCLE 661 662 zsbergs(1) = ibergs_to_send 663 CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1) 664 CALL mpprecv( 21, znbergs(2), 1 ) 665 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 666 ibergs_to_rcv = INT( znbergs(2) ) 667 667 668 668 ! send bergs 669 669 670 IF( nbergs_to_send > 0 ) &671 CALL mppsend( 12, obuffer_f%data, nbergs_to_send*buffer_width, jfldproc-1,ml_req2 )672 IF( nbergs_to_rcv > 0 ) THEN673 CALL increase_ibuffer(ibuffer_f, nbergs_to_rcv)674 CALL mpprecv( 12, ibuffer_f%data, nbergs_to_rcv*buffer_width )675 ENDIF 676 IF( nbergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat,ml_err )677 DO jk = 1, nbergs_to_rcv670 IF( ibergs_to_send > 0 ) & 671 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*pp_buffer_width, ifldproc-1, iml_req2 ) 672 IF( ibergs_to_rcv > 0 ) THEN 673 CALL increase_ibuffer(ibuffer_f, ibergs_to_rcv) 674 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*pp_buffer_width ) 675 ENDIF 676 IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 677 DO jk = 1, ibergs_to_rcv 678 678 IF( nn_verbose_level >= 4 ) THEN 679 WRITE(numicb,*) 'bergstep ', ktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'679 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' 680 680 CALL flush( numicb ) 681 681 ENDIF … … 704 704 !!------------------------------------------------------------------------- 705 705 706 SUBROUTINE dealloc_buffer( buff)706 SUBROUTINE dealloc_buffer(pbuff) 707 707 ! Arguments 708 TYPE(buffer), POINTER :: buff709 710 IF( ASSOCIATED( buff) ) THEN711 IF( ASSOCIATED( buff%data)) DEALLOCATE(buff%data)712 DEALLOCATE( buff)708 TYPE(buffer), POINTER :: pbuff 709 710 IF( ASSOCIATED(pbuff) ) THEN 711 IF( ASSOCIATED(pbuff%data)) DEALLOCATE(pbuff%data) 712 DEALLOCATE(pbuff) 713 713 ENDIF 714 714 END SUBROUTINE dealloc_buffer … … 716 716 !!------------------------------------------------------------------------- 717 717 718 SUBROUTINE pack_berg_into_buffer(berg, buff, n)718 SUBROUTINE pack_berg_into_buffer(berg, pbuff, kb) 719 719 ! Arguments 720 720 TYPE(iceberg), POINTER :: berg 721 TYPE(buffer) , POINTER :: buff722 INTEGER , INTENT(in) :: n721 TYPE(buffer) , POINTER :: pbuff 722 INTEGER , INTENT(in) :: kb 723 723 ! Local 724 724 INTEGER :: k 725 725 726 IF( .NOT. ASSOCIATED( buff) ) CALL increase_buffer( buff,delta_buf )727 IF( n .GT. buff%size ) CALL increase_buffer( buff,delta_buf )726 IF( .NOT. ASSOCIATED(pbuff) ) CALL increase_buffer( pbuff, pp_delta_buf ) 727 IF( kb .GT. pbuff%size ) CALL increase_buffer( pbuff, pp_delta_buf ) 728 728 729 729 !! pack points into buffer 730 730 731 buff%data( 1,n) = berg%current_point%lon732 buff%data( 2,n) = berg%current_point%lat733 buff%data( 3,n) = berg%current_point%uvel734 buff%data( 4,n) = berg%current_point%vvel735 buff%data( 5,n) = berg%current_point%xi736 buff%data( 6,n) = berg%current_point%yj737 buff%data( 7,n) = float(berg%current_point%year)738 buff%data( 8,n) = berg%current_point%day739 buff%data( 9,n) = berg%current_point%mass740 buff%data(10,n) = berg%current_point%thickness741 buff%data(11,n) = berg%current_point%width742 buff%data(12,n) = berg%current_point%length743 buff%data(13,n) = berg%current_point%mass_of_bits744 buff%data(14,n) = berg%current_point%heat_density745 746 buff%data(15,n) = berg%mass_scaling731 pbuff%data( 1,kb) = berg%current_point%lon 732 pbuff%data( 2,kb) = berg%current_point%lat 733 pbuff%data( 3,kb) = berg%current_point%uvel 734 pbuff%data( 4,kb) = berg%current_point%vvel 735 pbuff%data( 5,kb) = berg%current_point%xi 736 pbuff%data( 6,kb) = berg%current_point%yj 737 pbuff%data( 7,kb) = float(berg%current_point%year) 738 pbuff%data( 8,kb) = berg%current_point%day 739 pbuff%data( 9,kb) = berg%current_point%mass 740 pbuff%data(10,kb) = berg%current_point%thickness 741 pbuff%data(11,kb) = berg%current_point%width 742 pbuff%data(12,kb) = berg%current_point%length 743 pbuff%data(13,kb) = berg%current_point%mass_of_bits 744 pbuff%data(14,kb) = berg%current_point%heat_density 745 746 pbuff%data(15,kb) = berg%mass_scaling 747 747 DO k=1,nkounts 748 buff%data(15+k,n) = REAL( berg%number(k), wp )748 pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) 749 749 END DO 750 750 … … 753 753 !!------------------------------------------------------------------------- 754 754 755 SUBROUTINE unpack_berg_from_buffer(first, buff, n)755 SUBROUTINE unpack_berg_from_buffer(first, pbuff, kb) 756 756 ! Arguments 757 757 TYPE(iceberg), POINTER :: first 758 TYPE(buffer) , POINTER :: buff759 INTEGER , INTENT(in) :: n758 TYPE(buffer) , POINTER :: pbuff 759 INTEGER , INTENT(in) :: kb 760 760 ! Local variables 761 LOGICAL :: lres762 761 TYPE(iceberg) :: currentberg 763 762 TYPE(point) :: pt 764 INTEGER ::k765 766 pt%lon = buff%data( 1,n)767 pt%lat = buff%data( 2,n)768 pt%uvel = buff%data( 3,n)769 pt%vvel = buff%data( 4,n)770 pt%xi = buff%data( 5,n)771 pt%yj = buff%data( 6,n)772 pt%year = INT( buff%data( 7,n) )773 pt%day = buff%data( 8,n)774 pt%mass = buff%data( 9,n)775 pt%thickness = buff%data(10,n)776 pt%width = buff%data(11,n)777 pt%length = buff%data(12,n)778 pt%mass_of_bits = buff%data(13,n)779 pt%heat_density = buff%data(14,n)780 781 currentberg%mass_scaling = buff%data(15,n)782 DO k=1,nkounts783 currentberg%number( k) = INT( buff%data(15+k,n) )763 INTEGER :: ik 764 765 pt%lon = pbuff%data( 1,kb) 766 pt%lat = pbuff%data( 2,kb) 767 pt%uvel = pbuff%data( 3,kb) 768 pt%vvel = pbuff%data( 4,kb) 769 pt%xi = pbuff%data( 5,kb) 770 pt%yj = pbuff%data( 6,kb) 771 pt%year = INT( pbuff%data( 7,kb) ) 772 pt%day = pbuff%data( 8,kb) 773 pt%mass = pbuff%data( 9,kb) 774 pt%thickness = pbuff%data(10,kb) 775 pt%width = pbuff%data(11,kb) 776 pt%length = pbuff%data(12,kb) 777 pt%mass_of_bits = pbuff%data(13,kb) 778 pt%heat_density = pbuff%data(14,kb) 779 780 currentberg%mass_scaling = pbuff%data(15,kb) 781 DO ik=1,nkounts 782 currentberg%number(ik) = INT( pbuff%data(15+ik,kb) ) 784 783 END DO 785 784 … … 790 789 !!------------------------------------------------------------------------- 791 790 792 SUBROUTINE increase_buffer(old, delta)791 SUBROUTINE increase_buffer(old,kdelta) 793 792 ! Arguments 794 793 TYPE(buffer), POINTER :: old 795 INTEGER , INTENT(in) :: delta794 INTEGER , INTENT(in) :: kdelta 796 795 ! Local variables 797 796 TYPE(buffer), POINTER :: new 798 INTEGER :: new_size797 INTEGER :: inew_size 799 798 800 799 IF( .NOT. ASSOCIATED(old) ) THEN 801 new_size =delta800 inew_size = kdelta 802 801 ELSE 803 new_size = old%size +delta802 inew_size = old%size + kdelta 804 803 ENDIF 805 804 ALLOCATE( new ) 806 ALLOCATE( new%data( buffer_width,new_size) )807 new%size = new_size805 ALLOCATE( new%data( pp_buffer_width, inew_size) ) 806 new%size = inew_size 808 807 IF( ASSOCIATED(old) ) THEN 809 808 new%data(:,1:old%size) = old%data(:,1:old%size) … … 817 816 !!------------------------------------------------------------------------- 818 817 819 SUBROUTINE increase_ibuffer(old, delta)818 SUBROUTINE increase_ibuffer(old,kdelta) 820 819 ! Arguments 821 820 TYPE(buffer), POINTER :: old 822 INTEGER , INTENT(in) :: delta821 INTEGER , INTENT(in) :: kdelta 823 822 ! Local variables 824 823 TYPE(buffer), POINTER :: new 825 INTEGER :: new_size,old_size824 INTEGER :: inew_size, iold_size 826 825 827 826 IF( .NOT. ASSOCIATED(old) ) THEN 828 new_size = delta +delta_buf829 old_size = 0827 inew_size = kdelta + pp_delta_buf 828 iold_size = 0 830 829 ELSE 831 old_size = old%size832 IF( delta .LT. old%size ) THEN833 new_size = old%size +delta830 iold_size = old%size 831 IF( kdelta .LT. old%size ) THEN 832 inew_size = old%size + kdelta 834 833 ELSE 835 new_size = delta +delta_buf836 ENDIF 837 ENDIF 838 839 IF( old_size .NE.new_size ) THEN834 inew_size = kdelta + pp_delta_buf 835 ENDIF 836 ENDIF 837 838 IF( iold_size .NE. inew_size ) THEN 840 839 ALLOCATE( new ) 841 ALLOCATE( new%data( buffer_width,new_size) )842 new%size = new_size840 ALLOCATE( new%data( pp_buffer_width, inew_size) ) 841 new%size = inew_size 843 842 IF( ASSOCIATED(old) ) THEN 844 843 new%data(:,1:old%size) = old%data(:,1:old%size) … … 847 846 ENDIF 848 847 old => new 849 !WRITE( numicb,*) 'increase_ibuffer',narea,' increased to', new_size848 !WRITE( numicb,*) 'increase_ibuffer',narea,' increased to',inew_size 850 849 ENDIF 851 850
Note: See TracChangeset
for help on using the changeset viewer.
