- Timestamp:
- 2012-04-30T14:06:55+02:00 (12 years ago)
- Location:
- branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB
- Files:
-
- 3 edited
-
icbini.F90 (modified) (1 diff)
-
icblbc.F90 (modified) (1 diff)
-
icbrst.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
r3374 r3375 164 164 ! 165 165 ! work out list of unique processors to talk to 166 ! pack them into a fixed size array where empty slots are marked by a -1 166 167 DO ji = nicbdi, nicbei 167 168 ii = nicbflddest(ji) 168 169 DO jn = 1, jpni 170 ! work along array until we find an empty slot 169 171 IF( nicbfldproc(jn) == -1 ) THEN 170 172 nicbfldproc(jn) = ii 171 173 EXIT !!gm EXIT should be avoided: use DO WHILE expression instead 172 174 ENDIF 175 ! before we find an empty slot, we may find processor number is already here so we exit 173 176 IF( nicbfldproc(jn) == ii ) EXIT 174 177 END DO -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
r3374 r3375 592 592 ! 593 593 DO jn = 1, jpni 594 IF( nicbfldproc(jn) == -1 ) EXIT 595 ifldproc = nicbfldproc(jn) 596 ibergs_to_send = 0 597 598 ! Find number of bergs that need to be exchanged 599 ! Pick out exchanges with processor ifldproc 600 ! if ifldproc is this processor then don't send 601 ! 602 IF( ASSOCIATED(first_berg) ) THEN 603 this => first_berg 604 DO WHILE (ASSOCIATED(this)) 605 pt => this%current_point 606 iine = INT( pt%xi + 0.5 ) 607 ijne = INT( pt%yj + 0.5 ) 608 ipts = nicbfldpts (mi1(iine)) 609 iproc = nicbflddest(mi1(iine)) 610 IF( ijne .GT. mjg(nicbej) ) THEN 611 IF( iproc == ifldproc ) THEN 612 ! 613 ! moving across the cut line means both position and 614 ! velocity must change 615 ijglo = INT( ipts/nicbpack ) 616 iiglo = ipts - nicbpack*ijglo 617 pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) 618 pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) 619 pt%uvel = -1._wp * pt%uvel 620 pt%vvel = -1._wp * pt%vvel 621 ! 622 ! now remove berg from list and pack it into a buffer 623 IF( iproc /= narea ) THEN 624 tmpberg => this 625 ibergs_to_send = ibergs_to_send + 1 626 IF( nn_verbose_level >= 4 ) THEN 627 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' 628 CALL flush( numicb ) 594 IF( nicbfldproc(jn) /= -1 ) THEN 595 ifldproc = nicbfldproc(jn) 596 ibergs_to_send = 0 597 598 ! Find number of bergs that need to be exchanged 599 ! Pick out exchanges with processor ifldproc 600 ! if ifldproc is this processor then don't send 601 ! 602 IF( ASSOCIATED(first_berg) ) THEN 603 this => first_berg 604 DO WHILE (ASSOCIATED(this)) 605 pt => this%current_point 606 iine = INT( pt%xi + 0.5 ) 607 ijne = INT( pt%yj + 0.5 ) 608 ipts = nicbfldpts (mi1(iine)) 609 iproc = nicbflddest(mi1(iine)) 610 IF( ijne .GT. mjg(nicbej) ) THEN 611 IF( iproc == ifldproc ) THEN 612 ! 613 ! moving across the cut line means both position and 614 ! velocity must change 615 ijglo = INT( ipts/nicbpack ) 616 iiglo = ipts - nicbpack*ijglo 617 pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) 618 pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) 619 pt%uvel = -1._wp * pt%uvel 620 pt%vvel = -1._wp * pt%vvel 621 ! 622 ! now remove berg from list and pack it into a buffer 623 IF( iproc /= narea ) THEN 624 tmpberg => this 625 ibergs_to_send = ibergs_to_send + 1 626 IF( nn_verbose_level >= 4 ) THEN 627 WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' 628 CALL flush( numicb ) 629 ENDIF 630 CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) 631 CALL icb_utl_delete(first_berg, tmpberg) 629 632 ENDIF 630 CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) 631 CALL icb_utl_delete(first_berg, tmpberg) 633 ! 632 634 ENDIF 633 !634 635 ENDIF 636 this => this%next 637 END DO 638 ENDIF 639 if( nn_verbose_level >= 3) then 640 write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send 641 call flush(numicb) 642 endif 643 ! 644 ! if we're in this processor, then we've done everything we need to 645 ! so go on to next element of loop 646 IF( ifldproc == narea ) CYCLE 647 648 zsbergs(1) = ibergs_to_send 649 CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1) 650 CALL mpprecv( 21, znbergs(2), 1 ) 651 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 652 ibergs_to_rcv = INT( znbergs(2) ) 653 654 ! send bergs 655 656 IF( ibergs_to_send > 0 ) & 657 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 658 IF( ibergs_to_rcv > 0 ) THEN 659 CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) 660 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width ) 661 ENDIF 662 IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 663 DO jk = 1, ibergs_to_rcv 664 IF( nn_verbose_level >= 4 ) THEN 665 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' 666 CALL flush( numicb ) 635 667 ENDIF 636 this => this%next668 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 637 669 END DO 638 ENDIF 639 if( nn_verbose_level >= 3) then 640 write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send 641 call flush(numicb) 642 endif 643 ! 644 ! if we're in this processor, then we've done everything we need to 645 ! so go on to next element of loop 646 IF( ifldproc == narea ) CYCLE 647 648 zsbergs(1) = ibergs_to_send 649 CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1) 650 CALL mpprecv( 21, znbergs(2), 1 ) 651 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 652 ibergs_to_rcv = INT( znbergs(2) ) 653 654 ! send bergs 655 656 IF( ibergs_to_send > 0 ) & 657 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 658 IF( ibergs_to_rcv > 0 ) THEN 659 CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) 660 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width ) 661 ENDIF 662 IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 663 DO jk = 1, ibergs_to_rcv 664 IF( nn_verbose_level >= 4 ) THEN 665 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' 666 CALL flush( numicb ) 667 ENDIF 668 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 669 END DO 670 ! 671 ENDIF 670 672 ! 671 673 END DO -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90
r3373 r3375 64 64 REAL(wp), DIMENSION(1) :: zdata ! need 1d array to read in with 65 65 ! start and count arrays 66 LOGICAL :: ll_found_restart , ll_multiPErestart=.FALSE.66 LOGICAL :: ll_found_restart 67 67 CHARACTER(len=80) :: cl_filename 68 68 CHARACTER(len=NF90_MAX_NAME) :: cl_dname … … 74 74 75 75 ! Find a restart file 76 ll_multiPErestart=.FALSE. 77 DO 78 cl_filename = ' ' 79 cl_filename = 'restart_icebergs.nc' 80 INQUIRE( file=TRIM(cl_filename), exist=ll_found_restart ) 81 IF ( ll_found_restart ) EXIT 76 cl_filename = ' ' 77 IF ( lk_mpp ) THEN 82 78 cl_filename = ' ' 83 79 WRITE( cl_filename, '("restart_icebergs_",I4.4,".nc")' ) narea-1 84 80 INQUIRE( file=TRIM(cl_filename), exist=ll_found_restart ) 85 IF ( ll_found_restart ) THEN 86 ll_multiPErestart = .TRUE. 87 EXIT 88 ENDIF 89 IF (nn_verbose_level >= 0 .AND. lwp) & 90 WRITE( numout, '(a)' ) 'read_restart_bergs: no restart file found' 91 ll_multiPErestart = .TRUE. ! force checking in a MPP if no file found on this PE 92 EXIT 93 ENDDO 81 ELSE 82 cl_filename = 'restart_icebergs.nc' 83 INQUIRE( file=TRIM(cl_filename), exist=ll_found_restart ) 84 ENDIF 94 85 95 86 IF ( .NOT. ll_found_restart) THEN ! only do the following if a file was found … … 220 211 WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 221 212 IF( lk_mpp ) THEN 222 IF (ll_multiPErestart) CALL mpp_sum(ibergs_in_file) ! In case PE 0 didn't open a file213 CALL mpp_sum(ibergs_in_file) 223 214 CALL mpp_sum(jn) 224 215 ENDIF … … 247 238 IF( .NOT. ASSOCIATED(griddata) ) ALLOCATE( griddata(jpi,jpj,1) ) 248 239 249 WRITE(cl_filename,'("icebergs_",I8.8,"_restart_",I4.4,".nc")') kt, narea-1 240 IF( lk_mpp ) THEN 241 WRITE(cl_filename,'("icebergs_",I8.8,"_restart_",I4.4,".nc")') kt, narea-1 242 ELSE 243 WRITE(cl_filename,'("icebergs_",I8.8,"_restart.nc")') kt 244 ENDIF 250 245 IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_filename) 251 246
Note: See TracChangeset
for help on using the changeset viewer.
