Changeset 4990 for trunk/NEMOGCM/NEMO/OPA_SRC/ICB
- Timestamp:
- 2014-12-15T17:42:49+01:00 (9 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/ICB
- Files:
-
- 7 edited
-
icb_oce.F90 (modified) (6 diffs)
-
icbdyn.F90 (modified) (2 diffs)
-
icbini.F90 (modified) (3 diffs)
-
icblbc.F90 (modified) (10 diffs)
-
icbrst.F90 (modified) (3 diffs)
-
icbstp.F90 (modified) (1 diff)
-
icbutl.F90 (modified) (10 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90
r4153 r4990 44 44 45 45 INTEGER, PUBLIC, PARAMETER :: nclasses = 10 !: Number of icebergs classes 46 !!INTEGER, PUBLIC &47 !!#if !defined key_agrif48 !! , PARAMETER &49 !!#endif50 !! :: &51 !! nclasses = 10 !: Number of icebergs classes52 46 INTEGER, PUBLIC, PARAMETER :: nkounts = 3 !: Number of integers combined for unique naming 53 47 … … 93 87 ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid 94 88 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: uo_e, vo_e 95 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ff_e 89 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ff_e, tt_e, fr_e, hicth 96 90 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e 97 91 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e 98 #if defined key_lim2 || defined key_lim3 92 #if defined key_lim2 || defined key_lim3 || defined key_cice 99 93 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ui_e, vi_e 100 94 #endif … … 144 138 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbflddest !: nfold destination proc 145 139 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldproc !: nfold destination proc 140 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldnsend !: nfold number of bergs to send to nfold neighbour 141 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldexpect !: nfold expected number of bergs 142 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldreq !: nfold message handle (immediate send) 146 143 147 144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: griddata !: work array for icbrst … … 162 159 ! 163 160 icb_alloc = 0 161 ALLOCATE( berg_grid, STAT=ill ) 162 icb_alloc = icb_alloc + ill 164 163 ALLOCATE( berg_grid%calving (jpi,jpj) , berg_grid%calving_hflx (jpi,jpj) , & 165 164 & berg_grid%stored_heat(jpi,jpj) , berg_grid%floating_melt(jpi,jpj) , & … … 171 170 ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) , & 172 171 & vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) , & 173 #if defined key_lim2 || defined key_lim3 172 #if defined key_lim2 || defined key_lim3 || defined key_cice 174 173 & ui_e(0:jpi+1,0:jpj+1) , & 175 174 & vi_e(0:jpi+1,0:jpj+1) , & 176 175 #endif 177 & ff_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) , & 176 & ff_e(0:jpi+1,0:jpj+1) , fr_e(0:jpi+1,0:jpj+1) , & 177 & tt_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) , & 178 & hicth(0:jpi+1,0:jpj+1), & 178 179 & first_width(nclasses) , first_length(nclasses) , & 179 180 & src_calving (jpi,jpj) , & … … 181 182 icb_alloc = icb_alloc + ill 182 183 183 ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , STAT=ill) 184 ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , & 185 & nicbfldnsend(jpni), nicbfldexpect(jpni) , nicbfldreq(jpni), STAT=ill) 184 186 icb_alloc = icb_alloc + ill 185 187 -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icbdyn.F90
r3614 r4990 33 33 CONTAINS 34 34 35 SUBROUTINE icb_dyn( )35 SUBROUTINE icb_dyn( kt ) 36 36 !!---------------------------------------------------------------------- 37 37 !! *** ROUTINE icb_dyn *** … … 50 50 TYPE(iceberg), POINTER :: berg 51 51 TYPE(point) , POINTER :: pt 52 INTEGER :: kt 52 53 !!---------------------------------------------------------------------- 53 54 -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
r4624 r4990 172 172 DO ji = nicbdi, nicbei 173 173 ii = nicbflddest(ji) 174 DO jn = 1, jpni 175 ! work along array until we find an empty slot 176 IF( nicbfldproc(jn) == -1 ) THEN 177 nicbfldproc(jn) = ii 178 EXIT !!gm EXIT should be avoided: use DO WHILE expression instead 179 ENDIF 180 ! before we find an empty slot, we may find processor number is already here so we exit 181 IF( nicbfldproc(jn) == ii ) EXIT 182 END DO 174 IF( ii .GT. 0 ) THEN ! Needed because land suppression can mean 175 ! that unused points are not set in edge haloes 176 DO jn = 1, jpni 177 ! work along array until we find an empty slot 178 IF( nicbfldproc(jn) == -1 ) THEN 179 nicbfldproc(jn) = ii 180 EXIT !!gm EXIT should be avoided: use DO WHILE expression instead 181 ENDIF 182 ! before we find an empty slot, we may find processor number is already here so we exit 183 IF( nicbfldproc(jn) == ii ) EXIT 184 END DO 185 ENDIF 183 186 END DO 184 187 ENDIF … … 210 213 WRITE(numicb,*) 'north fold destination procs ' 211 214 WRITE(numicb,*) nicbflddest 215 WRITE(numicb,*) 'north fold destination proclist ' 216 WRITE(numicb,*) nicbfldproc 212 217 ENDIF 213 218 CALL flush(numicb) … … 397 402 ENDIF 398 403 399 400 401 404 ! IF( lk_lim3 .AND. ln_icebergs ) THEN 405 ! CALL ctl_stop( 'icb_nam: the use of ICB with LIM3 not allowed. ice thickness missing in ICB' ) 406 ! ENDIF 402 407 403 408 IF(lwp) THEN ! control print -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
r3614 r4990 280 280 zwebergs(1) = ibergs_to_send_e 281 281 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 282 CALL mpprecv( 11, zewbergs(2), 1 )282 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 283 283 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 284 284 ibergs_rcvd_from_e = INT( zewbergs(2) ) … … 288 288 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 289 289 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 290 CALL mpprecv( 11, zewbergs(2), 1 )291 CALL mpprecv( 12, zwebergs(2), 1 )290 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 291 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 292 292 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 293 293 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 297 297 zewbergs(1) = ibergs_to_send_w 298 298 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 299 CALL mpprecv( 12, zwebergs(2), 1 )299 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 300 300 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 301 301 ibergs_rcvd_from_w = INT( zwebergs(2) ) … … 411 411 zsnbergs(1) = ibergs_to_send_n 412 412 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 413 CALL mpprecv( 15, znsbergs(2), 1 )413 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 414 414 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 415 415 ibergs_rcvd_from_n = INT( znsbergs(2) ) … … 419 419 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 420 420 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 421 CALL mpprecv( 15, znsbergs(2), 1 )422 CALL mpprecv( 16, zsnbergs(2), 1 )421 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 422 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 423 423 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 424 424 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 428 428 znsbergs(1) = ibergs_to_send_s 429 429 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 430 CALL mpprecv( 16, zsnbergs(2), 1 )430 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 431 431 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 432 432 ibergs_rcvd_from_s = INT( zsnbergs(2) ) … … 581 581 INTEGER :: ifldproc, iproc, ipts 582 582 INTEGER :: iine, ijne 583 REAL(wp), DIMENSION(2) :: zsbergs, znbergs 583 INTEGER :: jjn 584 REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs 584 585 INTEGER :: iml_req1, iml_req2, iml_err 585 586 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat … … 591 592 ! its of fixed size, the first -1 marks end of list of processors 592 593 ! 594 nicbfldnsend(:) = 0 595 nicbfldexpect(:) = 0 596 nicbfldreq(:) = 0 597 ! 598 ! Since each processor may be communicating with more than one northern 599 ! neighbour, cycle through the sends so that the receive order can be 600 ! controlled. 601 ! 602 ! First compute how many icebergs each active neighbour should expect 603 DO jn = 1, jpni 604 IF( nicbfldproc(jn) /= -1 ) THEN 605 ifldproc = nicbfldproc(jn) 606 nicbfldnsend(jn) = 0 607 608 ! Find number of bergs that need to be exchanged 609 ! Pick out exchanges with processor ifldproc 610 ! if ifldproc is this processor then don't send 611 ! 612 IF( ASSOCIATED(first_berg) ) THEN 613 this => first_berg 614 DO WHILE (ASSOCIATED(this)) 615 pt => this%current_point 616 iine = INT( pt%xi + 0.5 ) 617 ijne = INT( pt%yj + 0.5 ) 618 iproc = nicbflddest(mi1(iine)) 619 IF( ijne .GT. mjg(nicbej) ) THEN 620 IF( iproc == ifldproc ) THEN 621 ! 622 IF( iproc /= narea ) THEN 623 tmpberg => this 624 nicbfldnsend(jn) = nicbfldnsend(jn) + 1 625 ENDIF 626 ! 627 ENDIF 628 ENDIF 629 this => this%next 630 END DO 631 ENDIF 632 ! 633 ENDIF 634 ! 635 END DO 636 ! 637 ! Now tell each active neighbour how many icebergs to expect 638 DO jn = 1, jpni 639 IF( nicbfldproc(jn) /= -1 ) THEN 640 ifldproc = nicbfldproc(jn) 641 IF( ifldproc == narea ) CYCLE 642 643 zsbergs(0) = narea 644 zsbergs(1) = nicbfldnsend(jn) 645 !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc 646 CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) 647 ENDIF 648 ! 649 END DO 650 ! 651 ! and receive the heads-up from active neighbours preparing to send 652 DO jn = 1, jpni 653 IF( nicbfldproc(jn) /= -1 ) THEN 654 ifldproc = nicbfldproc(jn) 655 IF( ifldproc == narea ) CYCLE 656 657 CALL mpprecv( 21, znbergs(1:2), 2 ) 658 DO jjn = 1,jpni 659 IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT 660 END DO 661 IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR' 662 nicbfldexpect(jjn) = INT( znbergs(2) ) 663 !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) 664 !CALL FLUSH(numicb) 665 ENDIF 666 ! 667 END DO 668 ! 669 ! post the mpi waits if using immediate send protocol 670 DO jn = 1, jpni 671 IF( nicbfldproc(jn) /= -1 ) THEN 672 ifldproc = nicbfldproc(jn) 673 IF( ifldproc == narea ) CYCLE 674 675 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 676 ENDIF 677 ! 678 END DO 679 680 ! 681 ! Cycle through the icebergs again, this time packing and sending any 682 ! going through the north fold. They will be expected. 593 683 DO jn = 1, jpni 594 684 IF( nicbfldproc(jn) /= -1 ) THEN … … 646 736 IF( ifldproc == narea ) CYCLE 647 737 648 zsbergs(1) = ibergs_to_send649 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 738 ! send bergs 655 739 656 740 IF( ibergs_to_send > 0 ) & 657 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 741 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) 742 ! 743 ENDIF 744 ! 745 END DO 746 ! 747 ! Now receive the expected number of bergs from the active neighbours 748 DO jn = 1, jpni 749 IF( nicbfldproc(jn) /= -1 ) THEN 750 ifldproc = nicbfldproc(jn) 751 IF( ifldproc == narea ) CYCLE 752 ibergs_to_rcv = nicbfldexpect(jn) 753 658 754 IF( ibergs_to_rcv > 0 ) THEN 659 755 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 )756 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) 757 ENDIF 758 ! 663 759 DO jk = 1, ibergs_to_rcv 664 760 IF( nn_verbose_level >= 4 ) THEN … … 668 764 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 669 765 END DO 670 ! 766 ENDIF 767 ! 768 END DO 769 ! 770 ! Finally post the mpi waits if using immediate send protocol 771 DO jn = 1, jpni 772 IF( nicbfldproc(jn) /= -1 ) THEN 773 ifldproc = nicbfldproc(jn) 774 IF( ifldproc == narea ) CYCLE 775 776 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 671 777 ENDIF 672 778 ! -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90
r3614 r4990 64 64 ! start and count arrays 65 65 LOGICAL :: ll_found_restart 66 CHARACTER(len= 80):: cl_filename66 CHARACTER(len=256) :: cl_filename 67 67 CHARACTER(len=NF90_MAX_NAME) :: cl_dname 68 68 TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable … … 228 228 INTEGER :: jn ! dummy loop index 229 229 INTEGER :: ix_dim, iy_dim, ik_dim, in_dim 230 CHARACTER(len= 80):: cl_filename230 CHARACTER(len=256) :: cl_filename 231 231 TYPE(iceberg), POINTER :: this 232 232 TYPE(point) , POINTER :: pt … … 256 256 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim k failed') 257 257 258 ! global attributes 259 IF( lk_mpp ) THEN 260 ! Set domain parameters (assume jpdom_local_full) 261 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ) 262 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ) 263 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/1 , 2 /) ) 264 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/jpiglo, jpjglo/) ) 265 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/jpi , jpj /) ) 266 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/nimpp , njmpp /) ) 267 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/nimpp + jpi - 1 , njmpp + jpj - 1 /) ) 268 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/nldi - 1 , nldj - 1 /) ) 269 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/jpi - nlei , jpj - nlej /) ) 270 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ) 271 ENDIF 272 258 273 IF (associated(first_berg)) then 259 274 nret = NF90_DEF_DIM(ncid, 'n', NF90_UNLIMITED, in_dim) -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icbstp.F90
r4153 r4990 105 105 ! !== For each berg, evolve ==! 106 106 ! 107 IF( ASSOCIATED(first_berg) ) CALL icb_dyn( )! ice berg dynamics107 IF( ASSOCIATED(first_berg) ) CALL icb_dyn( kt ) ! ice berg dynamics 108 108 109 109 IF( lk_mpp ) THEN ; CALL icb_lbc_mpp() ! Send bergs to other PEs -
trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
r3821 r4990 70 70 ! and ssh which is used to calculate gradients 71 71 72 uo_e(:,:) = 0._wp ; uo_e(1:jpi, 1:jpj) = ssu_m(:,:) 73 vo_e(:,:) = 0._wp ; vo_e(1:jpi, 1:jpj) = ssv_m(:,:) 74 ff_e(:,:) = 0._wp ; ff_e(1:jpi, 1:jpj) = ff (:,:) 75 ua_e(:,:) = 0._wp ; ua_e(1:jpi, 1:jpj) = utau (:,:) 76 va_e(:,:) = 0._wp ; va_e(1:jpi, 1:jpj) = vtau (:,:) 77 78 CALL lbc_lnk_e( uo_e, 'U', -1._wp, 1, 1 ) 79 CALL lbc_lnk_e( vo_e, 'V', -1._wp, 1, 1 ) 80 CALL lbc_lnk_e( ff_e, 'F', +1._wp, 1, 1 ) 81 CALL lbc_lnk_e( ua_e, 'U', -1._wp, 1, 1 ) 82 CALL lbc_lnk_e( va_e, 'V', -1._wp, 1, 1 ) 72 uo_e(:,:) = 0._wp ; uo_e(1:jpi, 1:jpj) = ssu_m(:,:) * umask(:,:,1) 73 vo_e(:,:) = 0._wp ; vo_e(1:jpi, 1:jpj) = ssv_m(:,:) * vmask(:,:,1) 74 ff_e(:,:) = 0._wp ; ff_e(1:jpi, 1:jpj) = ff (:,:) 75 tt_e(:,:) = 0._wp ; tt_e(1:jpi, 1:jpj) = sst_m(:,:) 76 fr_e(:,:) = 0._wp ; fr_e(1:jpi, 1:jpj) = fr_i (:,:) 77 ua_e(:,:) = 0._wp ; ua_e(1:jpi, 1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk 78 va_e(:,:) = 0._wp ; va_e(1:jpi, 1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk 79 80 CALL lbc_lnk_icb( uo_e, 'U', -1._wp, 1, 1 ) 81 CALL lbc_lnk_icb( vo_e, 'V', -1._wp, 1, 1 ) 82 CALL lbc_lnk_icb( ff_e, 'F', +1._wp, 1, 1 ) 83 CALL lbc_lnk_icb( ua_e, 'U', -1._wp, 1, 1 ) 84 CALL lbc_lnk_icb( va_e, 'V', -1._wp, 1, 1 ) 85 CALL lbc_lnk_icb( fr_e, 'T', +1._wp, 1, 1 ) 86 CALL lbc_lnk_icb( tt_e, 'T', +1._wp, 1, 1 ) 87 #if defined key_lim2 88 hicth(:,:) = 0._wp ; hicth(1:jpi,1:jpj) = hicif(:,:) 89 CALL lbc_lnk_icb(hicth, 'T', +1._wp, 1, 1 ) 90 #endif 83 91 84 92 #if defined key_lim2 || defined key_lim3 … … 86 94 vi_e(:,:) = 0._wp ; vi_e(1:jpi, 1:jpj) = v_ice(:,:) 87 95 88 CALL lbc_lnk_ e( ui_e, 'U', -1._wp, 1, 1 )89 CALL lbc_lnk_ e( vi_e, 'V', -1._wp, 1, 1 )96 CALL lbc_lnk_icb( ui_e, 'U', -1._wp, 1, 1 ) 97 CALL lbc_lnk_icb( vi_e, 'V', -1._wp, 1, 1 ) 90 98 #endif 91 99 … … 93 101 !! so fudge some numbers all the way around the boundary 94 102 95 ssh_e(:,:) = 0._wp ; ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) 103 ssh_e(:,:) = 0._wp ; ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1) 96 104 ssh_e(0 , :) = ssh_e(1 , :) 97 105 ssh_e(jpi+1, :) = ssh_e(jpi, :) … … 102 110 ssh_e(0,jpj+1) = ssh_e(1,jpj) 103 111 ssh_e(jpi+1,jpj+1) = ssh_e(jpi,jpj) 104 CALL lbc_lnk_ e( ssh_e, 'T', +1._wp, 1, 1 )112 CALL lbc_lnk_icb( ssh_e, 'T', +1._wp, 1, 1 ) 105 113 ! 106 114 END SUBROUTINE icb_utl_copy … … 133 141 !!---------------------------------------------------------------------- 134 142 135 pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) 143 pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) ! scale factors 136 144 pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 137 145 ! 138 146 puo = icb_utl_bilin_h( uo_e, pi, pj, 'U' ) ! ocean velocities 139 147 pvo = icb_utl_bilin_h( vo_e, pi, pj, 'V' ) 140 psst = icb_utl_bilin ( sst_m, pi, pj, 'T' )! SST141 pcn = icb_utl_bilin ( fr_i , pi, pj, 'T' )! ice concentration148 psst = icb_utl_bilin_h( tt_e, pi, pj, 'T' ) ! SST 149 pcn = icb_utl_bilin_h( fr_e , pi, pj, 'T' ) ! ice concentration 142 150 pff = icb_utl_bilin_h( ff_e , pi, pj, 'F' ) ! Coriolis parameter 143 151 ! 144 152 pua = icb_utl_bilin_h( ua_e , pi, pj, 'U' ) ! 10m wind 145 153 pva = icb_utl_bilin_h( va_e , pi, pj, 'V' ) ! here (ua,va) are stress => rough conversion from stress to speed 146 zcd = 1.22_wp * 1.5e-3_wp 154 zcd = 1.22_wp * 1.5e-3_wp ! air density * drag coefficient 147 155 zmod = 1._wp / MAX( 1.e-20, SQRT( zcd * SQRT( pua*pua + pva*pva) ) ) 148 pua = pua * zmod 156 pua = pua * zmod ! note: stress module=0 necessarly implies ua=va=0 149 157 pva = pva * zmod 150 158 … … 155 163 phi = 0._wp ! LIM-3 case (to do) 156 164 # else 157 phi = icb_utl_bilin (hicif, pi, pj, 'T' )! ice thickness165 phi = icb_utl_bilin_h(hicth, pi, pj, 'T' ) ! ice thickness 158 166 # endif 159 167 #else … … 217 225 END SELECT 218 226 ! 219 ! find position in this processor 220 ii = mi1( ii ) 221 ij = mj1( ij ) 227 ! find position in this processor. Prevent near edge problems (see #1389) 228 229 if (ii.lt.mig(1)) then 230 ii = 1 231 else if (ii.gt.mig(jpi)) then 232 ii = jpi 233 else 234 ii = mi1( ii ) 235 end if 236 237 if (ij.lt.mjg(1)) then 238 ij = 1 239 else if (ij.gt.mjg(jpj)) then 240 ij = jpj 241 else 242 ij = mj1( ij ) 243 end if 244 245 if (ij.eq.jpj) ij=ij-1 246 if (ii.eq.jpi) ii=ii-1 247 222 248 ! 223 249 icb_utl_bilin_h = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) & … … 271 297 END SELECT 272 298 ! 273 ! find position in this processor 274 ii = mi1( ii ) 275 ij = mj1( ij ) 276 ! 299 ! find position in this processor. Prevent near edge problems (see #1389) 300 301 if (ii.lt.mig(1)) then 302 ii = 1 303 else if (ii.gt.mig(jpi)) then 304 ii = jpi 305 else 306 ii = mi1( ii ) 307 end if 308 309 if (ij.lt.mjg(1)) then 310 ij = 1 311 else if (ij.gt.mjg(jpj)) then 312 ij = jpj 313 else 314 ij = mj1( ij ) 315 end if 316 317 if (ij.eq.jpj) ij=ij-1 318 if (ii.eq.jpi) ii=ii-1 319 277 320 icb_utl_bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) & 278 321 & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj … … 309 352 zj = pj - REAL(ij,wp) 310 353 ! 311 ! find position in this processor !!gm use here mig, mjg arrays 312 ii = mi1( ii ) 313 ij = mj1( ij ) 354 ! find position in this processor. Prevent near edge problems (see #1389) 355 356 if (ii.lt.mig(1)) then 357 ii = 1 358 else if (ii.gt.mig(jpi)) then 359 ii = jpi 360 else 361 ii = mi1( ii ) 362 end if 363 364 if (ij.lt.mjg(1)) then 365 ij = 1 366 else if (ij.gt.mjg(jpj)) then 367 ij = jpj 368 else 369 ij = mj1( ij ) 370 end if 371 372 if (ij.eq.jpj) ij=ij-1 373 if (ii.eq.jpi) ii=ii-1 374 314 375 z4(1) = pfld(ii ,ij ) 315 376 z4(2) = pfld(ii+1,ij ) … … 359 420 zj = pj - REAL(ij,wp) 360 421 361 ! find position in this processor 362 ii = mi1( ii ) 363 ij = mj1( ij ) 422 ! find position in this processor. Prevent near edge problems (see #1389) 423 424 if (ii.lt.mig(1)) then 425 ii = 1 426 else if (ii.gt.mig(jpi)) then 427 ii = jpi 428 else 429 ii = mi1( ii ) 430 end if 431 432 if (ij.lt.mjg(1)) then 433 ij = 1 434 else if (ij.gt.mjg(jpj)) then 435 ij = jpj 436 else 437 ij = mj1( ij ) 438 end if 439 440 if (ij.eq.jpj) ij=ij-1 441 if (ii.eq.jpi) ii=ii-1 364 442 365 443 IF( 0.0_wp <= zi .AND. zi < 0.5_wp ) THEN
Note: See TracChangeset
for help on using the changeset viewer.
