Changeset 2888 for branches/2011/UKMO_MERCATOR_obc_bdy_merge
- Timestamp:
- 2011-10-06T11:26:33+02:00 (13 years ago)
- Location:
- branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 16 added
- 4 deleted
- 21 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r2797 r2888 19 19 USE trabbc ! bottom boundary condition 20 20 USE obc_par ! (for lk_obc) 21 USE bdy_par ! (for lk_bdy) 21 22 22 23 IMPLICIT NONE … … 204 205 WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 205 206 WRITE(numout,*) "~~~~~~~ output written in the 'heat_salt_volume_budgets.txt' ASCII file" 206 IF( lk_obc ) THEN207 IF( lk_obc .or. lk_bdy ) THEN 207 208 CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' ) 208 209 ENDIF -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r2865 r2888 30 30 USE domvvl ! variable volume 31 31 USE obc_oce ! ocean open boundary conditions 32 USE obcd ta ! ocean open boundary conditions33 USE obcdyn ! ocean open boundary conditions32 USE obcdyn ! open boundary condition for momentum (obc_dyn routine) 33 USE obcdyn_bt ! 2D open boundary condition for momentum (obc_dyn_bt routine) 34 34 USE obcvol ! ocean open boundary condition (obc_vol routines) 35 USE bdy_oce ! ocean open boundary conditions 36 USE bdydta ! ocean open boundary conditions 37 USE bdydyn ! ocean open boundary conditions 38 USE bdyvol ! ocean open boundary condition (bdy_vol routines) 35 39 USE in_out_manager ! I/O manager 36 40 USE lbclnk ! lateral boundary condition (or mpp link) … … 153 157 # if defined key_obc 154 158 ! !* OBC open boundaries 155 IF( lk_dynspg_exp ) CALL obc_dyn( kt ) 156 IF( lk_dynspg_ts ) CALL obc_dyn( kt, dyn3d_only=.true. ) 157 158 !!$!!gm ERROR - potential BUG: sshn should not be modified at this stage !! ssh_nxt not alrady called 159 !!$ CALL lbc_lnk( sshn, 'T', 1. ) ! Boundary conditions on sshn 160 !!$ ! 161 !!$ IF( ln_vol_cst ) CALL obc_vol( kt ) 162 !!$ ! 163 !!$ IF(ln_ctl) CALL prt_ctl( tab2d_1=sshn, clinfo1=' ssh : ', mask1=tmask ) 159 CALL obc_dyn( kt ) 160 ! 161 IF( .NOT. lk_dynspg_flt ) THEN 162 ! Flather boundary condition : - Update sea surface height on each open boundary 163 ! sshn (= after ssh ) for explicit case (lk_dynspg_exp=T) 164 ! sshn_b (= after ssha_b) for time-splitting case (lk_dynspg_ts=T) 165 ! - Correct the barotropic velocities 166 CALL obc_dyn_bt( kt ) 167 ! 168 !!gm ERROR - potential BUG: sshn should not be modified at this stage !! ssh_nxt not alrady called 169 CALL lbc_lnk( sshn, 'T', 1. ) ! Boundary conditions on sshn 170 ! 171 IF( ln_vol_cst ) CALL obc_vol( kt ) 172 ! 173 IF(ln_ctl) CALL prt_ctl( tab2d_1=sshn, clinfo1=' ssh : ', mask1=tmask ) 174 ENDIF 175 ! 176 # elif defined key_bdy 177 ! !* BDY open boundaries 178 IF( lk_dynspg_exp ) CALL bdy_dyn( kt ) 179 IF( lk_dynspg_ts ) CALL bdy_dyn( kt, dyn3d_only=.true. ) 180 181 !!$ Do we need a call to bdy_vol here?? 164 182 ! 165 183 # endif -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r2797 r2888 20 20 USE obc_oce ! Lateral open boundary condition 21 21 USE phycst ! physical constants 22 USE obcdta ! open boundary condition data (obc_dta_bt routine) 22 USE obc_par ! open boundary condition parameters 23 USE obcdta ! open boundary condition data (bdy_dta_bt routine) 23 24 USE in_out_manager ! I/O manager 24 25 USE lib_mpp ! distributed memory computing library … … 77 78 78 79 !!gm bug ?? Rachid we have to discuss of the call below. I don't understand why it is here and not in ssh_wzv 79 IF( lk_obc ) CALL obc_dta ( kt, jit=0 ) ! OBC: read or estimate ssh and vertically integrated velocities80 IF( lk_obc ) CALL obc_dta_bt( kt, 0 ) ! OBC: read or estimate ssh and vertically integrated velocities 80 81 !!gm 81 82 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r2800 r2888 26 26 USE sbc_oce ! surface boundary condition: ocean 27 27 USE obc_oce ! Lateral open boundary condition 28 USE bdy_oce ! Lateral open boundary condition 28 29 USE sol_oce ! ocean elliptic solver 29 30 USE phycst ! physical constants … … 34 35 USE solsor ! Successive Over-relaxation solver 35 36 USE obcdyn ! ocean open boundary condition on dynamics 36 USE obcvol ! ocean open boundary condition (obc_vol routines) 37 USE obcvol ! ocean open boundary condition (obc_vol routine) 38 USE bdydyn ! ocean open boundary condition on dynamics 39 USE bdyvol ! ocean open boundary condition (bdy_vol routine) 37 40 USE cla ! cross land advection 38 41 USE in_out_manager ! I/O manager … … 180 183 181 184 #if defined key_obc 182 CALL obc_dyn( kt ) ! Update velocities on each open boundary 183 CALL obc_vol( kt ) ! Correction of the barotropic component velocity to control the volume of the system 185 CALL obc_dyn( kt ) ! Update velocities on each open boundary with the radiation algorithm 186 CALL obc_vol( kt ) ! Correction of the barotropic componant velocity to control the volume of the system 187 #endif 188 #if defined key_bdy 189 CALL bdy_dyn( kt ) ! Update velocities on each open boundary 190 CALL bdy_vol( kt ) ! Correction of the barotropic component velocity to control the volume of the system 184 191 #endif 185 192 #if defined key_agrif … … 301 308 spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj) 302 309 spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj) 310 #elif defined key_bdy 311 ! caution : grad D = 0 along open boundaries 312 spgu(ji,jj) = z2dt * ztdgu * bdyumask(ji,jj) 313 spgv(ji,jj) = z2dt * ztdgv * bdyvmask(ji,jj) 303 314 #else 304 315 spgu(ji,jj) = z2dt * ztdgu -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r2865 r2888 26 26 USE zdfbfr ! bottom friction 27 27 USE dynvor ! vorticity term 28 USE obc_par ! for lk_obc29 28 USE obc_oce ! Lateral open boundary condition 29 USE obc_par ! open boundary condition parameters 30 30 USE obcdta ! open boundary condition data 31 USE obcdyn2d ! open boundary conditions on barotropic variables 31 USE obcfla ! Flather open boundary condition 32 USE bdy_par ! for lk_bdy 33 USE bdy_oce ! Lateral open boundary condition 34 USE bdydta ! open boundary condition data 35 USE bdydyn2d ! open boundary conditions on barotropic variables 32 36 USE lib_mpp ! distributed memory computing library 33 37 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 347 351 zssh_sum(:,:) = sshn (:,:) 348 352 353 #if defined key_obc 354 ! set ssh corrections to 0 355 ! ssh corrections are applied to normal velocities (Flather's algorithm) and averaged over the barotropic loop 356 IF( lp_obc_east ) sshfoe_b(:,:) = 0.e0 357 IF( lp_obc_west ) sshfow_b(:,:) = 0.e0 358 IF( lp_obc_south ) sshfos_b(:,:) = 0.e0 359 IF( lp_obc_north ) sshfon_b(:,:) = 0.e0 360 #endif 361 349 362 ! ! ==================== ! 350 363 DO jn = 1, icycle ! sub-time-step loop ! (from NOW to AFTER+1) … … 353 366 IF( jn == 1 ) z2dt_e = rdt / nn_baro 354 367 355 ! !* Update the forcing ( OBCand tides)368 ! !* Update the forcing (BDY and tides) 356 369 ! ! ------------------ 357 IF( lk_obc ) CALL obc_dta ( kt, jit=jn, time_offset=+1 ) 370 IF( lk_obc ) CALL obc_dta_bt ( kt, jn ) 371 IF( lk_bdy ) CALL bdy_dta ( kt, jit=jn, time_offset=+1 ) 358 372 359 373 ! !* after ssh_e … … 369 383 ! 370 384 #if defined key_obc 371 zhdiv(:,:) = zhdiv(:,:) * obctmask(:,:) ! OBC mask 385 ! ! OBC : zhdiv must be zero behind the open boundary 386 !! mpp remark: The zeroing of hdiv can probably be extended to 1->jpi/jpj for the correct row/column 387 IF( lp_obc_east ) zhdiv(nie0p1:nie1p1,nje0 :nje1 ) = 0.e0 ! east 388 IF( lp_obc_west ) zhdiv(niw0 :niw1 ,njw0 :njw1 ) = 0.e0 ! west 389 IF( lp_obc_north ) zhdiv(nin0 :nin1 ,njn0p1:njn1p1) = 0.e0 ! north 390 IF( lp_obc_south ) zhdiv(nis0 :nis1 ,njs0 :njs1 ) = 0.e0 ! south 391 #endif 392 #if defined key_bdy 393 zhdiv(:,:) = zhdiv(:,:) * bdytmask(:,:) ! BDY mask 372 394 #endif 373 395 ! … … 466 488 ! !* domain lateral boundary 467 489 ! ! ----------------------- 490 468 491 ! OBC open boundaries 469 #if defined key_obc 492 IF( lk_obc ) CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 493 494 ! BDY open boundaries 495 #if defined key_bdy 470 496 pssh => sshn_e 471 497 phur => hur_e … … 474 500 pv2d => va_e 475 501 476 IF( lk_ obc ) CALL obc_dyn2d( kt )502 IF( lk_bdy ) CALL bdy_dyn2d( kt ) 477 503 #endif 478 504 … … 529 555 ! ! ==================== ! 530 556 557 #if defined key_obc 558 IF( lp_obc_east ) sshfoe_b(:,:) = zcoef * sshfoe_b(:,:) !!gm totally useless ????? 559 IF( lp_obc_west ) sshfow_b(:,:) = zcoef * sshfow_b(:,:) 560 IF( lp_obc_north ) sshfon_b(:,:) = zcoef * sshfon_b(:,:) 561 IF( lp_obc_south ) sshfos_b(:,:) = zcoef * sshfos_b(:,:) 562 #endif 563 531 564 ! ----------------------------------------------------------------------------- 532 565 ! Phase 3. update the general trend with the barotropic trend -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r2797 r2888 26 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 27 27 USE lib_mpp ! MPP library 28 USE obc_par ! open boundary cond. parameter 28 29 USE obc_oce 30 USE bdy_oce 29 31 USE diaar5, ONLY: lk_diaar5 30 32 USE iom … … 173 175 #endif 174 176 #if defined key_obc 175 ssha(:,:) = ssha(:,:) * obctmask(:,:) 177 IF( Agrif_Root() ) THEN 178 ssha(:,:) = ssha(:,:) * obctmsk(:,:) 179 CALL lbc_lnk( ssha, 'T', 1. ) ! absolutly compulsory !! (jmm) 180 ENDIF 181 #endif 182 #if defined key_bdy 183 ssha(:,:) = ssha(:,:) * bdytmask(:,:) 176 184 CALL lbc_lnk( ssha, 'T', 1. ) ! absolutly compulsory !! (jmm) 177 185 #endif … … 209 217 & - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) & 210 218 & * tmask(:,:,jk) * z1_2dt 211 #if defined key_ obc212 wn(:,:,jk) = wn(:,:,jk) * obctmask(:,:)219 #if defined key_bdy 220 wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) 213 221 #endif 214 222 END DO -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_oce.F90
r2865 r2888 1 1 MODULE obc_oce 2 !!====================================================================== 2 !!============================================================================== 3 3 !! *** MODULE obc_oce *** 4 !! Unstructured Open Boundary Cond. : define related variables 5 !!====================================================================== 6 !! History : 1.0 ! 2001-05 (J. Chanut, A. Sellar) Original code 7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 8 !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions 9 !! 3.4 ! 2011 (D. Storkey, J. Chanut) OBC-BDY merge 10 !!---------------------------------------------------------------------- 11 #if defined key_obc 12 !!---------------------------------------------------------------------- 13 !! 'key_obc' Unstructured Open Boundary Condition 4 !! Open Boundary Cond. : define related variables 5 !!============================================================================== 6 !! history : OPA ! 1991-01 (CLIPPER) Original code 7 !! NEMO 1.0 ! 2002-02 (C. Talandier) modules, F90 8 !!---------------------------------------------------------------------- 9 #if defined key_obc 10 !!---------------------------------------------------------------------- 11 !! 'key_obc' : Open Boundary Condition 14 12 !!---------------------------------------------------------------------- 15 13 USE par_oce ! ocean parameters 16 USE obc_par ! Unstructured boundary parameters 17 USE lib_mpp ! distributed memory computing 14 USE obc_par ! open boundary condition parameters 18 15 19 16 IMPLICIT NONE 20 17 PUBLIC 21 22 TYPE, PUBLIC :: OBC_INDEX !: Indices and weights which define the open boundary 23 INTEGER, DIMENSION(jpbgrd) :: nblen 24 INTEGER, DIMENSION(jpbgrd) :: nblenrim 25 INTEGER, POINTER, DIMENSION(:,:) :: nbi 26 INTEGER, POINTER, DIMENSION(:,:) :: nbj 27 INTEGER, POINTER, DIMENSION(:,:) :: nbr 28 INTEGER, POINTER, DIMENSION(:,:) :: nbmap 29 REAL , POINTER, DIMENSION(:,:) :: nbw 30 REAL , POINTER, DIMENSION(:) :: flagu 31 REAL , POINTER, DIMENSION(:) :: flagv 32 END TYPE OBC_INDEX 33 34 TYPE, PUBLIC :: OBC_DATA !: Storage for external data 35 REAL, POINTER, DIMENSION(:) :: ssh 36 REAL, POINTER, DIMENSION(:) :: u2d 37 REAL, POINTER, DIMENSION(:) :: v2d 38 REAL, POINTER, DIMENSION(:,:) :: u3d 39 REAL, POINTER, DIMENSION(:,:) :: v3d 40 REAL, POINTER, DIMENSION(:,:) :: tem 41 REAL, POINTER, DIMENSION(:,:) :: sal 42 #if defined key_lim2 43 REAL, POINTER, DIMENSION(:) :: frld 44 REAL, POINTER, DIMENSION(:) :: hicif 45 REAL, POINTER, DIMENSION(:) :: hsnif 46 #endif 47 END TYPE OBC_DATA 48 49 !!---------------------------------------------------------------------- 50 !! Namelist variables 51 !!---------------------------------------------------------------------- 52 CHARACTER(len=80), DIMENSION(jp_obc) :: cn_coords_file !: Name of obc coordinates file 53 CHARACTER(len=80) :: cn_mask_file !: Name of obc mask file 18 19 PUBLIC obc_oce_alloc ! called by obcini.F90 module 20 21 !!---------------------------------------------------------------------- 22 !! open boundary variables 23 !!---------------------------------------------------------------------- 54 24 ! 55 LOGICAL, DIMENSION(jp_obc) :: ln_coords_file !: =T read obc coordinates from file; 56 ! !: =F read obc coordinates from namelist 57 LOGICAL :: ln_mask_file !: =T read obcmask from file 58 LOGICAL :: ln_vol !: =T volume correction 59 ! 60 INTEGER :: nb_obc !: number of open boundary sets 61 INTEGER, DIMENSION(jp_obc) :: nn_rimwidth !: boundary rim width for Flow Relaxation Scheme 62 INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P 63 ! ! = 1 the volume will be constant during all the integration. 64 INTEGER, DIMENSION(jp_obc) :: nn_dyn2d ! Choice of boundary condition for barotropic variables (U,V,SSH) 65 INTEGER, DIMENSION(jp_obc) :: nn_dyn2d_dta !: = 0 use the initial state as obc dta ; 66 !: = 1 read it in a NetCDF file 67 !: = 2 read tidal harmonic forcing from a NetCDF file 68 !: = 3 read external data AND tidal harmonic forcing from NetCDF files 69 INTEGER, DIMENSION(jp_obc) :: nn_dyn3d ! Choice of boundary condition for baroclinic velocities 70 INTEGER, DIMENSION(jp_obc) :: nn_dyn3d_dta !: = 0 use the initial state as obc dta ; 71 !: = 1 read it in a NetCDF file 72 INTEGER, DIMENSION(jp_obc) :: nn_tra ! Choice of boundary condition for active tracers (T and S) 73 INTEGER, DIMENSION(jp_obc) :: nn_tra_dta !: = 0 use the initial state as obc dta ; 74 !: = 1 read it in a NetCDF file 75 #if defined key_lim2 76 INTEGER, DIMENSION(jp_obc) :: nn_ice_lim2 ! Choice of boundary condition for sea ice variables 77 INTEGER, DIMENSION(jp_obc) :: nn_ice_lim2_dta !: = 0 use the initial state as obc dta ; 78 !: = 1 read it in a NetCDF file 79 #endif 80 ! 81 INTEGER, DIMENSION(jp_obc) :: nn_dmp2d_in ! Damping timescale (days) for 2D solution for inward radiation or FRS 82 INTEGER, DIMENSION(jp_obc) :: nn_dmp2d_out ! Damping timescale (days) for 2D solution for outward radiation 83 INTEGER, DIMENSION(jp_obc) :: nn_dmp3d_in ! Damping timescale (days) for 3D solution for inward radiation or FRS 84 INTEGER, DIMENSION(jp_obc) :: nn_dmp3d_out ! Damping timescale (days) for 3D solution for outward radiation 85 86 87 !!---------------------------------------------------------------------- 88 !! Global variables 89 !!---------------------------------------------------------------------- 90 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obctmask !: Mask defining computational domain at T-points 91 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obcumask !: Mask defining computational domain at U-points 92 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obcvmask !: Mask defining computational domain at V-points 93 94 REAL(wp) :: obcsurftot !: Lateral surface of unstructured open boundary 95 96 REAL(wp), POINTER, DIMENSION(:,:) :: pssh !: 97 REAL(wp), POINTER, DIMENSION(:,:) :: phur !: 98 REAL(wp), POINTER, DIMENSION(:,:) :: phvr !: Pointers for barotropic fields 99 REAL(wp), POINTER, DIMENSION(:,:) :: pu2d !: 100 REAL(wp), POINTER, DIMENSION(:,:) :: pv2d !: 101 102 !!---------------------------------------------------------------------- 103 !! open boundary data variables 104 !!---------------------------------------------------------------------- 105 106 INTEGER, DIMENSION(jp_obc) :: nn_dta !: =0 => *all* data is set to initial conditions 107 !: =1 => some data to be read in from data files 108 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global !: workspace for reading in global data arrays 109 TYPE(OBC_INDEX), DIMENSION(jp_obc), TARGET :: idx_obc !: obc indices (local process) 110 TYPE(OBC_DATA) , DIMENSION(jp_obc) :: dta_obc !: obc external data (local process) 111 112 !!---------------------------------------------------------------------- 113 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 25 ! !!* Namelist namobc: open boundary condition * 26 INTEGER :: nn_obcdta = 0 !: = 0 use the initial state as obc data 27 ! ! = 1 read obc data in obcxxx.dta files 28 CHARACTER(len=20) :: cn_obcdta = 'annual' !: set to annual if obc datafile hold 1 year of data 29 ! ! set to monthly if obc datafile hold 1 month of data 30 LOGICAL :: ln_obc_clim = .true. !: obc data files are climatological 31 LOGICAL :: ln_obc_fla = .false. !: Flather open boundary condition not used 32 LOGICAL :: ln_vol_cst = .true. !: Conservation of the whole volume 33 REAL(wp) :: rn_dpein = 1. !: damping time scale for inflow at East open boundary 34 REAL(wp) :: rn_dpwin = 1. !: " " at West open boundary 35 REAL(wp) :: rn_dpsin = 1. !: " " at South open boundary 36 REAL(wp) :: rn_dpnin = 1. !: " " at North open boundary 37 REAL(wp) :: rn_dpeob = 15. !: damping time scale for the climatology at East open boundary 38 REAL(wp) :: rn_dpwob = 15. !: " " at West open boundary 39 REAL(wp) :: rn_dpsob = 15. !: " " at South open boundary 40 REAL(wp) :: rn_dpnob = 15. !: " " at North open boundary 41 REAL(wp) :: rn_volemp = 1. !: = 0 the total volume will have the variability of the 42 ! ! surface Flux E-P else (volemp = 1) the volume will be constant 43 ! ! = 1 the volume will be constant during all the integration. 44 45 ! !!! OLD non-DOCTOR name of namelist variables 46 INTEGER :: nbobc !: number of open boundaries ( 1=< nbobc =< 4 ) 47 INTEGER :: nobc_dta !: = 0 use the initial state as obc data 48 REAL(wp) :: rdpein !: damping time scale for inflow at East open boundary 49 REAL(wp) :: rdpwin !: " " at West open boundary 50 REAL(wp) :: rdpsin !: " " at South open boundary 51 REAL(wp) :: rdpnin !: " " at North open boundary 52 REAL(wp) :: rdpeob !: damping time scale for the climatology at East open boundary 53 REAL(wp) :: rdpwob !: " " at West open boundary 54 REAL(wp) :: rdpsob !: " " at South open boundary 55 REAL(wp) :: rdpnob !: " " at North open boundary 56 REAL(wp) :: volemp !: = 0 the total volume will have the variability of the 57 CHARACTER(len=20) :: cffile 58 59 60 !!General variables for open boundaries: 61 !!-------------------------------------- 62 LOGICAL :: lfbceast, lfbcwest !: logical flag for a fixed East and West open boundaries 63 LOGICAL :: lfbcnorth, lfbcsouth !: logical flag for a fixed North and South open boundaries 64 ! ! These logical flags are set to 'true' if damping time 65 ! ! scale are set to 0 in the namelist, for both inflow and outflow). 66 67 REAL(wp), PUBLIC :: obcsurftot !: Total lateral surface of open boundaries 68 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 70 obctmsk, & !: mask array identical to tmask, execpt along OBC where it is set to 0 71 ! ! it used to calculate the cumulate flux E-P in the obcvol.F90 routine 72 obcumask, obcvmask !: u-, v- Force filtering mask for the open 73 ! ! boundary condition on grad D 74 75 !!-------------------- 76 !! East open boundary: 77 !!-------------------- 78 INTEGER :: nie0 , nie1 !: do loop index in mpp case for jpieob 79 INTEGER :: nie0p1, nie1p1 !: do loop index in mpp case for jpieob+1 80 INTEGER :: nie0m1, nie1m1 !: do loop index in mpp case for jpieob-1 81 INTEGER :: nje0 , nje1 !: do loop index in mpp case for jpjed, jpjef 82 INTEGER :: nje0p1, nje1m1 !: do loop index in mpp case for jpjedp1,jpjefm1 83 INTEGER :: nje1m2, nje0m1 !: do loop index in mpp case for jpjefm1-1,jpjed 84 85 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 86 sshfoe, & !: now climatology of the east boundary sea surface height 87 ubtfoe,vbtfoe !: now climatology of the east boundary barotropic transport 88 89 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 90 ufoe, vfoe, & !: now climatology of the east boundary velocities 91 tfoe, sfoe, & !: now climatology of the east boundary temperature and salinity 92 uclie !: baroclinic componant of the zonal velocity after radiation 93 ! ! in the obcdyn.F90 routine 94 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfoe_b !: east boundary ssh correction averaged over the barotropic loop 96 ! ! (if Flather's algoritm applied at open boundary) 97 98 !!------------------------------- 99 !! Arrays for radiative East OBC: 100 !!------------------------------- 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uebnd, vebnd !: baroclinic u & v component of the velocity over 3 rows 102 ! ! and 3 time step (now, before, and before before) 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tebnd, sebnd !: East boundary temperature and salinity over 2 rows 104 ! ! and 2 time step (now and before) 105 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cxebnd, v_cxebnd !: Zonal component of the phase speed ratio computed with 106 ! ! radiation of u and v velocity (respectively) at the 107 ! ! east open boundary (u_cxebnd = cx rdt ) 108 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uemsk, vemsk, temsk !: 2D mask for the East OB 109 110 ! Note that those arrays are optimized for mpp case 111 ! (hence the dimension jpj is the size of one processor subdomain) 112 113 !!-------------------- 114 !! West open boundary 115 !!-------------------- 116 INTEGER :: niw0 , niw1 !: do loop index in mpp case for jpiwob 117 INTEGER :: niw0p1, niw1p1 !: do loop index in mpp case for jpiwob+1 118 INTEGER :: njw0 , njw1 !: do loop index in mpp case for jpjwd, jpjwf 119 INTEGER :: njw0p1, njw1m1 !: do loop index in mpp case for jpjwdp1,jpjwfm1 120 INTEGER :: njw1m2, njw0m1 !: do loop index in mpp case for jpjwfm2,jpjwd 121 122 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 123 sshfow, & !: now climatology of the west boundary sea surface height 124 ubtfow,vbtfow !: now climatology of the west boundary barotropic transport 125 126 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 127 ufow, vfow, & !: now climatology of the west velocities 128 tfow, sfow, & !: now climatology of the west temperature and salinity 129 ucliw !: baroclinic componant of the zonal velocity after the radiation 130 ! ! in the obcdyn.F90 routine 131 132 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfow_b !: west boundary ssh correction averaged over the barotropic loop 133 ! ! (if Flather's algoritm applied at open boundary) 134 135 !!------------------------------- 136 !! Arrays for radiative West OBC 137 !!------------------------------- 138 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uwbnd, vwbnd !: baroclinic u & v components of the velocity over 3 rows 139 ! ! and 3 time step (now, before, and before before) 140 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: twbnd, swbnd !: west boundary temperature and salinity over 2 rows and 141 ! ! 2 time step (now and before) 142 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cxwbnd, v_cxwbnd !: Zonal component of the phase speed ratio computed with 143 ! ! radiation of zonal and meridional velocity (respectively) 144 ! ! at the west open boundary (u_cxwbnd = cx rdt ) 145 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uwmsk, vwmsk, twmsk !: 2D mask for the West OB 146 147 ! Note that those arrays are optimized for mpp case 148 ! (hence the dimension jpj is the size of one processor subdomain) 149 150 !!--------------------- 151 !! North open boundary 152 !!--------------------- 153 INTEGER :: nin0 , nin1 !: do loop index in mpp case for jpind, jpinf 154 INTEGER :: nin0p1, nin1m1 !: do loop index in mpp case for jpindp1, jpinfm1 155 INTEGER :: nin1m2, nin0m1 !: do loop index in mpp case for jpinfm1-1,jpind 156 INTEGER :: njn0 , njn1 !: do loop index in mpp case for jpnob 157 INTEGER :: njn0p1, njn1p1 !: do loop index in mpp case for jpnob+1 158 INTEGER :: njn0m1, njn1m1 !: do loop index in mpp case for jpnob-1 159 160 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 161 sshfon, & !: now climatology of the north boundary sea surface height 162 ubtfon,vbtfon !: now climatology of the north boundary barotropic transport 163 164 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 165 ufon, vfon, & !: now climatology of the north boundary velocities 166 tfon, sfon, & !: now climatology of the north boundary temperature and salinity 167 vclin !: baroclinic componant of the meridian velocity after the radiation 168 ! ! in yhe obcdyn.F90 routine 169 170 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfon_b !: north boundary ssh correction averaged over the barotropic loop 171 ! ! (if Flather's algoritm applied at open boundary) 172 173 !!-------------------------------- 174 !! Arrays for radiative North OBC 175 !!-------------------------------- 176 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: unbnd, vnbnd !: baroclinic u & v components of the velocity over 3 177 ! ! rows and 3 time step (now, before, and before before) 178 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tnbnd, snbnd !: north boundary temperature and salinity over 179 ! ! 2 rows and 2 time step (now and before) 180 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cynbnd, v_cynbnd !: Meridional component of the phase speed ratio compu- 181 ! ! ted with radiation of zonal and meridional velocity 182 ! ! (respectively) at the north OB (u_cynbnd = cx rdt ) 183 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: unmsk, vnmsk, tnmsk !: 2D mask for the North OB 184 185 ! Note that those arrays are optimized for mpp case 186 ! (hence the dimension jpj is the size of one processor subdomain) 187 188 !!--------------------- 189 !! South open boundary 190 !!--------------------- 191 INTEGER :: nis0 , nis1 !: do loop index in mpp case for jpisd, jpisf 192 INTEGER :: nis0p1, nis1m1 !: do loop index in mpp case for jpisdp1, jpisfm1 193 INTEGER :: nis1m2, nis0m1 !: do loop index in mpp case for jpisfm1-1,jpisd 194 INTEGER :: njs0 , njs1 !: do loop index in mpp case for jpsob 195 INTEGER :: njs0p1, njs1p1 !: do loop index in mpp case for jpsob+1 196 197 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 198 sshfos, & !: now climatology of the south boundary sea surface height 199 ubtfos,vbtfos !: now climatology of the south boundary barotropic transport 200 201 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 202 ufos, vfos, & !: now climatology of the south boundary velocities 203 tfos, sfos, & !: now climatology of the south boundary temperature and salinity 204 vclis !: baroclinic componant of the meridian velocity after the radiation 205 ! ! in the obcdyn.F90 routine 206 207 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfos_b !: south boundary ssh correction averaged over the barotropic loop 208 ! ! (if Flather's algoritm applied at open boundary) 209 210 !!-------------------------------- 211 !! Arrays for radiative South OBC (computed by the forward time step in dynspg) 212 !!-------------------------------- 213 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: usbnd, vsbnd !: baroclinic u & v components of the velocity over 3 214 ! ! rows and 3 time step (now, before, and before before) 215 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsbnd, ssbnd !: south boundary temperature and salinity over 216 ! ! 2 rows and 2 time step (now and before) 217 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cysbnd, v_cysbnd !: Meridional component of the phase speed ratio 218 ! ! computed with radiation of zonal and meridional velocity 219 ! ! (repsectively) at the south OB (u_cynbnd = cx rdt ) 220 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: usmsk, vsmsk, tsmsk !: 2D mask for the South OB 221 222 !!---------------------------------------------------------------------- 223 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 114 224 !! $Id$ 115 !! Software governed by the CeCILL licence 225 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 116 226 !!---------------------------------------------------------------------- 117 227 CONTAINS 118 228 119 FUNCTION obc_oce_alloc()229 INTEGER FUNCTION obc_oce_alloc() 120 230 !!---------------------------------------------------------------------- 121 USE lib_mpp, ONLY: ctl_warn, mpp_sum 122 ! 123 INTEGER :: obc_oce_alloc 231 !! *** FUNCTION obc_oce_alloc *** 124 232 !!---------------------------------------------------------------------- 125 ! 126 ALLOCATE( obctmask(jpi,jpj) , obcumask(jpi,jpj), obcvmask(jpi,jpj), & 127 & STAT=obc_oce_alloc ) 128 ! 129 IF( lk_mpp ) CALL mpp_sum ( obc_oce_alloc ) 130 IF( obc_oce_alloc /= 0 ) CALL ctl_warn('obc_oce_alloc: failed to allocate arrays.') 233 234 ALLOCATE( & 235 !! East open boundary 236 obctmsk(jpi,jpj), obcumask(jpi,jpj), obcvmask(jpi,jpj), & 237 sshfoe(jpjed:jpjef), ubtfoe(jpjed:jpjef), vbtfoe(jpjed:jpjef), & 238 ufoe(jpj,jpk), vfoe(jpj,jpk), tfoe(jpj,jpk), sfoe(jpj,jpk), & 239 uclie(jpj,jpk), sshfoe_b(jpjed:jpjef,jpj), & 240 !! Arrays for radiative East OBC 241 uebnd(jpj,jpk,3,3), vebnd(jpj,jpk,3,3) , & 242 tebnd(jpj,jpk,2,2), sebnd(jpj,jpk,2,2), & 243 u_cxebnd(jpj,jpk), v_cxebnd(jpj,jpk), & 244 uemsk(jpj,jpk), vemsk(jpj,jpk), temsk(jpj,jpk), & 245 !! West open boundary 246 sshfow(jpjwd:jpjwf), ubtfow(jpjwd:jpjwf), vbtfow(jpjwd:jpjwf), & 247 ufow(jpj,jpk), vfow(jpj,jpk), tfow(jpj,jpk), & 248 sfow(jpj,jpk), ucliw(jpj,jpk), sshfow_b(jpjwd:jpjwf,jpj), & 249 !! Arrays for radiative West OBC 250 uwbnd(jpj,jpk,3,3), vwbnd(jpj,jpk,3,3), & 251 twbnd(jpj,jpk,2,2), swbnd(jpj,jpk,2,2), & 252 u_cxwbnd(jpj,jpk), v_cxwbnd(jpj,jpk), & 253 uwmsk(jpj,jpk), vwmsk(jpj,jpk), twmsk(jpj,jpk), & 254 !! North open boundary 255 sshfon(jpind:jpinf), ubtfon(jpind:jpinf), vbtfon(jpind:jpinf), & 256 ufon(jpi,jpk), vfon(jpi,jpk), tfon(jpi,jpk), & 257 sfon(jpi,jpk), vclin(jpi,jpk), sshfon_b(jpind:jpinf,jpj), & 258 !! Arrays for radiative North OBC 259 unbnd(jpi,jpk,3,3), vnbnd(jpi,jpk,3,3), & 260 tnbnd(jpi,jpk,2,2), snbnd(jpi,jpk,2,2), & 261 u_cynbnd(jpi,jpk), v_cynbnd(jpi,jpk), & 262 unmsk(jpi,jpk), vnmsk(jpi,jpk), tnmsk (jpi,jpk), & 263 !! South open boundary 264 sshfos(jpisd:jpisf), ubtfos(jpisd:jpisf), vbtfos(jpisd:jpisf), & 265 ufos(jpi,jpk), vfos(jpi,jpk), tfos(jpi,jpk), & 266 sfos(jpi,jpk), vclis(jpi,jpk), & 267 sshfos_b(jpisd:jpisf,jpj), & 268 !! Arrays for radiative South OBC 269 usbnd(jpi,jpk,3,3), vsbnd(jpi,jpk,3,3), & 270 tsbnd(jpi,jpk,2,2), ssbnd(jpi,jpk,2,2), & 271 u_cysbnd(jpi,jpk), v_cysbnd(jpi,jpk), & 272 usmsk(jpi,jpk), vsmsk(jpi,jpk), tsmsk(jpi,jpk), & 273 !! 274 STAT=obc_oce_alloc ) 131 275 ! 132 276 END FUNCTION obc_oce_alloc 133 277 134 278 #else 135 279 !!---------------------------------------------------------------------- 136 !! Dummy module NO Unstructured Open Boundary Condition 137 !!---------------------------------------------------------------------- 138 LOGICAL :: ln_tides = .false. !: =T apply tidal harmonic forcing along open boundaries 280 !! Default option Empty module No OBC 281 !!---------------------------------------------------------------------- 139 282 #endif 140 283 141 284 !!====================================================================== 142 285 END MODULE obc_oce 143 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_par.F90
r2797 r2888 1 1 MODULE obc_par 2 !!====================================================================== 3 !! 4 !! UnstructuredOpen Boundary Cond. : define related parameters5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version8 !! 3.3 ! 2010-09 (D. Storkey and E. O'Dea) update for Shelf configurations2 !!============================================================================== 3 !! *** MODULE obc_par *** 4 !! Open Boundary Cond. : define related parameters 5 !!============================================================================== 6 !! history : OPA ! 1991-01 (CLIPPER) Original code 7 !! NEMO 1.0 ! 2002-04 (C. Talandier) modules 8 !! - ! 2004/06 (F. Durand) jptobc is defined as a parameter 9 9 !!---------------------------------------------------------------------- 10 #if defined 10 #if defined key_obc 11 11 !!---------------------------------------------------------------------- 12 !! 'key_obc' : UnstructuredOpen Boundary Condition12 !! 'key_obc' : Open Boundary Condition 13 13 !!---------------------------------------------------------------------- 14 USE par_oce ! ocean parameters 14 15 15 16 IMPLICIT NONE 16 17 PUBLIC 17 18 18 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .TRUE. !: Unstructured Ocean Boundary Condition flag 19 INTEGER, PUBLIC, PARAMETER :: jp_obc = 10 !: Maximum number of obc sets 20 INTEGER, PUBLIC, PARAMETER :: jpbtime = 1000 !: Max number of time dumps per file 21 INTEGER, PUBLIC, PARAMETER :: jpbgrd = 3 !: Number of horizontal grid types used (T, U, V) 19 #if ! defined key_agrif 20 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .TRUE. !: Ocean Boundary Condition flag 21 #else 22 LOGICAL, PUBLIC :: lk_obc = .TRUE. !: Ocean Boundary Condition flag 23 #endif 22 24 23 !! Flags for choice of schemes 24 INTEGER, PUBLIC, PARAMETER :: jp_none = 0 !: Flag for no open boundary condition 25 INTEGER, PUBLIC, PARAMETER :: jp_frs = 1 !: Flag for Flow Relaxation Scheme 26 INTEGER, PUBLIC, PARAMETER :: jp_flather = 2 !: Flag for Flather 25 # if defined key_eel_r5 26 !!---------------------------------------------------------------------- 27 !! 'key_eel_r5' : EEL R5 configuration 28 !!---------------------------------------------------------------------- 29 # include "obc_par_EEL_R5.h90" 30 31 # elif defined key_pomme_r025 32 !!---------------------------------------------------------------------- 33 !! 'key_pomme_r025' : POMME R025 configuration 34 !!---------------------------------------------------------------------- 35 # include "obc_par_POMME_R025.h90" 36 37 # else 38 !!--------------------------------------------------------------------- 39 !! open boundary parameter 40 !!--------------------------------------------------------------------- 41 INTEGER, PARAMETER :: jptobc = 2 !: time dimension of the BCS fields on input 42 43 !! * EAST open boundary 44 LOGICAL, PARAMETER :: lp_obc_east = .FALSE. !: to active or not the East open boundary 45 INTEGER & 46 #if !defined key_agrif 47 , PARAMETER & 48 #endif 49 :: & 50 jpieob = jpiglo-2, & !: i-localization of the East open boundary (must be ocean U-point) 51 jpjed = 2, & !: j-starting indice of the East open boundary (must be land T-point) 52 jpjef = jpjglo-1, & !: j-ending indice of the East open boundary (must be land T-point) 53 jpjedp1 = jpjed+1, & !: first ocean point " " 54 jpjefm1 = jpjef-1 !: last ocean point " " 55 56 !! * WEST open boundary 57 LOGICAL, PARAMETER :: lp_obc_west = .FALSE. !: to active or not the West open boundary 58 INTEGER & 59 #if !defined key_agrif 60 , PARAMETER & 61 #endif 62 :: & 63 jpiwob = 2, & !: i-localization of the West open boundary (must be ocean U-point) 64 jpjwd = 2, & !: j-starting indice of the West open boundary (must be land T-point) 65 jpjwf = jpjglo-1, & !: j-ending indice of the West open boundary (must be land T-point) 66 jpjwdp1 = jpjwd+1, & !: first ocean point " " 67 jpjwfm1 = jpjwf-1 !: last ocean point " " 68 69 !! * NORTH open boundary 70 LOGICAL, PARAMETER :: lp_obc_north = .FALSE. !: to active or not the North open boundary 71 INTEGER & 72 #if !defined key_agrif 73 , PARAMETER & 74 #endif 75 :: & 76 jpjnob = jpjglo-2, & !: j-localization of the North open boundary (must be ocean V-point) 77 jpind = 2, & !: i-starting indice of the North open boundary (must be land T-point) 78 jpinf = jpiglo-1, & !: i-ending indice of the North open boundary (must be land T-point) 79 jpindp1 = jpind+1, & !: first ocean point " " 80 jpinfm1 = jpinf-1 !: last ocean point " " 81 82 !! * SOUTH open boundary 83 LOGICAL, PARAMETER :: lp_obc_south = .FALSE. !: to active or not the South open boundary 84 INTEGER & 85 #if !defined key_agrif 86 , PARAMETER & 87 #endif 88 :: & 89 jpjsob = 2, & !: j-localization of the South open boundary (must be ocean V-point) 90 jpisd = 2, & !: i-starting indice of the South open boundary (must be land T-point) 91 jpisf = jpiglo-1, & !: i-ending indice of the South open boundary (must be land T-point) 92 jpisdp1 = jpisd+1, & !: first ocean point " " 93 jpisfm1 = jpisf-1 !: last ocean point " " 94 95 INTEGER, PARAMETER :: jpnic = 2700 !: maximum number of isolated coastlines points 96 97 # endif 98 27 99 #else 28 100 !!---------------------------------------------------------------------- 29 !! Default option : NO Unstructuredopen boundary condition101 !! Default option : NO open boundary condition 30 102 !!---------------------------------------------------------------------- 31 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .FALSE. !: UnstructuredOcean Boundary Condition flag103 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .FALSE. !: Ocean Boundary Condition flag 32 104 #endif 33 105 … … 35 107 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 36 108 !! $Id$ 37 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)109 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 38 110 !!====================================================================== 39 111 END MODULE obc_par -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcdta.F90
r2865 r2888 1 1 MODULE obcdta 2 !!====================================================================== 3 !! *** MODULE obcdta *** 4 !! Open boundary data : read the data for the unstructured open boundaries. 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! - ! 2007-01 (D. Storkey) Update to use IOM module 8 !! - ! 2007-07 (D. Storkey) add obc_dta_fla 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 !! 3.4 ???????????????? 13 !!---------------------------------------------------------------------- 2 !!============================================================================== 3 !! *** MODULE obcdta *** 4 !! Open boundary data : read the data for the open boundaries. 5 !!============================================================================== 6 !! History : OPA ! 1998-05 (J.M. Molines) Original code 7 !! 8.5 ! 2002-10 (C. Talandier, A-M. Treguier) Free surface, F90 8 !! NEMO 1.0 ! 2004-06 (F. Durand, A-M. Treguier) Netcdf BC files on input 9 !! 3.0 ! 2007-2008 (C. Langlais, P. Mathiot, J.M. Molines) high frequency boundaries data 10 !!------------------------------------------------------------------------------ 14 11 #if defined key_obc 15 !!---------------------------------------------------------------------- 16 !! 'key_obc' Open Boundary Conditions 17 !!---------------------------------------------------------------------- 18 !! obc_dta : read external data along open boundaries from file 19 !! obc_dta_init : initialise arrays etc for reading of external data 20 !!---------------------------------------------------------------------- 21 USE oce ! ocean dynamics and tracers 12 !!------------------------------------------------------------------------------ 13 !! 'key_obc' : Open Boundary Conditions 14 !!------------------------------------------------------------------------------ 15 !! obc_dta : read u, v, t, s data along each open boundary 16 !!------------------------------------------------------------------------------ 17 USE oce ! ocean dynamics and tracers 22 18 USE dom_oce ! ocean space and time domain 19 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 23 20 USE phycst ! physical constants 24 USE obc_oce ! ocean open boundary conditions 25 USE obctides ! tidal forcing at boundaries 26 USE fldread ! read input fields 27 USE iom ! IOM library 21 USE obc_par ! ocean open boundary conditions 22 USE obc_oce ! ocean open boundary conditions 28 23 USE in_out_manager ! I/O logical units 29 #if defined key_lim2 30 USE ice_2 31 #endif 24 USE lib_mpp ! distributed memory computing 25 USE dynspg_oce ! ocean: surface pressure gradient 26 USE ioipsl ! now only for ymds2ju function 27 USE iom ! 32 28 33 29 IMPLICIT NONE 34 30 PRIVATE 35 31 36 PUBLIC obc_dta ! routine called by step.F90 and dynspg_ts.F90 37 PUBLIC obc_dta_init ! routine called by nemogcm.F90 38 39 INTEGER, ALLOCATABLE, DIMENSION(:) :: nb_obc_fld ! Number of fields to update for each boundary set. 40 INTEGER :: nb_obc_fld_sum ! Total number of fields to update for all boundary sets. 41 42 LOGICAL, DIMENSION(jp_obc) :: ln_full_vel_array ! =T => full velocities in 3D boundary conditions 43 ! =F => baroclinic velocities in 3D boundary conditions 44 45 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET :: bf ! structure of input fields (file informations, fields read) 46 47 TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr ! array of pointers to nbmap 48 32 PUBLIC obc_dta ! routine called by step.F90 33 PUBLIC obc_dta_bt ! routine called by dynspg_ts.F90 34 PUBLIC obc_dta_alloc ! function called by obcini.F90 35 36 REAL(wp), DIMENSION(2) :: zjcnes_obc ! 37 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztcobc 38 REAL(wp) :: rdt_obc 39 REAL(wp) :: zjcnes 40 INTEGER :: imm0, iyy0, idd0, iyy, imm, idd 41 INTEGER :: nt_a=2, nt_b=1, itobc, ndate0_cnes, nday_year0 42 INTEGER :: itobce, itobcw, itobcs, itobcn, itobc_b ! number of time steps in OBC files 43 44 INTEGER :: ntobc ! where we are in the obc file 45 INTEGER :: ntobc_b ! first record used 46 INTEGER :: ntobc_a ! second record used 47 48 CHARACTER (len=40) :: cl_obc_eTS, cl_obc_eU ! name of data files 49 CHARACTER (len=40) :: cl_obc_wTS, cl_obc_wU ! - - 50 CHARACTER (len=40) :: cl_obc_nTS, cl_obc_nV ! - - 51 CHARACTER (len=40) :: cl_obc_sTS, cl_obc_sV ! - - 52 53 ! bt arrays for interpolating time dependent data on the boundaries 54 INTEGER :: nt_m=0, ntobc_m 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtedta, vbtedta, sshedta ! East 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtwdta, vbtwdta, sshwdta ! West 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtndta, vbtndta, sshndta ! North 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtsdta, vbtsdta, sshsdta ! South 59 ! arrays used for interpolating time dependent data on the boundaries 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uedta, vedta, tedta, sedta ! East 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uwdta, vwdta, twdta, swdta ! West 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: undta, vndta, tndta, sndta ! North 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: usdta, vsdta, tsdta, ssdta ! South 64 65 ! Masks set to .TRUE. after successful allocation below 66 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltemsk, luemsk, lvemsk ! boolean msks 67 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltwmsk, luwmsk, lvwmsk ! used for outliers 68 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltnmsk, lunmsk, lvnmsk ! checks 69 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltsmsk, lusmsk, lvsmsk 70 71 !! * Substitutions 72 # include "obc_vectopt_loop_substitute.h90" 49 73 # include "domzgr_substitute.h90" 50 74 !!---------------------------------------------------------------------- 51 75 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 52 !! $Id$ 53 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)76 !! $Id$ 77 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 54 78 !!---------------------------------------------------------------------- 55 79 CONTAINS 56 80 57 SUBROUTINE obc_dta( kt, jit, time_offset ) 58 !!---------------------------------------------------------------------- 59 !! *** SUBROUTINE obc_dta *** 81 INTEGER FUNCTION obc_dta_alloc() 82 !!------------------------------------------------------------------- 83 !! *** ROUTINE obc_dta_alloc *** 84 !!------------------------------------------------------------------- 85 INTEGER :: ierr(2) 86 !!------------------------------------------------------------------- 87 # if defined key_dynspg_ts 88 ALLOCATE( & ! time-splitting : 0:jptobc 89 ! bt arrays for interpolating time dependent data on the boundaries 90 & ubtedta (jpj,0:jptobc) , vbtedta (jpj,0:jptobc) , sshedta (jpj,0:jptobc) , & 91 & ubtwdta (jpj,0:jptobc) , vbtwdta (jpj,0:jptobc) , sshwdta (jpj,0:jptobc) , & 92 & ubtndta (jpi,0:jptobc) , vbtndta (jpi,0:jptobc) , sshndta (jpi,0:jptobc) , & 93 & ubtsdta (jpi,0:jptobc) , vbtsdta (jpi,0:jptobc) , sshsdta (jpi,0:jptobc) , & 94 ! arrays used for interpolating time dependent data on the boundaries 95 & uedta(jpj,jpk,0:jptobc) , vedta(jpj,jpk,0:jptobc) , & 96 & tedta(jpj,jpk,0:jptobc) , sedta(jpj,jpk,0:jptobc) , & 97 & uwdta(jpj,jpk,0:jptobc) , vwdta(jpj,jpk,0:jptobc) , & 98 & twdta(jpj,jpk,0:jptobc) , swdta(jpj,jpk,0:jptobc) , & 99 & undta(jpi,jpk,0:jptobc) , vndta(jpi,jpk,0:jptobc) , & 100 & tndta(jpi,jpk,0:jptobc) , sndta(jpi,jpk,0:jptobc) , & 101 & usdta(jpi,jpk,0:jptobc) , vsdta(jpi,jpk,0:jptobc) , & 102 & tsdta(jpi,jpk,0:jptobc) , ssdta(jpi,jpk,0:jptobc) , STAT=ierr(1) ) 103 # else 104 ALLOCATE( & ! no time splitting : 1:jptobc 105 ! bt arrays for interpolating time dependent data on the boundaries 106 & ubtedta (jpj,jptobc) , vbtedta (jpj,jptobc) , sshedta (jpj,jptobc) , & 107 & ubtwdta (jpj,jptobc) , vbtwdta (jpj,jptobc) , sshwdta (jpj,jptobc) , & 108 & ubtndta (jpi,jptobc) , vbtndta (jpi,jptobc) , sshndta (jpi,jptobc) , & 109 & ubtsdta (jpi,jptobc) , vbtsdta (jpi,jptobc) , sshsdta (jpi,jptobc) , & 110 ! arrays used for interpolating time dependent data on the boundaries 111 & uedta(jpj,jpk,jptobc) , vedta(jpj,jpk,jptobc) , & 112 & tedta(jpj,jpk,jptobc) , sedta(jpj,jpk,jptobc) , & 113 & uwdta(jpj,jpk,jptobc) , vwdta(jpj,jpk,jptobc) , & 114 & twdta(jpj,jpk,jptobc) , swdta(jpj,jpk,jptobc) , & 115 & undta(jpi,jpk,jptobc) , vndta(jpi,jpk,jptobc) , & 116 & tndta(jpi,jpk,jptobc) , sndta(jpi,jpk,jptobc) , & 117 & usdta(jpi,jpk,jptobc) , vsdta(jpi,jpk,jptobc) , & 118 & tsdta(jpi,jpk,jptobc) , ssdta(jpi,jpk,jptobc) , STAT=ierr(1) ) 119 # endif 120 121 ALLOCATE( ltemsk(jpj,jpk) , luemsk(jpj,jpk) , lvemsk(jpj,jpk) , & 122 & ltwmsk(jpj,jpk) , luwmsk(jpj,jpk) , lvwmsk(jpj,jpk) , & 123 & ltnmsk(jpj,jpk) , lunmsk(jpj,jpk) , lvnmsk(jpj,jpk) , & 124 & ltsmsk(jpj,jpk) , lusmsk(jpj,jpk) , lvsmsk(jpj,jpk) , STAT=ierr(2) ) 125 126 obc_dta_alloc = MAXVAL( ierr ) 127 IF( lk_mpp ) CALL mpp_sum( obc_dta_alloc ) 128 129 IF( obc_dta_alloc == 0 ) THEN ! Initialise mask values following successful allocation 130 ! east ! west ! north ! south ! 131 ltemsk(:,:) = .TRUE. ; ltwmsk(:,:) = .TRUE. ; ltnmsk(:,:) = .TRUE. ; ltsmsk(:,:) = .TRUE. 132 luemsk(:,:) = .TRUE. ; luwmsk(:,:) = .TRUE. ; lunmsk(:,:) = .TRUE. ; lusmsk(:,:) = .TRUE. 133 lvemsk(:,:) = .TRUE. ; lvwmsk(:,:) = .TRUE. ; lvnmsk(:,:) = .TRUE. ; lvsmsk(:,:) = .TRUE. 134 END IF 135 ! 136 END FUNCTION obc_dta_alloc 137 138 139 SUBROUTINE obc_dta( kt ) 140 !!--------------------------------------------------------------------------- 141 !! *** SUBROUTINE obc_dta *** 60 142 !! 61 !! ** Purpose : Update external data for open boundary conditions 62 !! 63 !! ** Method : Use fldread.F90 64 !! 65 !!---------------------------------------------------------------------- 66 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 67 USE wrk_nemo, ONLY: wrk_2d_22, wrk_2d_23 ! 2D workspace 68 !! 69 INTEGER, INTENT( in ) :: kt ! ocean time-step index 70 INTEGER, INTENT( in ), OPTIONAL :: jit ! subcycle time-step index (for timesplitting option) 71 INTEGER, INTENT( in ), OPTIONAL :: time_offset ! time offset in units of timesteps. NB. if jit 72 ! is present then units = subcycle timesteps. 73 ! time_offset = 0 => get data at "now" time level 74 ! time_offset = -1 => get data at "before" time level 75 ! time_offset = +1 => get data at "after" time level 76 ! etc. 77 !! 78 INTEGER :: ib_obc, jfld, jstart, jend, ib, ii, ij, ik, igrd ! local indices 79 INTEGER, DIMENSION(jpbgrd) :: ilen1 80 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 143 !! ** Purpose : Find the climatological boundary arrays for the specified date, 144 !! The boundary arrays are netcdf files. Three possible cases: 145 !! - one time frame only in the file (time dimension = 1). 146 !! in that case the boundary data does not change in time. 147 !! - many time frames. In that case, if we have 12 frames 148 !! we assume monthly fields. 149 !! Else, we assume that time_counter is in seconds 150 !! since the beginning of either the current year or a reference 151 !! year given in the namelist. 152 !! (no check is done so far but one would have to check the "unit" 153 !! attribute of variable time_counter). 81 154 !! 82 155 !!--------------------------------------------------------------------------- 83 84 IF(wrk_in_use(2, 22,23) ) THEN 85 CALL ctl_stop('obc_dta: ERROR: requested workspace arrays are unavailable.') ; RETURN 156 INTEGER, INTENT( in ) :: kt ! ocean time-step index 157 ! 158 INTEGER, SAVE :: immfile, iyyfile ! 159 INTEGER :: nt ! record indices (incrementation) 160 REAL(wp) :: zsec, zxy, znum, zden ! time interpolation weight 161 !!--------------------------------------------------------------------------- 162 163 ! 0. initialisation : 164 ! -------------------- 165 IF ( kt == nit000 ) CALL obc_dta_ini ( kt ) 166 IF ( nobc_dta == 0 ) RETURN ! already done in obc_dta_ini 167 IF ( itobc == 1 ) RETURN ! case of only one time frame in file done in obc_dta_ini 168 169 ! in the following code, we assume that obc data are read from files, with more than 1 time frame in it 170 171 iyyfile=iyy ; immfile = 00 ! set component of the current file name 172 IF ( cffile /= 'annual') immfile = imm ! 173 IF ( ln_obc_clim ) iyyfile = 0000 ! assume that climatological files are labeled y0000 174 175 ! 1. Synchronize time of run with time of data files 176 !--------------------------------------------------- 177 ! nday_year is the day number in the current year ( 1 for 01/01 ) 178 zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 179 IF (ln_obc_clim) THEN 180 zjcnes = nday_year - 1 + zsec/rday 181 ELSE 182 zjcnes = zjcnes + rdt/rday 183 ENDIF 184 185 ! look for 'before' record number in the current file 186 ntobc = nrecbef () ! this function return the record number for 'before', relative to zjcnes 187 188 IF (MOD(kt-1,10)==0) THEN 189 IF (lwp) WRITE(numout,*) 'kt= ',kt,' zjcnes =', zjcnes,' ndastp =',ndastp, 'mm =',imm 86 190 END IF 87 191 88 ! Initialise data arrays once for all from initial conditions where required 89 !--------------------------------------------------------------------------- 90 IF( kt .eq. nit000 .and. .not. PRESENT(jit) ) THEN 91 92 ! Calculate depth-mean currents 93 !----------------------------- 94 pu2d => wrk_2d_22 95 pu2d => wrk_2d_23 96 97 pu2d(:,:) = 0.e0 98 pv2d(:,:) = 0.e0 99 100 DO ik = 1, jpkm1 !! Vertically integrated momentum trends 101 pu2d(:,:) = pu2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik) 102 pv2d(:,:) = pv2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik) 192 ! 2. read a new data if necessary 193 !-------------------------------- 194 IF ( ntobc /= ntobc_b ) THEN 195 ! we need to read the 'after' record 196 ! swap working index: 197 # if defined key_dynspg_ts 198 nt=nt_m ; nt_m=nt_b ; nt_b=nt 199 # endif 200 nt=nt_b ; nt_b=nt_a ; nt_a=nt 201 ntobc_b = ntobc 202 203 ! new record number : 204 ntobc_a = ntobc_a + 1 205 206 ! all tricky things related to record number, changing files etc... are managed by obc_read 207 208 CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile ) 209 210 ! update zjcnes_obc 211 # if defined key_dynspg_ts 212 ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 213 zjcnes_obc(nt_m)= ztcobc(ntobc_m) 214 # endif 215 zjcnes_obc(nt_b)= ztcobc(ntobc_b) 216 zjcnes_obc(nt_a)= ztcobc(ntobc_a) 217 ENDIF 218 219 ! 3. interpolation at each time step 220 ! ------------------------------------ 221 IF( ln_obc_clim) THEN 222 znum= MOD(zjcnes - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) ) 223 IF( znum < 0 ) znum = znum + REAL(nyear_len(1),wp) 224 zden= MOD(zjcnes_obc(nt_a) - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) ) 225 IF( zden < 0 ) zden = zden + REAL(nyear_len(1),wp) 226 ELSE 227 znum= zjcnes - zjcnes_obc(nt_b) 228 zden= zjcnes_obc(nt_a) - zjcnes_obc(nt_b) 229 ENDIF 230 zxy = znum / zden 231 232 IF( lp_obc_east ) THEN 233 ! fills sfoe, tfoe, ufoe ,vfoe 234 sfoe(:,:) = zxy * sedta (:,:,nt_a) + (1. - zxy)*sedta(:,:,nt_b) 235 tfoe(:,:) = zxy * tedta (:,:,nt_a) + (1. - zxy)*tedta(:,:,nt_b) 236 ufoe(:,:) = zxy * uedta (:,:,nt_a) + (1. - zxy)*uedta(:,:,nt_b) 237 vfoe(:,:) = zxy * vedta (:,:,nt_a) + (1. - zxy)*vedta(:,:,nt_b) 238 ENDIF 239 240 IF( lp_obc_west) THEN 241 ! fills sfow, tfow, ufow ,vfow 242 sfow(:,:) = zxy * swdta (:,:,nt_a) + (1. - zxy)*swdta(:,:,nt_b) 243 tfow(:,:) = zxy * twdta (:,:,nt_a) + (1. - zxy)*twdta(:,:,nt_b) 244 ufow(:,:) = zxy * uwdta (:,:,nt_a) + (1. - zxy)*uwdta(:,:,nt_b) 245 vfow(:,:) = zxy * vwdta (:,:,nt_a) + (1. - zxy)*vwdta(:,:,nt_b) 246 ENDIF 247 248 IF( lp_obc_north) THEN 249 ! fills sfon, tfon, ufon ,vfon 250 sfon(:,:) = zxy * sndta (:,:,nt_a) + (1. - zxy)*sndta(:,:,nt_b) 251 tfon(:,:) = zxy * tndta (:,:,nt_a) + (1. - zxy)*tndta(:,:,nt_b) 252 ufon(:,:) = zxy * undta (:,:,nt_a) + (1. - zxy)*undta(:,:,nt_b) 253 vfon(:,:) = zxy * vndta (:,:,nt_a) + (1. - zxy)*vndta(:,:,nt_b) 254 ENDIF 255 256 IF( lp_obc_south) THEN 257 ! fills sfos, tfos, ufos ,vfos 258 sfos(:,:) = zxy * ssdta (:,:,nt_a) + (1. - zxy)*ssdta(:,:,nt_b) 259 tfos(:,:) = zxy * tsdta (:,:,nt_a) + (1. - zxy)*tsdta(:,:,nt_b) 260 ufos(:,:) = zxy * usdta (:,:,nt_a) + (1. - zxy)*usdta(:,:,nt_b) 261 vfos(:,:) = zxy * vsdta (:,:,nt_a) + (1. - zxy)*vsdta(:,:,nt_b) 262 ENDIF 263 END SUBROUTINE obc_dta 264 265 266 SUBROUTINE obc_dta_ini( kt ) 267 !!----------------------------------------------------------------------------- 268 !! *** SUBROUTINE obc_dta_ini *** 269 !! 270 !! ** Purpose : When obc_dta first call, realize some data initialization 271 !!---------------------------------------------------------------------------- 272 INTEGER, INTENT(in) :: kt ! ocean time-step index 273 ! 274 INTEGER :: ji, jj ! dummy loop indices 275 INTEGER, SAVE :: immfile, iyyfile ! 276 277 ! variables for the julian day calculation 278 INTEGER :: iyear, imonth, iday 279 REAL(wp) :: zsec , zjulian, zjuliancnes 280 281 IF(lwp) WRITE(numout,*) 282 IF(lwp) WRITE(numout,*) 'obc_dta : find boundary data' 283 IF(lwp) WRITE(numout,*) '~~~~~~~' 284 IF (lwp) THEN 285 IF ( nobc_dta == 0 ) THEN 286 WRITE(numout,*) ' OBC data taken from initial conditions.' 287 ELSE 288 WRITE(numout,*) ' OBC data taken from netcdf files.' 289 ENDIF 290 ENDIF 291 nday_year0 = nday_year ! to remember the day when kt=nit000 292 293 sedta(:,:,:) = 0.e0 ; tedta(:,:,:) = 0.e0 ; uedta(:,:,:) = 0.e0 ; vedta(:,:,:) = 0.e0 ! East 294 swdta(:,:,:) = 0.e0 ; twdta(:,:,:) = 0.e0 ; uwdta(:,:,:) = 0.e0 ; vwdta(:,:,:) = 0.e0 ! West 295 sndta(:,:,:) = 0.e0 ; tndta(:,:,:) = 0.e0 ; undta(:,:,:) = 0.e0 ; vndta(:,:,:) = 0.e0 ! North 296 ssdta(:,:,:) = 0.e0 ; tsdta(:,:,:) = 0.e0 ; usdta(:,:,:) = 0.e0 ; vsdta(:,:,:) = 0.e0 ! South 297 298 sfoe(:,:) = 0.e0 ; tfoe(:,:) = 0.e0 ; ufoe(:,:) = 0.e0 ; vfoe(:,:) = 0.e0 ! East 299 sfow(:,:) = 0.e0 ; tfow(:,:) = 0.e0 ; ufow(:,:) = 0.e0 ; vfow(:,:) = 0.e0 ! West 300 sfon(:,:) = 0.e0 ; tfon(:,:) = 0.e0 ; ufon(:,:) = 0.e0 ; vfon(:,:) = 0.e0 ! North 301 sfos(:,:) = 0.e0 ; tfos(:,:) = 0.e0 ; ufos(:,:) = 0.e0 ; vfos(:,:) = 0.e0 ! South 302 303 IF (nobc_dta == 0 ) THEN ! boundary data are the initial data of this run (set only at nit000) 304 IF (lp_obc_east) THEN ! East 305 DO ji = nie0 , nie1 306 sfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * sn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 307 tfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * tn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 308 ufoe(nje0:nje1,:) = uemsk(nje0:nje1,:) * un (ji , nje0:nje1 , :) * umask(ji, nje0:nje1 , :) 309 vfoe(nje0:nje1,:) = vemsk(nje0:nje1,:) * vn (ji+1 , nje0:nje1 , :) * vmask(ji+1,nje0:nje1 , :) 310 END DO 311 ENDIF 312 313 IF (lp_obc_west) THEN ! West 314 DO ji = niw0 , niw1 315 sfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * sn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 316 tfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * tn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 317 ufow(njw0:njw1,:) = uwmsk(njw0:njw1,:) * un (ji , njw0:njw1 , :) * umask(ji , njw0:njw1 , :) 318 vfow(njw0:njw1,:) = vwmsk(njw0:njw1,:) * vn (ji , njw0:njw1 , :) * vmask(ji , njw0:njw1 , :) 319 END DO 320 ENDIF 321 322 IF (lp_obc_north) THEN ! North 323 DO jj = njn0 , njn1 324 sfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * sn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 325 tfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * tn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 326 ufon(nin0:nin1,:) = unmsk(nin0:nin1,:) * un (nin0:nin1 , jj+1 , :) * umask(nin0:nin1 , jj+1 , :) 327 vfon(nin0:nin1,:) = vnmsk(nin0:nin1,:) * vn (nin0:nin1 , jj , :) * vmask(nin0:nin1 , jj , :) 328 END DO 329 ENDIF 330 331 IF (lp_obc_south) THEN ! South 332 DO jj = njs0 , njs1 333 sfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * sn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 334 tfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * tn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 335 ufos(nis0:nis1,:) = usmsk(nis0:nis1,:) * un (nis0:nis1 , jj , :) * umask(nis0:nis1 , jj , :) 336 vfos(nis0:nis1,:) = vsmsk(nis0:nis1,:) * vn (nis0:nis1 , jj , :) * vmask(nis0:nis1 , jj , :) 337 END DO 338 ENDIF 339 RETURN ! exit the routine all is done 340 ENDIF ! nobc_dta = 0 341 342 !!!! In the following OBC data are read from files. 343 ! all logical-mask are initialzed to true when declared 344 WHERE ( temsk == 0 ) ltemsk=.FALSE. 345 WHERE ( uemsk == 0 ) luemsk=.FALSE. 346 WHERE ( vemsk == 0 ) lvemsk=.FALSE. 347 348 WHERE ( twmsk == 0 ) ltwmsk=.FALSE. 349 WHERE ( uwmsk == 0 ) luwmsk=.FALSE. 350 WHERE ( vwmsk == 0 ) lvwmsk=.FALSE. 351 352 WHERE ( tnmsk == 0 ) ltnmsk=.FALSE. 353 WHERE ( unmsk == 0 ) lunmsk=.FALSE. 354 WHERE ( vnmsk == 0 ) lvnmsk=.FALSE. 355 356 WHERE ( tsmsk == 0 ) ltsmsk=.FALSE. 357 WHERE ( usmsk == 0 ) lusmsk=.FALSE. 358 WHERE ( vsmsk == 0 ) lvsmsk=.FALSE. 359 360 iyear=1950; imonth=01; iday=01; zsec=0. 361 ! zjuliancnes : julian day corresonding to 01/01/1950 362 CALL ymds2ju(iyear, imonth, iday,zsec , zjuliancnes) 363 364 !current year and curent month 365 iyy=INT(ndastp/10000) ; imm=INT((ndastp -iyy*10000)/100) ; idd=(ndastp-iyy*10000-imm*100) 366 IF (iyy < 1900) iyy = iyy+1900 ! always assume that years are on 4 digits. 367 CALL ymds2ju(iyy, imm, idd ,zsec , zjulian) 368 ndate0_cnes = zjulian - zjuliancnes ! jcnes day when call to obc_dta_ini 369 370 iyyfile=iyy ; immfile=0 ! set component of the current file name 371 IF ( cffile /= 'annual') immfile=imm 372 IF ( ln_obc_clim) iyyfile = 0 ! assume that climatological files are labeled y0000 373 374 CALL obc_dta_chktime ( iyyfile, immfile ) 375 376 IF ( itobc == 1 ) THEN 377 ! in this case we will provide boundary data only once. 378 nt_a=1 ; ntobc_a=1 379 CALL obc_read (nit000, nt_a, ntobc_a, iyyfile, immfile) 380 IF( lp_obc_east ) THEN 381 ! fills sfoe, tfoe, ufoe ,vfoe 382 sfoe(:,:) = sedta (:,:,1) ; tfoe(:,:) = tedta (:,:,1) 383 ufoe(:,:) = uedta (:,:,1) ; vfoe(:,:) = vedta (:,:,1) 384 ENDIF 385 386 IF( lp_obc_west) THEN 387 ! fills sfow, tfow, ufow ,vfow 388 sfow(:,:) = swdta (:,:,1) ; tfow(:,:) = twdta (:,:,1) 389 ufow(:,:) = uwdta (:,:,1) ; vfow(:,:) = vwdta (:,:,1) 390 ENDIF 391 392 IF( lp_obc_north) THEN 393 ! fills sfon, tfon, ufon ,vfon 394 sfon(:,:) = sndta (:,:,1) ; tfon(:,:) = tndta (:,:,1) 395 ufon(:,:) = undta (:,:,1) ; vfon(:,:) = vndta (:,:,1) 396 ENDIF 397 398 IF( lp_obc_south) THEN 399 ! fills sfos, tfos, ufos ,vfos 400 sfos(:,:) = ssdta (:,:,1) ; tfos(:,:) = tsdta (:,:,1) 401 ufos(:,:) = usdta (:,:,1) ; vfos(:,:) = vsdta (:,:,1) 402 ENDIF 403 RETURN ! we go out of obc_dta_ini -------------------------------------->>>>> 404 ENDIF 405 406 ! nday_year is the day number in the current year ( 1 for 01/01 ) 407 ! we suppose that we always start from the begining of a day 408 ! zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 409 zsec=0.e0 ! here, kt=nit000, nday_year = ndat_year0 410 411 IF (ln_obc_clim) THEN 412 zjcnes = nday_year - 1 + zsec/rday ! for clim file time is in days in a year 413 ELSE 414 zjcnes = ndate0_cnes + (nday_year - nday_year0 ) + zsec/rday 415 ENDIF 416 417 ! look for 'before' record number in the current file 418 ntobc = nrecbef () 419 420 IF (lwp) WRITE(numout,*) 'obc files frequency :',cffile 421 IF (lwp) WRITE(numout,*) ' zjcnes0 =',zjcnes,' ndastp0 =',ndastp 422 IF (lwp) WRITE(numout,*) ' annee0 ',iyy,' month0 ', imm,' day0 ', idd 423 IF (lwp) WRITE(numout,*) 'first file open :',cl_obc_nTS 424 425 ! record initialisation 426 !-------------------- 427 nt_b = 1 ; nt_a = 2 428 429 ntobc_a = ntobc + 1 430 ntobc_b = ntobc 431 432 CALL obc_read (kt, nt_b, ntobc_b, iyyfile, immfile) ! read 'before' fields 433 CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile) ! read 'after' fields 434 435 ! additional frame in case of time-splitting 436 # if defined key_dynspg_ts 437 nt_m = 0 438 ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 439 zjcnes_obc(nt_m)= ztcobc(ntobc_m) ! FDbug has not checked that this is correct!! 440 IF (ln_rstart) THEN 441 CALL obc_read (kt, nt_m, ntobc_m, iyyfile, immfile) ! read 'after' fields 442 ENDIF 443 # endif 444 445 zjcnes_obc(nt_b)= ztcobc(ntobc_b) 446 zjcnes_obc(nt_a)= ztcobc(ntobc_a) 447 ! 448 END SUBROUTINE obc_dta_ini 449 450 451 SUBROUTINE obc_dta_chktime (kyyfile, kmmfile) 452 ! 453 ! check the number of time steps in the files and read ztcobc 454 ! 455 ! * Arguments 456 INTEGER, INTENT(in) :: kyyfile, kmmfile 457 ! * local variables 458 INTEGER :: istop ! error control 459 INTEGER :: ji ! dummy loop index 460 461 INTEGER :: idvar, id_e, id_w, id_n, id_s ! file identifiers 462 INTEGER, DIMENSION(1) :: itmp 463 CHARACTER(LEN=25) :: cl_vname 464 465 ntobc_a = 0; itobce =0 ; itobcw = 0; itobcn = 0; itobcs = 0 466 ! build file name 467 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 468 cl_obc_eTS='obceast_TS.nc' 469 cl_obc_wTS='obcwest_TS.nc' 470 cl_obc_nTS='obcnorth_TS.nc' 471 cl_obc_sTS='obcsouth_TS.nc' 472 ELSE ! convention for climatological OBC 473 WRITE(cl_obc_eTS ,'("obc_east_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 474 WRITE(cl_obc_wTS ,'("obc_west_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 475 WRITE(cl_obc_nTS ,'("obc_north_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 476 WRITE(cl_obc_sTS ,'("obc_south_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 477 ENDIF 478 479 cl_vname = 'time_counter' 480 IF ( lp_obc_east ) THEN 481 CALL iom_open ( cl_obc_eTS , id_e ) 482 idvar = iom_varid( id_e, cl_vname, kdimsz = itmp ); itobce=itmp(1) 483 ENDIF 484 IF ( lp_obc_west ) THEN 485 CALL iom_open ( cl_obc_wTS , id_w ) 486 idvar = iom_varid( id_w, cl_vname, kdimsz = itmp ) ; itobcw=itmp(1) 487 ENDIF 488 IF ( lp_obc_north ) THEN 489 CALL iom_open ( cl_obc_nTS , id_n ) 490 idvar = iom_varid( id_n, cl_vname, kdimsz = itmp ) ; itobcn=itmp(1) 491 ENDIF 492 IF ( lp_obc_south ) THEN 493 CALL iom_open ( cl_obc_sTS , id_s ) 494 idvar = iom_varid( id_s, cl_vname, kdimsz = itmp ) ; itobcs=itmp(1) 495 ENDIF 496 497 itobc = MAX( itobce, itobcw, itobcn, itobcs ) 498 istop = 0 499 IF ( lp_obc_east .AND. itobce /= itobc ) istop = istop+1 500 IF ( lp_obc_west .AND. itobcw /= itobc ) istop = istop+1 501 IF ( lp_obc_north .AND. itobcn /= itobc ) istop = istop+1 502 IF ( lp_obc_south .AND. itobcs /= itobc ) istop = istop+1 503 nstop = nstop + istop 504 505 IF ( istop /= 0 ) THEN 506 WRITE(ctmp1,*) ' east, west, north, south: ', itobce, itobcw, itobcn, itobcs 507 CALL ctl_stop( 'obcdta : all files must have the same number of time steps', ctmp1 ) 508 ENDIF 509 510 IF ( itobc == 1 ) THEN 511 IF (lwp) THEN 512 WRITE(numout,*) ' obcdta found one time step only in the OBC files' 513 IF (ln_obc_clim) THEN 514 ! OK no problem 515 ELSE 516 ln_obc_clim=.true. 517 WRITE(numout,*) ' we force ln_obc_clim to T' 518 ENDIF 519 ENDIF 520 ELSE 521 IF ( ALLOCATED(ztcobc) ) DEALLOCATE ( ztcobc ) 522 ALLOCATE (ztcobc(itobc)) 523 DO ji=1,1 ! use a dummy loop to read ztcobc only once 524 IF ( lp_obc_east ) THEN 525 CALL iom_gettime ( id_e, ztcobc, cl_vname ) ; CALL iom_close (id_e) ; EXIT 526 ENDIF 527 IF ( lp_obc_west ) THEN 528 CALL iom_gettime ( id_w, ztcobc, cl_vname ) ; CALL iom_close (id_w) ; EXIT 529 ENDIF 530 IF ( lp_obc_north ) THEN 531 CALL iom_gettime ( id_n, ztcobc, cl_vname ) ; CALL iom_close (id_n) ; EXIT 532 ENDIF 533 IF ( lp_obc_south ) THEN 534 CALL iom_gettime ( id_s, ztcobc, cl_vname ) ; CALL iom_close (id_s) ; EXIT 535 ENDIF 103 536 END DO 104 pu2d(:,:) = pu2d(:,:) * hur(:,:) 105 pv2d(:,:) = pv2d(:,:) * hvr(:,:) 106 107 DO ib_obc = 1, nb_obc 108 109 nblen => idx_obc(ib_obc)%nblen 110 nblenrim => idx_obc(ib_obc)%nblenrim 111 112 IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .eq. 0 ) THEN 113 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 114 ilen1(:) = nblen(:) 115 ELSE 116 ilen1(:) = nblenrim(:) 117 ENDIF 118 igrd = 1 119 DO ib = 1, ilen1(igrd) 120 ii = idx_obc(ib_obc)%nbi(ib,igrd) 121 ij = idx_obc(ib_obc)%nbj(ib,igrd) 122 dta_obc(ib_obc)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1) 123 END DO 124 igrd = 2 125 DO ib = 1, ilen1(igrd) 126 ii = idx_obc(ib_obc)%nbi(ib,igrd) 127 ij = idx_obc(ib_obc)%nbj(ib,igrd) 128 dta_obc(ib_obc)%u2d(ib) = pu2d(ii,ij) * umask(ii,ij,1) 129 END DO 130 igrd = 3 131 DO ib = 1, ilen1(igrd) 132 ii = idx_obc(ib_obc)%nbi(ib,igrd) 133 ij = idx_obc(ib_obc)%nbj(ib,igrd) 134 dta_obc(ib_obc)%v2d(ib) = pv2d(ii,ij) * vmask(ii,ij,1) 135 END DO 136 ENDIF 137 138 IF( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 0 ) THEN 139 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 140 ilen1(:) = nblen(:) 141 ELSE 142 ilen1(:) = nblenrim(:) 143 ENDIF 144 igrd = 2 145 DO ib = 1, ilen1(igrd) 146 DO ik = 1, jpkm1 147 ii = idx_obc(ib_obc)%nbi(ib,igrd) 148 ij = idx_obc(ib_obc)%nbj(ib,igrd) 149 dta_obc(ib_obc)%u3d(ib,ik) = ( un(ii,ij,ik) - pu2d(ii,ij) ) * umask(ii,ij,ik) 537 rdt_obc = ztcobc(2)-ztcobc(1) ! just an information, not used for any computation 538 IF (lwp) WRITE(numout,*) ' obcdta found', itobc,' time steps in the OBC files' 539 IF (lwp) WRITE(numout,*) ' time step of obc data :', rdt_obc,' days' 540 ENDIF 541 zjcnes = zjcnes - rdt/rday ! trick : zcnes is always incremented by rdt/rday in obc_dta! 542 END SUBROUTINE obc_dta_chktime 543 544 # if defined key_dynspg_ts || defined key_dynspg_exp 545 SUBROUTINE obc_dta_bt( kt, kbt ) 546 !!--------------------------------------------------------------------------- 547 !! *** SUBROUTINE obc_dta *** 548 !! 549 !! ** Purpose : time interpolation of barotropic data for time-splitting scheme 550 !! Data at the boundary must be in m2/s 551 !! 552 !! History : 9.0 ! 05-11 (V. garnier) Original code 553 !!--------------------------------------------------------------------------- 554 INTEGER, INTENT( in ) :: kt ! ocean time-step index 555 INTEGER, INTENT( in ) :: kbt ! barotropic ocean time-step index 556 ! 557 INTEGER :: ji, jj ! dummy loop indices 558 INTEGER :: i15 559 INTEGER :: itobcm, itobcp 560 REAL(wp) :: zxy 561 INTEGER :: isrel ! number of seconds since 1/1/1992 562 !!--------------------------------------------------------------------------- 563 564 ! 1. First call: check time frames available in files. 565 ! ------------------------------------------------------- 566 567 IF( kt == nit000 ) THEN 568 569 ! 1.1 Barotropic tangential velocities set to zero 570 ! ------------------------------------------------- 571 IF( lp_obc_east ) vbtfoe(:) = 0.e0 572 IF( lp_obc_west ) vbtfow(:) = 0.e0 573 IF( lp_obc_south ) ubtfos(:) = 0.e0 574 IF( lp_obc_north ) ubtfon(:) = 0.e0 575 576 ! 1.2 Sea surface height and normal barotropic velocities set to zero 577 ! or initial conditions if nobc_dta == 0 578 ! -------------------------------------------------------------------- 579 580 IF( lp_obc_east ) THEN 581 ! initialisation to zero 582 sshedta(:,:) = 0.e0 583 ubtedta(:,:) = 0.e0 584 vbtedta(:,:) = 0.e0 ! tangential component 585 ! ! ================== ! 586 IF( nobc_dta == 0 ) THEN ! initial state used ! 587 ! ! ================== ! 588 ! Fills sedta, tedta, uedta (global arrays) 589 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 590 DO ji = nie0, nie1 591 DO jj = 1, jpj 592 sshedta(jj,1) = sshn(ji+1,jj) * tmask(ji+1,jj,1) 150 593 END DO 151 END DO 152 igrd = 3 153 DO ib = 1, ilen1(igrd) 154 DO ik = 1, jpkm1 155 ii = idx_obc(ib_obc)%nbi(ib,igrd) 156 ij = idx_obc(ib_obc)%nbj(ib,igrd) 157 dta_obc(ib_obc)%v3d(ib,ik) = ( vn(ii,ij,ik) - pv2d(ii,ij) ) * vmask(ii,ij,ik) 158 END DO 159 END DO 160 ENDIF 161 162 IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 0 ) THEN 163 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 164 ilen1(:) = nblen(:) 165 ELSE 166 ilen1(:) = nblenrim(:) 167 ENDIF 168 igrd = 1 ! Everything is at T-points here 169 DO ib = 1, ilen1(igrd) 170 DO ik = 1, jpkm1 171 ii = idx_obc(ib_obc)%nbi(ib,igrd) 172 ij = idx_obc(ib_obc)%nbj(ib,igrd) 173 dta_obc(ib_obc)%tem(ib,ik) = tn(ii,ij,ik) * tmask(ii,ij,ik) 174 dta_obc(ib_obc)%sal(ib,ik) = sn(ii,ij,ik) * tmask(ii,ij,ik) 594 END DO 595 ENDIF 596 ENDIF 597 598 IF( lp_obc_west) THEN 599 ! initialisation to zero 600 sshwdta(:,:) = 0.e0 601 ubtwdta(:,:) = 0.e0 602 vbtwdta(:,:) = 0.e0 ! tangential component 603 ! ! ================== ! 604 IF( nobc_dta == 0 ) THEN ! initial state used ! 605 ! ! ================== ! 606 ! Fills swdta, twdta, uwdta (global arrays) 607 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 608 DO ji = niw0, niw1 609 DO jj = 1, jpj 610 sshwdta(jj,1) = sshn(ji,jj) * tmask(ji,jj,1) 175 611 END DO 176 END DO 177 ENDIF 178 179 #if defined key_lim2 180 IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 0 ) THEN 181 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 182 ilen1(:) = nblen(:) 183 ELSE 184 ilen1(:) = nblenrim(:) 185 ENDIF 186 igrd = 1 ! Everything is at T-points here 187 DO ib = 1, ilen1(igrd) 188 ii = idx_obc(ib_obc)%nbi(ib,igrd) 189 ij = idx_obc(ib_obc)%nbj(ib,igrd) 190 dta_obc(ib_obc)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1) 191 dta_obc(ib_obc)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1) 192 dta_obc(ib_obc)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1) 193 END DO 194 ENDIF 195 #endif 196 197 ENDDO ! ib_obc 198 199 ENDIF ! kt .eq. nit000 200 201 ! update external data from files 202 !-------------------------------- 203 204 jstart = 1 205 DO ib_obc = 1, nb_obc 206 IF( nn_dta(ib_obc) .eq. 1 ) THEN ! skip this bit if no external data required 207 208 IF( PRESENT(jit) ) THEN 209 ! Update barotropic boundary conditions only 210 ! jit is optional argument for fld_read and tide_update 211 IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 212 IF( nn_dyn2d_dta(ib_obc) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 213 dta_obc(ib_obc)%ssh(:) = 0.0 214 dta_obc(ib_obc)%u2d(:) = 0.0 215 dta_obc(ib_obc)%v2d(:) = 0.0 216 ENDIF 217 IF( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) THEN ! update external data 218 jend = jstart + 2 219 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), jit=jit, time_offset=time_offset ) 220 ENDIF 221 IF( nn_dyn2d_dta(ib_obc) .ge. 2 ) THEN ! update tidal harmonic forcing 222 CALL tide_update( kt=kt, idx=idx_obc(ib_obc), dta=dta_obc(ib_obc), td=tides(ib_obc), jit=jit, time_offset=time_offset ) 223 ENDIF 612 END DO 613 ENDIF 614 ENDIF 615 616 IF( lp_obc_north) THEN 617 ! initialisation to zero 618 sshndta(:,:) = 0.e0 619 ubtndta(:,:) = 0.e0 ! tangential component 620 vbtndta(:,:) = 0.e0 621 ! ! ================== ! 622 IF( nobc_dta == 0 ) THEN ! initial state used ! 623 ! ! ================== ! 624 ! Fills sndta, tndta, vndta (global arrays) 625 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 626 DO jj = njn0, njn1 627 DO ji = 1, jpi 628 sshndta(ji,1) = sshn(ji,jj+1) * tmask(ji,jj+1,1) 629 END DO 630 END DO 631 ENDIF 632 ENDIF 633 634 IF( lp_obc_south) THEN 635 ! initialisation to zero 636 sshsdta(:,:) = 0.e0 637 ubtsdta(:,:) = 0.e0 ! tangential component 638 vbtsdta(:,:) = 0.e0 639 ! ! ================== ! 640 IF( nobc_dta == 0 ) THEN ! initial state used ! 641 ! ! ================== ! 642 ! Fills ssdta, tsdta, vsdta (global arrays) 643 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 644 DO jj = njs0, njs1 645 DO ji = 1, jpi 646 sshsdta(ji,1) = sshn(ji,jj) * tmask(ji,jj,1) 647 END DO 648 END DO 649 ENDIF 650 ENDIF 651 652 IF( nobc_dta == 0 ) CALL obc_depth_average(1) ! depth averaged velocity from the OBC depth-dependent frames 653 654 ENDIF ! END kt == nit000 655 656 !!------------------------------------------------------------------------------------ 657 ! 2. Initialize the time we are at. Does this every time the routine is called, 658 ! excepted when nobc_dta = 0 659 ! 660 661 ! 3. Call at every time step : Linear interpolation of BCs to current time step 662 ! ---------------------------------------------------------------------- 663 664 IF( lk_dynspg_ts ) THEN 665 isrel = (kt-1)*rdt + kbt*(rdt/REAL(nn_baro,wp)) 666 ELSE IF( lk_dynspg_exp ) THEN 667 isrel=kt*rdt 668 ENDIF 669 670 itobcm = nt_b 671 itobcp = nt_a 672 IF( itobc == 1 .OR. nobc_dta == 0 ) THEN 673 zxy = 0.e0 674 itobcm = 1 675 itobcp = 1 676 ELSE IF( itobc == 12 ) THEN 677 i15 = nday / 16 678 zxy = FLOAT( nday + 15 - 30 * i15 ) / 30. 679 ELSE 680 zxy = (zjcnes_obc(nt_a)-FLOAT(isrel)) / (zjcnes_obc(nt_a)-zjcnes_obc(nt_b)) 681 IF( zxy < 0. ) THEN ! case of extrapolation, switch to old time frames 682 itobcm = nt_m 683 itobcp = nt_b 684 zxy = (zjcnes_obc(nt_b)-FLOAT(isrel)) / (zjcnes_obc(nt_b)-zjcnes_obc(nt_m)) 685 ENDIF 686 ENDIF 687 688 IF( lp_obc_east ) THEN ! fills sshfoe, ubtfoe (local to each processor) 689 DO jj = 1, jpj 690 sshfoe(jj) = zxy * sshedta(jj,itobcp) + (1.-zxy) * sshedta(jj,itobcm) 691 ubtfoe(jj) = zxy * ubtedta(jj,itobcp) + (1.-zxy) * ubtedta(jj,itobcm) 692 vbtfoe(jj) = zxy * vbtedta(jj,itobcp) + (1.-zxy) * vbtedta(jj,itobcm) 693 END DO 694 ENDIF 695 696 IF( lp_obc_west) THEN ! fills sshfow, ubtfow (local to each processor) 697 DO jj = 1, jpj 698 sshfow(jj) = zxy * sshwdta(jj,itobcp) + (1.-zxy) * sshwdta(jj,itobcm) 699 ubtfow(jj) = zxy * ubtwdta(jj,itobcp) + (1.-zxy) * ubtwdta(jj,itobcm) 700 vbtfow(jj) = zxy * vbtwdta(jj,itobcp) + (1.-zxy) * vbtwdta(jj,itobcm) 701 END DO 702 ENDIF 703 704 IF( lp_obc_north) THEN ! fills sshfon, vbtfon (local to each processor) 705 DO ji = 1, jpi 706 sshfon(ji) = zxy * sshndta(ji,itobcp) + (1.-zxy) * sshndta(ji,itobcm) 707 ubtfon(ji) = zxy * ubtndta(ji,itobcp) + (1.-zxy) * ubtndta(ji,itobcm) 708 vbtfon(ji) = zxy * vbtndta(ji,itobcp) + (1.-zxy) * vbtndta(ji,itobcm) 709 END DO 710 ENDIF 711 712 IF( lp_obc_south) THEN ! fills sshfos, vbtfos (local to each processor) 713 DO ji = 1, jpi 714 sshfos(ji) = zxy * sshsdta(ji,itobcp) + (1.-zxy) * sshsdta(ji,itobcm) 715 ubtfos(ji) = zxy * ubtsdta(ji,itobcp) + (1.-zxy) * ubtsdta(ji,itobcm) 716 vbtfos(ji) = zxy * vbtsdta(ji,itobcp) + (1.-zxy) * vbtsdta(ji,itobcm) 717 END DO 718 ENDIF 719 720 END SUBROUTINE obc_dta_bt 721 722 # else 723 !!----------------------------------------------------------------------------- 724 !! Default option 725 !!----------------------------------------------------------------------------- 726 SUBROUTINE obc_dta_bt ( kt, kbt ) ! Empty routine 727 !! * Arguments 728 INTEGER,INTENT(in) :: kt 729 INTEGER, INTENT( in ) :: kbt ! barotropic ocean time-step index 730 WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kt 731 WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kbt 732 END SUBROUTINE obc_dta_bt 733 # endif 734 735 SUBROUTINE obc_read (kt, nt_x, ntobc_x, iyy, imm) 736 !!------------------------------------------------------------------------- 737 !! *** ROUTINE obc_read *** 738 !! 739 !! ** Purpose : Read the boundary data in files identified by iyy and imm 740 !! According to the validated open boundaries, return the 741 !! following arrays : 742 !! sedta, tedta : East OBC salinity and temperature 743 !! uedta, vedta : " " u and v velocity component 744 !! 745 !! swdta, twdta : West OBC salinity and temperature 746 !! uwdta, vwdta : " " u and v velocity component 747 !! 748 !! sndta, tndta : North OBC salinity and temperature 749 !! undta, vndta : " " u and v velocity component 750 !! 751 !! ssdta, tsdta : South OBC salinity and temperature 752 !! usdta, vsdta : " " u and v velocity component 753 !! 754 !! ** Method : These fields are read in the record ntobc_x of the files. 755 !! The number of records is already known. If ntobc_x is greater 756 !! than the number of record, this routine will look for next file, 757 !! updating the indices (case of inter-annual obcs) or loop at the 758 !! begining in case of climatological file (ln_obc_clim = true ). 759 !! ------------------------------------------------------------------------- 760 !! History: ! 2005 ( P. Mathiot, C. Langlais ) Original code 761 !! ! 2008 ( J,M, Molines ) Use IOM and cleaning 762 !!-------------------------------------------------------------------------- 763 764 ! * Arguments 765 INTEGER, INTENT( in ) :: kt, nt_x 766 INTEGER, INTENT( inout ) :: ntobc_x , iyy, imm ! yes ! inout ! 767 768 ! * Local variables 769 CHARACTER (len=40) :: & ! file names 770 cl_obc_eTS , cl_obc_eU, cl_obc_eV,& 771 cl_obc_wTS , cl_obc_wU, cl_obc_wV,& 772 cl_obc_nTS , cl_obc_nU, cl_obc_nV,& 773 cl_obc_sTS , cl_obc_sU, cl_obc_sV 774 775 INTEGER :: ikprint 776 REAL(wp) :: zmin, zmax ! control of boundary values 777 778 !IOM stuff 779 INTEGER :: id_e, id_w, id_n, id_s 780 INTEGER, DIMENSION(2) :: istart, icount 781 782 !-------------------------------------------------------------------------- 783 IF ( ntobc_x > itobc ) THEN 784 IF (ln_obc_clim) THEN ! just loop on the same file 785 ntobc_x = 1 786 ELSE 787 ! need to change file : it is always for an 'after' data 788 IF ( cffile == 'annual' ) THEN ! go to next year file 789 iyy = iyy + 1 790 ELSE IF ( cffile =='monthly' ) THEN ! go to next month file 791 imm = imm + 1 792 IF ( imm == 13 ) THEN 793 imm = 1 ; iyy = iyy + 1 224 794 ENDIF 225 795 ELSE 226 IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 227 dta_obc(ib_obc)%ssh(:) = 0.0 228 dta_obc(ib_obc)%u2d(:) = 0.0 229 dta_obc(ib_obc)%v2d(:) = 0.0 230 ENDIF 231 IF( nb_obc_fld(ib_obc) .gt. 0 ) THEN ! update external data 232 jend = jstart + nb_obc_fld(ib_obc) - 1 233 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), time_offset=time_offset ) 234 ENDIF 235 IF( nn_dyn2d(ib_obc) .gt. 0 .and. nn_dyn2d_dta(ib_obc) .ge. 2 ) THEN ! update tidal harmonic forcing 236 CALL tide_update( kt=kt, idx=idx_obc(ib_obc), dta=dta_obc(ib_obc), td=tides(ib_obc), time_offset=time_offset ) 237 ENDIF 238 ENDIF 239 jstart = jend+1 240 241 ! If full velocities in boundary data then split into barotropic and baroclinic data 242 ! (Note that we have already made sure that you can't use ln_full_vel = .true. at the same 243 ! time as the dynspg_ts option). 244 245 IF( ln_full_vel_array(ib_obc) .and. & 246 & ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 .or. nn_dyn3d_dta(ib_obc) .eq. 1 ) ) THEN 247 248 igrd = 2 ! zonal velocity 249 dta_obc(ib_obc)%u2d(:) = 0.0 250 DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 251 ii = idx_obc(ib_obc)%nbi(ib,igrd) 252 ij = idx_obc(ib_obc)%nbj(ib,igrd) 253 DO ik = 1, jpkm1 254 dta_obc(ib_obc)%u2d(ib) = dta_obc(ib_obc)%u2d(ib) & 255 & + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta_obc(ib_obc)%u3d(ib,ik) 256 END DO 257 dta_obc(ib_obc)%u2d(ib) = dta_obc(ib_obc)%u2d(ib) * hur(ii,ij) 258 DO ik = 1, jpkm1 259 dta_obc(ib_obc)%u3d(ib,ik) = dta_obc(ib_obc)%u3d(ib,ik) - dta_obc(ib_obc)%u2d(ib) 796 ctmp1='obcread : this type of obc file is not supported :( ' 797 ctmp2=TRIM(cffile) 798 CALL ctl_stop (ctmp1, ctmp2) 799 ! cffile should be either annual or monthly ... 800 ENDIF 801 ! as the file is changed, need to update itobc etc ... 802 CALL obc_dta_chktime (iyy,imm) 803 ntobc_x = nrecbef() + 1 ! remember : this case occur for an after data 804 ENDIF 805 ENDIF 806 807 IF( lp_obc_east ) THEN 808 ! ... Read datafile and set temperature, salinity and normal velocity 809 ! ... initialise the sedta, tedta, uedta arrays 810 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 811 cl_obc_eTS='obceast_TS.nc' 812 cl_obc_eU ='obceast_U.nc' 813 cl_obc_eV ='obceast_V.nc' 814 ELSE ! convention for climatological OBC 815 WRITE(cl_obc_eTS ,'("obc_east_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 816 WRITE(cl_obc_eU ,'("obc_east_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 817 WRITE(cl_obc_eV ,'("obc_east_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 818 ENDIF 819 ! JMM this may change depending on the obc data format ... 820 istart(:)=(/nje0+njmpp-1,1/) ; icount(:)=(/nje1-nje0 +1,jpk/) 821 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_eTS) 822 IF (nje1 >= nje0 ) THEN 823 CALL iom_open ( cl_obc_eTS , id_e ) 824 CALL iom_get ( id_e, jpdom_unknown, 'votemper', tedta(nje0:nje1,:,nt_x), & 825 & ktime=ntobc_x , kstart=istart, kcount= icount ) 826 CALL iom_get ( id_e, jpdom_unknown, 'vosaline', sedta(nje0:nje1,:,nt_x), & 827 & ktime=ntobc_x , kstart=istart, kcount= icount ) 828 # if defined key_dynspg_ts || defined key_dynspg_exp 829 CALL iom_get ( id_e, jpdom_unknown, 'vossurfh', sshedta(nje0:nje1,nt_x), & 830 & ktime=ntobc_x , kstart=istart, kcount= icount ) 831 # endif 832 CALL iom_close (id_e) 833 ! 834 CALL iom_open ( cl_obc_eU , id_e ) 835 CALL iom_get ( id_e, jpdom_unknown, 'vozocrtx', uedta(nje0:nje1,:,nt_x), & 836 & ktime=ntobc_x , kstart=istart, kcount= icount ) 837 CALL iom_close ( id_e ) 838 ! 839 CALL iom_open ( cl_obc_eV , id_e ) 840 CALL iom_get ( id_e, jpdom_unknown, 'vomecrty', vedta(nje0:nje1,:,nt_x), & 841 & ktime=ntobc_x , kstart=istart, kcount= icount ) 842 CALL iom_close ( id_e ) 843 844 ! mask the boundary values 845 tedta(:,:,nt_x) = tedta(:,:,nt_x)*temsk(:,:) ; sedta(:,:,nt_x) = sedta(:,:,nt_x)*temsk(:,:) 846 uedta(:,:,nt_x) = uedta(:,:,nt_x)*uemsk(:,:) ; vedta(:,:,nt_x) = vedta(:,:,nt_x)*vemsk(:,:) 847 848 ! check any outliers 849 zmin=MINVAL( sedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(sedta(:,:,nt_x), mask=ltemsk) 850 IF ( zmin < 5 .OR. zmax > 50) THEN 851 CALL ctl_stop('Error in sedta',' routine obcdta') 852 ENDIF 853 zmin=MINVAL( tedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(tedta(:,:,nt_x), mask=ltemsk) 854 IF ( zmin < -10. .OR. zmax > 40) THEN 855 CALL ctl_stop('Error in tedta',' routine obcdta') 856 ENDIF 857 zmin=MINVAL( uedta(:,:,nt_x), mask=luemsk ) ; zmax=MAXVAL(uedta(:,:,nt_x), mask=luemsk) 858 IF ( zmin < -5. .OR. zmax > 5.) THEN 859 CALL ctl_stop('Error in uedta',' routine obcdta') 860 ENDIF 861 zmin=MINVAL( vedta(:,:,nt_x), mask=lvemsk ) ; zmax=MAXVAL(vedta(:,:,nt_x), mask=lvemsk) 862 IF ( zmin < -5. .OR. zmax > 5.) THEN 863 CALL ctl_stop('Error in vedta',' routine obcdta') 864 ENDIF 865 866 ! Usually printout is done only once at kt = nit000, unless nprint (namelist) > 1 867 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 868 WRITE(numout,*) 869 WRITE(numout,*) ' Read East OBC data records ', ntobc_x 870 ikprint = jpj/20 +1 871 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 872 CALL prihre( tedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 873 WRITE(numout,*) 874 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 875 CALL prihre( sedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 876 WRITE(numout,*) 877 WRITE(numout,*) ' Normal velocity U record 1 - printout every 3 level' 878 CALL prihre( uedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 879 WRITE(numout,*) 880 WRITE(numout,*) ' Tangential velocity V record 1 - printout every 3 level' 881 CALL prihre( vedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 882 ENDIF 883 ENDIF 884 ENDIF 885 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 886 IF ( lp_obc_west ) THEN 887 ! ... Read datafile and set temperature, salinity and normal velocity 888 ! ... initialise the swdta, twdta, uwdta arrays 889 IF (ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 890 cl_obc_wTS='obcwest_TS.nc' 891 cl_obc_wU ='obcwest_U.nc' 892 cl_obc_wV ='obcwest_V.nc' 893 ELSE ! convention for climatological OBC 894 WRITE(cl_obc_wTS ,'("obc_west_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 895 WRITE(cl_obc_wU ,'("obc_west_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 896 WRITE(cl_obc_wV ,'("obc_west_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 897 ENDIF 898 istart(:)=(/njw0+njmpp-1,1/) ; icount(:)=(/njw1-njw0 +1,jpk/) 899 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_wTS) 900 901 IF ( njw1 >= njw0 ) THEN 902 CALL iom_open ( cl_obc_wTS , id_w ) 903 CALL iom_get ( id_w, jpdom_unknown, 'votemper', twdta(njw0:njw1,:,nt_x), & 904 & ktime=ntobc_x , kstart=istart, kcount= icount ) 905 906 CALL iom_get ( id_w, jpdom_unknown, 'vosaline', swdta(njw0:njw1,:,nt_x), & 907 & ktime=ntobc_x , kstart=istart, kcount= icount) 908 # if defined key_dynspg_ts || defined key_dynspg_exp 909 CALL iom_get ( id_w, jpdom_unknown, 'vossurfh', sshwdta(njw0:njw1,nt_x), & 910 & ktime=ntobc_x , kstart=istart, kcount= icount ) 911 # endif 912 CALL iom_close (id_w) 913 ! 914 CALL iom_open ( cl_obc_wU , id_w ) 915 CALL iom_get ( id_w, jpdom_unknown, 'vozocrtx', uwdta(njw0:njw1,:,nt_x),& 916 & ktime=ntobc_x , kstart=istart, kcount= icount ) 917 CALL iom_close ( id_w ) 918 ! 919 CALL iom_open ( cl_obc_wV , id_w ) 920 CALL iom_get ( id_w, jpdom_unknown, 'vomecrty', vwdta(njw0:njw1,:,nt_x), & 921 & ktime=ntobc_x , kstart=istart, kcount= icount ) 922 CALL iom_close ( id_w ) 923 924 ! mask the boundary values 925 twdta(:,:,nt_x) = twdta(:,:,nt_x)*twmsk(:,:) ; swdta(:,:,nt_x) = swdta(:,:,nt_x)*twmsk(:,:) 926 uwdta(:,:,nt_x) = uwdta(:,:,nt_x)*uwmsk(:,:) ; vwdta(:,:,nt_x) = vwdta(:,:,nt_x)*vwmsk(:,:) 927 928 ! check any outliers 929 zmin=MINVAL( swdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(swdta(:,:,nt_x), mask=ltwmsk) 930 IF ( zmin < 5 .OR. zmax > 50) THEN 931 CALL ctl_stop('Error in swdta',' routine obcdta') 932 ENDIF 933 zmin=MINVAL( twdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(twdta(:,:,nt_x), mask=ltwmsk) 934 IF ( zmin < -10. .OR. zmax > 40) THEN 935 CALL ctl_stop('Error in twdta',' routine obcdta') 936 ENDIF 937 zmin=MINVAL( uwdta(:,:,nt_x), mask=luwmsk ) ; zmax=MAXVAL(uwdta(:,:,nt_x), mask=luwmsk) 938 IF ( zmin < -5. .OR. zmax > 5.) THEN 939 CALL ctl_stop('Error in uwdta',' routine obcdta') 940 ENDIF 941 zmin=MINVAL( vwdta(:,:,nt_x), mask=lvwmsk ) ; zmax=MAXVAL(vwdta(:,:,nt_x), mask=lvwmsk) 942 IF ( zmin < -5. .OR. zmax > 5.) THEN 943 CALL ctl_stop('Error in vwdta',' routine obcdta') 944 ENDIF 945 946 947 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 948 WRITE(numout,*) 949 WRITE(numout,*) ' Read West OBC data records ', ntobc_x 950 ikprint = jpj/20 +1 951 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 952 CALL prihre( twdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 953 WRITE(numout,*) 954 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 955 CALL prihre( swdta(:,:,nt_x),jpj,jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 956 WRITE(numout,*) 957 WRITE(numout,*) ' Normal velocity U record 1 - printout every 3 level' 958 CALL prihre( uwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 959 WRITE(numout,*) 960 WRITE(numout,*) ' Tangential velocity V record 1 - printout every 3 level' 961 CALL prihre( vwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 962 ENDIF 963 END IF 964 ENDIF 965 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 966 IF( lp_obc_north) THEN 967 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 968 cl_obc_nTS='obcnorth_TS.nc' 969 cl_obc_nU ='obcnorth_U.nc' 970 cl_obc_nV ='obcnorth_V.nc' 971 ELSE ! convention for climatological OBC 972 WRITE(cl_obc_nTS ,'("obc_north_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 973 WRITE(cl_obc_nV ,'("obc_north_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 974 WRITE(cl_obc_nU ,'("obc_north_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 975 ENDIF 976 istart(:)=(/nin0+nimpp-1,1/) ; icount(:)=(/nin1-nin0 +1,jpk/) 977 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_nTS) 978 IF ( nin1 >= nin0 ) THEN 979 CALL iom_open ( cl_obc_nTS , id_n ) 980 CALL iom_get ( id_n, jpdom_unknown, 'votemper', tndta(nin0:nin1,:,nt_x), & 981 & ktime=ntobc_x , kstart=istart, kcount= icount ) 982 CALL iom_get ( id_n, jpdom_unknown, 'vosaline', sndta(nin0:nin1,:,nt_x), & 983 & ktime=ntobc_x , kstart=istart, kcount= icount ) 984 # if defined key_dynspg_ts || defined key_dynspg_exp 985 CALL iom_get ( id_n, jpdom_unknown, 'vossurfh', sshndta(nin0:nin1,nt_x), & 986 & ktime=ntobc_x , kstart=istart, kcount= icount ) 987 # endif 988 CALL iom_close (id_n) 989 ! 990 CALL iom_open ( cl_obc_nU , id_n ) 991 CALL iom_get ( id_n, jpdom_unknown, 'vozocrtx', undta(nin0:nin1,:,nt_x), & 992 & ktime=ntobc_x , kstart=istart, kcount= icount ) 993 CALL iom_close ( id_n ) 994 ! 995 CALL iom_open ( cl_obc_nV , id_n ) 996 CALL iom_get ( id_n, jpdom_unknown, 'vomecrty', vndta(nin0:nin1,:,nt_x), & 997 & ktime=ntobc_x , kstart=istart, kcount= icount ) 998 CALL iom_close ( id_n ) 999 1000 ! mask the boundary values 1001 tndta(:,:,nt_x) = tndta(:,:,nt_x)*tnmsk(:,:) ; sndta(:,:,nt_x) = sndta(:,:,nt_x)*tnmsk(:,:) 1002 undta(:,:,nt_x) = undta(:,:,nt_x)*unmsk(:,:) ; vndta(:,:,nt_x) = vndta(:,:,nt_x)*vnmsk(:,:) 1003 1004 ! check any outliers 1005 zmin=MINVAL( sndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(sndta(:,:,nt_x), mask=ltnmsk) 1006 IF ( zmin < 5 .OR. zmax > 50) THEN 1007 CALL ctl_stop('Error in sndta',' routine obcdta') 1008 ENDIF 1009 zmin=MINVAL( tndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(tndta(:,:,nt_x), mask=ltnmsk) 1010 IF ( zmin < -10. .OR. zmax > 40) THEN 1011 CALL ctl_stop('Error in tndta',' routine obcdta') 1012 ENDIF 1013 zmin=MINVAL( undta(:,:,nt_x), mask=lunmsk ) ; zmax=MAXVAL(undta(:,:,nt_x), mask=lunmsk) 1014 IF ( zmin < -5. .OR. zmax > 5.) THEN 1015 CALL ctl_stop('Error in undta',' routine obcdta') 1016 ENDIF 1017 zmin=MINVAL( vndta(:,:,nt_x), mask=lvnmsk ) ; zmax=MAXVAL(vndta(:,:,nt_x), mask=lvnmsk) 1018 IF ( zmin < -5. .OR. zmax > 5.) THEN 1019 CALL ctl_stop('Error in vndta',' routine obcdta') 1020 ENDIF 1021 1022 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 1023 WRITE(numout,*) 1024 WRITE(numout,*) ' Read North OBC data records ', ntobc_x 1025 ikprint = jpi/20 +1 1026 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 1027 CALL prihre( tndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1028 WRITE(numout,*) 1029 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 1030 CALL prihre( sndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1031 WRITE(numout,*) 1032 WRITE(numout,*) ' Normal velocity V record 1 - printout every 3 level' 1033 CALL prihre( vndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1034 WRITE(numout,*) 1035 WRITE(numout,*) ' Tangential velocity U record 1 - printout every 3 level' 1036 CALL prihre( undta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1037 ENDIF 1038 ENDIF 1039 ENDIF 1040 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1041 IF( lp_obc_south) THEN 1042 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 1043 cl_obc_sTS='obcsouth_TS.nc' 1044 cl_obc_sU ='obcsouth_U.nc' 1045 cl_obc_sV ='obcsouth_V.nc' 1046 ELSE ! convention for climatological OBC 1047 WRITE(cl_obc_sTS ,'("obc_south_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1048 WRITE(cl_obc_sV ,'("obc_south_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1049 WRITE(cl_obc_sU ,'("obc_south_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1050 ENDIF 1051 istart(:)=(/nis0+nimpp-1,1/) ; icount(:)=(/nis1-nis0 +1,jpk/) 1052 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_sTS) 1053 IF ( nis1 >= nis0 ) THEN 1054 CALL iom_open ( cl_obc_sTS , id_s ) 1055 CALL iom_get ( id_s, jpdom_unknown, 'votemper', tsdta(nis0:nis1,:,nt_x), & 1056 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1057 CALL iom_get ( id_s, jpdom_unknown, 'vosaline', ssdta(nis0:nis1,:,nt_x), & 1058 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1059 # if defined key_dynspg_ts || defined key_dynspg_exp 1060 CALL iom_get ( id_s, jpdom_unknown, 'vossurfh', sshsdta(nis0:nis1,nt_x), & 1061 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1062 # endif 1063 CALL iom_close (id_s) 1064 ! 1065 CALL iom_open ( cl_obc_sU , id_s ) 1066 CALL iom_get ( id_s, jpdom_unknown, 'vozocrtx', usdta(nis0:nis1,:,nt_x), & 1067 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1068 CALL iom_close ( id_s ) 1069 ! 1070 CALL iom_open ( cl_obc_sV , id_s ) 1071 CALL iom_get ( id_s, jpdom_unknown, 'vomecrty', vsdta(nis0:nis1,:,nt_x), & 1072 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1073 CALL iom_close ( id_s ) 1074 1075 ! mask the boundary values 1076 tsdta(:,:,nt_x) = tsdta(:,:,nt_x)*tsmsk(:,:) ; ssdta(:,:,nt_x) = ssdta(:,:,nt_x)*tsmsk(:,:) 1077 usdta(:,:,nt_x) = usdta(:,:,nt_x)*usmsk(:,:) ; vsdta(:,:,nt_x) = vsdta(:,:,nt_x)*vsmsk(:,:) 1078 1079 ! check any outliers 1080 zmin=MINVAL( ssdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(ssdta(:,:,nt_x), mask=ltsmsk) 1081 IF ( zmin < 5 .OR. zmax > 50) THEN 1082 CALL ctl_stop('Error in ssdta',' routine obcdta') 1083 ENDIF 1084 zmin=MINVAL( tsdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(tsdta(:,:,nt_x), mask=ltsmsk) 1085 IF ( zmin < -10. .OR. zmax > 40) THEN 1086 CALL ctl_stop('Error in tsdta',' routine obcdta') 1087 ENDIF 1088 zmin=MINVAL( usdta(:,:,nt_x), mask=lusmsk ) ; zmax=MAXVAL(usdta(:,:,nt_x), mask=lusmsk) 1089 IF ( zmin < -5. .OR. zmax > 5.) THEN 1090 CALL ctl_stop('Error in usdta',' routine obcdta') 1091 ENDIF 1092 zmin=MINVAL( vsdta(:,:,nt_x), mask=lvsmsk ) ; zmax=MAXVAL(vsdta(:,:,nt_x), mask=lvsmsk) 1093 IF ( zmin < -5. .OR. zmax > 5.) THEN 1094 CALL ctl_stop('Error in vsdta',' routine obcdta') 1095 ENDIF 1096 1097 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 1098 WRITE(numout,*) 1099 WRITE(numout,*) ' Read South OBC data records ', ntobc_x 1100 ikprint = jpi/20 +1 1101 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 1102 CALL prihre( tsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1103 WRITE(numout,*) 1104 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 1105 CALL prihre( ssdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1106 WRITE(numout,*) 1107 WRITE(numout,*) ' Normal velocity V record 1 - printout every 3 level' 1108 CALL prihre( vsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1109 WRITE(numout,*) 1110 WRITE(numout,*) ' Tangential velocity U record 1 - printout every 3 level' 1111 CALL prihre( usdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1112 ENDIF 1113 ENDIF 1114 ENDIF 1115 1116 # if defined key_dynspg_ts || defined key_dynspg_exp 1117 CALL obc_depth_average(nt_x) ! computation of depth-averaged velocity 1118 # endif 1119 1120 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1121 END SUBROUTINE obc_read 1122 1123 1124 INTEGER FUNCTION nrecbef() 1125 !!----------------------------------------------------------------------- 1126 !! *** FUNCTION nrecbef *** 1127 !! 1128 !! Purpose : - provide the before record number in files, with respect to zjcnes 1129 !! 1130 !! History : 2008-04 : ( J.M. Molines ) Original code 1131 !!----------------------------------------------------------------------- 1132 1133 INTEGER :: it , idum 1134 1135 idum = itobc 1136 DO it =1, itobc 1137 IF ( ztcobc(it) > zjcnes ) THEN ; idum = it - 1 ; EXIT ; ENDIF 1138 ENDDO 1139 ! idum can be 0 (climato, before first record) 1140 IF ( idum == 0 ) THEN 1141 IF ( ln_obc_clim ) THEN 1142 idum = itobc 1143 ELSE 1144 ctmp1='obc_dta: find ntobc == 0 for non climatological file ' 1145 ctmp2='consider adding a first record in your data file ' 1146 CALL ctl_stop(ctmp1, ctmp2) 1147 ENDIF 1148 ENDIF 1149 ! idum can be itobc ( zjcnes > ztcobc (itobc) ) 1150 ! This is not a problem ... 1151 nrecbef = idum 1152 1153 END FUNCTION nrecbef 1154 1155 1156 SUBROUTINE obc_depth_average(nt_x) 1157 !!----------------------------------------------------------------------- 1158 !! *** ROUTINE obc_depth_average *** 1159 !! 1160 !! Purpose : - compute the depth-averaged velocity from depth-dependent OBC frames 1161 !! 1162 !! History : 2009-01 : ( Fred Dupont ) Original code 1163 !!----------------------------------------------------------------------- 1164 1165 ! * Arguments 1166 INTEGER, INTENT( in ) :: nt_x 1167 1168 ! * Local variables 1169 INTEGER :: ji, jj, jk 1170 1171 1172 IF( lp_obc_east ) THEN 1173 ! initialisation to zero 1174 ubtedta(:,nt_x) = 0.e0 1175 vbtedta(:,nt_x) = 0.e0 1176 DO ji = nie0, nie1 1177 DO jj = 1, jpj 1178 DO jk = 1, jpkm1 1179 ubtedta(jj,nt_x) = ubtedta(jj,nt_x) + uedta(jj,jk,nt_x)*fse3u(ji,jj,jk) 1180 vbtedta(jj,nt_x) = vbtedta(jj,nt_x) + vedta(jj,jk,nt_x)*fse3v(ji+1,jj,jk) 260 1181 END DO 261 1182 END DO 262 263 igrd = 3 ! meridional velocity 264 dta_obc(ib_obc)%v2d(:) = 0.0 265 DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 266 ii = idx_obc(ib_obc)%nbi(ib,igrd) 267 ij = idx_obc(ib_obc)%nbj(ib,igrd) 268 DO ik = 1, jpkm1 269 dta_obc(ib_obc)%v2d(ib) = dta_obc(ib_obc)%v2d(ib) & 270 & + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta_obc(ib_obc)%v3d(ib,ik) 271 END DO 272 dta_obc(ib_obc)%v2d(ib) = dta_obc(ib_obc)%v2d(ib) * hvr(ii,ij) 273 DO ik = 1, jpkm1 274 dta_obc(ib_obc)%v3d(ib,ik) = dta_obc(ib_obc)%v3d(ib,ik) - dta_obc(ib_obc)%v2d(ib) 1183 END DO 1184 ENDIF 1185 1186 IF( lp_obc_west) THEN 1187 ! initialisation to zero 1188 ubtwdta(:,nt_x) = 0.e0 1189 vbtwdta(:,nt_x) = 0.e0 1190 DO ji = niw0, niw1 1191 DO jj = 1, jpj 1192 DO jk = 1, jpkm1 1193 ubtwdta(jj,nt_x) = ubtwdta(jj,nt_x) + uwdta(jj,jk,nt_x)*fse3u(ji,jj,jk) 1194 vbtwdta(jj,nt_x) = vbtwdta(jj,nt_x) + vwdta(jj,jk,nt_x)*fse3v(ji,jj,jk) 275 1195 END DO 276 1196 END DO 277 278 ENDIF 279 280 END IF ! nn_dta(ib_obc) = 1 281 END DO ! ib_obc 282 283 IF(wrk_not_released(2, 22,23) ) CALL ctl_stop('obc_dta: ERROR: failed to release workspace arrays.') 284 1197 END DO 1198 ENDIF 1199 1200 IF( lp_obc_north) THEN 1201 ! initialisation to zero 1202 ubtndta(:,nt_x) = 0.e0 1203 vbtndta(:,nt_x) = 0.e0 1204 DO jj = njn0, njn1 1205 DO ji = 1, jpi 1206 DO jk = 1, jpkm1 1207 ubtndta(ji,nt_x) = ubtndta(ji,nt_x) + undta(ji,jk,nt_x)*fse3u(ji,jj+1,jk) 1208 vbtndta(ji,nt_x) = vbtndta(ji,nt_x) + vndta(ji,jk,nt_x)*fse3v(ji,jj,jk) 1209 END DO 1210 END DO 1211 END DO 1212 ENDIF 1213 1214 IF( lp_obc_south) THEN 1215 ! initialisation to zero 1216 ubtsdta(:,nt_x) = 0.e0 1217 vbtsdta(:,nt_x) = 0.e0 1218 DO jj = njs0, njs1 1219 DO ji = nis0, nis1 1220 DO jk = 1, jpkm1 1221 ubtsdta(ji,nt_x) = ubtsdta(ji,nt_x) + usdta(ji,jk,nt_x)*fse3u(ji,jj,jk) 1222 vbtsdta(ji,nt_x) = vbtsdta(ji,nt_x) + vsdta(ji,jk,nt_x)*fse3v(ji,jj,jk) 1223 END DO 1224 END DO 1225 END DO 1226 ENDIF 1227 1228 END SUBROUTINE obc_depth_average 1229 1230 #else 1231 !!------------------------------------------------------------------------------ 1232 !! default option: Dummy module NO Open Boundary Conditions 1233 !!------------------------------------------------------------------------------ 1234 CONTAINS 1235 SUBROUTINE obc_dta( kt ) ! Dummy routine 1236 INTEGER, INTENT (in) :: kt 1237 WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt 285 1238 END SUBROUTINE obc_dta 286 287 288 SUBROUTINE obc_dta_init289 !!----------------------------------------------------------------------290 !! *** SUBROUTINE obc_dta_init ***291 !!292 !! ** Purpose : Initialise arrays for reading of external data293 !! for open boundary conditions294 !!295 !! ** Method : Use fldread.F90296 !!297 !!----------------------------------------------------------------------298 USE dynspg_oce, ONLY: lk_dynspg_ts299 !!300 INTEGER :: ib_obc, jfld, jstart, jend, ierror ! local indices301 !!302 CHARACTER(len=100) :: cn_dir ! Root directory for location of data files303 CHARACTER(len=100), DIMENSION(nb_obc) :: cn_dir_array ! Root directory for location of data files304 LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data305 ! =F => baroclinic velocities in 3D boundary data306 INTEGER :: ilen_global ! Max length required for global obc dta arrays307 INTEGER, DIMENSION(jpbgrd) :: ilen0 ! size of local arrays308 INTEGER, ALLOCATABLE, DIMENSION(:) :: ilen1, ilen3 ! size of 1st and 3rd dimensions of local arrays309 INTEGER, ALLOCATABLE, DIMENSION(:) :: iobc ! obc set for a particular jfld310 INTEGER, ALLOCATABLE, DIMENSION(:) :: igrid ! index for grid type (1,2,3 = T,U,V)311 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts312 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: blf_i ! array of namelist information structures313 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d !314 TYPE(FLD_N) :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read315 #if defined key_lim2316 TYPE(FLD_N) :: bn_frld, bn_hicif, bn_hsnif !317 1239 #endif 318 NAMELIST/namobc_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d319 #if defined key_lim2320 NAMELIST/namobc_dta/ bn_frld, bn_hicif, bn_hsnif321 #endif322 NAMELIST/namobc_dta/ ln_full_vel323 !!---------------------------------------------------------------------------324 325 ! Set nn_dta326 DO ib_obc = 1, nb_obc327 nn_dta(ib_obc) = MAX( nn_dyn2d_dta(ib_obc) &328 ,nn_dyn3d_dta(ib_obc) &329 ,nn_tra_dta(ib_obc) &330 #if defined key_ice_lim2331 ,nn_ice_lim2_dta(ib_obc) &332 #endif333 )334 IF(nn_dta(ib_obc) .gt. 1) nn_dta(ib_obc) = 1335 END DO336 337 ! Work out upper bound of how many fields there are to read in and allocate arrays338 ! ---------------------------------------------------------------------------339 ALLOCATE( nb_obc_fld(nb_obc) )340 nb_obc_fld(:) = 0341 DO ib_obc = 1, nb_obc342 IF( nn_dyn2d(ib_obc) .gt. 0 .and. ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) THEN343 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3344 ENDIF345 IF( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ) THEN346 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2347 ENDIF348 IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 1 ) THEN349 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2350 ENDIF351 #if defined key_lim2352 IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 1 ) THEN353 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3354 ENDIF355 #endif356 ENDDO357 358 nb_obc_fld_sum = SUM( nb_obc_fld )359 360 ALLOCATE( bf(nb_obc_fld_sum), STAT=ierror )361 IF( ierror > 0 ) THEN362 CALL ctl_stop( 'obc_dta: unable to allocate bf structure' ) ; RETURN363 ENDIF364 ALLOCATE( blf_i(nb_obc_fld_sum), STAT=ierror )365 IF( ierror > 0 ) THEN366 CALL ctl_stop( 'obc_dta: unable to allocate blf_i structure' ) ; RETURN367 ENDIF368 ALLOCATE( nbmap_ptr(nb_obc_fld_sum), STAT=ierror )369 IF( ierror > 0 ) THEN370 CALL ctl_stop( 'obc_dta: unable to allocate nbmap_ptr structure' ) ; RETURN371 ENDIF372 ALLOCATE( ilen1(nb_obc_fld_sum), ilen3(nb_obc_fld_sum) )373 ALLOCATE( iobc(nb_obc_fld_sum) )374 ALLOCATE( igrid(nb_obc_fld_sum) )375 376 ! Read namelists377 ! --------------378 REWIND(numnam)379 jfld = 0380 DO ib_obc = 1, nb_obc381 IF( nn_dta(ib_obc) .eq. 1 ) THEN382 ! set file information383 cn_dir = './' ! directory in which the model is executed384 ln_full_vel = .false.385 ! ... default values (NB: frequency positive => hours, negative => months)386 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation !387 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs !388 bn_ssh = FLD_N( 'obc_ssh' , 24 , 'sossheig' , .false. , .false. , 'yearly' , '' , '' )389 bn_u2d = FLD_N( 'obc_vel2d_u' , 24 , 'vobtcrtx' , .false. , .false. , 'yearly' , '' , '' )390 bn_v2d = FLD_N( 'obc_vel2d_v' , 24 , 'vobtcrty' , .false. , .false. , 'yearly' , '' , '' )391 bn_u3d = FLD_N( 'obc_vel3d_u' , 24 , 'vozocrtx' , .false. , .false. , 'yearly' , '' , '' )392 bn_v3d = FLD_N( 'obc_vel3d_v' , 24 , 'vomecrty' , .false. , .false. , 'yearly' , '' , '' )393 bn_tem = FLD_N( 'obc_tem' , 24 , 'votemper' , .false. , .false. , 'yearly' , '' , '' )394 bn_sal = FLD_N( 'obc_sal' , 24 , 'vosaline' , .false. , .false. , 'yearly' , '' , '' )395 #if defined key_lim2396 bn_frld = FLD_N( 'obc_frld' , 24 , 'ildsconc' , .false. , .false. , 'yearly' , '' , '' )397 bn_hicif = FLD_N( 'obc_hicif' , 24 , 'iicethic' , .false. , .false. , 'yearly' , '' , '' )398 bn_hsnif = FLD_N( 'obc_hsnif' , 24 , 'isnothic' , .false. , .false. , 'yearly' , '' , '' )399 #endif400 401 ! Important NOT to rewind here.402 READ( numnam, namobc_dta )403 404 cn_dir_array(ib_obc) = cn_dir405 ln_full_vel_array(ib_obc) = ln_full_vel406 407 IF( ln_full_vel_array(ib_obc) .and. lk_dynspg_ts ) THEN408 CALL ctl_stop( 'obc_dta_init: ERROR, cannot specify full velocities in boundary data',&409 & 'with dynspg_ts option' ) ; RETURN410 ENDIF411 412 nblen => idx_obc(ib_obc)%nblen413 nblenrim => idx_obc(ib_obc)%nblenrim414 415 ! Only read in necessary fields for this set.416 ! Important that barotropic variables come first.417 IF( nn_dyn2d(ib_obc) .gt. 0 .and. ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) THEN418 419 IF( nn_dyn2d(ib_obc) .ne. jp_frs ) THEN420 jfld = jfld + 1421 blf_i(jfld) = bn_ssh422 iobc(jfld) = ib_obc423 igrid(jfld) = 1424 ilen1(jfld) = nblenrim(igrid(jfld))425 ilen3(jfld) = 1426 ENDIF427 428 IF( .not. ln_full_vel_array(ib_obc) ) THEN429 430 jfld = jfld + 1431 blf_i(jfld) = bn_u2d432 iobc(jfld) = ib_obc433 igrid(jfld) = 2434 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN435 ilen1(jfld) = nblen(igrid(jfld))436 ELSE437 ilen1(jfld) = nblenrim(igrid(jfld))438 ENDIF439 ilen3(jfld) = 1440 441 jfld = jfld + 1442 blf_i(jfld) = bn_v2d443 iobc(jfld) = ib_obc444 igrid(jfld) = 3445 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN446 ilen1(jfld) = nblen(igrid(jfld))447 ELSE448 ilen1(jfld) = nblenrim(igrid(jfld))449 ENDIF450 ilen3(jfld) = 1451 452 ENDIF453 454 ENDIF455 456 ! baroclinic velocities457 IF( ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ) .or. &458 & ( ln_full_vel_array(ib_obc) .and. nn_dyn2d(ib_obc) .gt. 0 .and. &459 & ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) ) THEN460 461 jfld = jfld + 1462 blf_i(jfld) = bn_u3d463 iobc(jfld) = ib_obc464 igrid(jfld) = 2465 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN466 ilen1(jfld) = nblen(igrid(jfld))467 ELSE468 ilen1(jfld) = nblenrim(igrid(jfld))469 ENDIF470 ilen3(jfld) = jpk471 472 jfld = jfld + 1473 blf_i(jfld) = bn_v3d474 iobc(jfld) = ib_obc475 igrid(jfld) = 3476 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN477 ilen1(jfld) = nblen(igrid(jfld))478 ELSE479 ilen1(jfld) = nblenrim(igrid(jfld))480 ENDIF481 ilen3(jfld) = jpk482 483 ENDIF484 485 ! temperature and salinity486 IF( nn_tra(ib_obc) .gt. 0 .and. nn_tra_dta(ib_obc) .eq. 1 ) THEN487 488 jfld = jfld + 1489 blf_i(jfld) = bn_tem490 iobc(jfld) = ib_obc491 igrid(jfld) = 1492 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN493 ilen1(jfld) = nblen(igrid(jfld))494 ELSE495 ilen1(jfld) = nblenrim(igrid(jfld))496 ENDIF497 ilen3(jfld) = jpk498 499 jfld = jfld + 1500 blf_i(jfld) = bn_sal501 iobc(jfld) = ib_obc502 igrid(jfld) = 1503 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN504 ilen1(jfld) = nblen(igrid(jfld))505 ELSE506 ilen1(jfld) = nblenrim(igrid(jfld))507 ENDIF508 ilen3(jfld) = jpk509 510 ENDIF511 512 #if defined key_lim2513 ! sea ice514 IF( nn_ice_lim2(ib_obc) .gt. 0 .and. nn_ice_lim2_dta(ib_obc) .eq. 1 ) THEN515 516 jfld = jfld + 1517 blf_i(jfld) = bn_frld518 iobc(jfld) = ib_obc519 igrid(jfld) = 1520 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN521 ilen1(jfld) = nblen(igrid(jfld))522 ELSE523 ilen1(jfld) = nblenrim(igrid(jfld))524 ENDIF525 ilen3(jfld) = 1526 527 jfld = jfld + 1528 blf_i(jfld) = bn_hicif529 iobc(jfld) = ib_obc530 igrid(jfld) = 1531 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN532 ilen1(jfld) = nblen(igrid(jfld))533 ELSE534 ilen1(jfld) = nblenrim(igrid(jfld))535 ENDIF536 ilen3(jfld) = 1537 538 jfld = jfld + 1539 blf_i(jfld) = bn_hsnif540 iobc(jfld) = ib_obc541 igrid(jfld) = 1542 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN543 ilen1(jfld) = nblen(igrid(jfld))544 ELSE545 ilen1(jfld) = nblenrim(igrid(jfld))546 ENDIF547 ilen3(jfld) = 1548 549 ENDIF550 #endif551 ! Recalculate field counts552 !-------------------------553 nb_obc_fld_sum = 0554 IF( ib_obc .eq. 1 ) THEN555 nb_obc_fld(ib_obc) = jfld556 nb_obc_fld_sum = jfld557 ELSE558 nb_obc_fld(ib_obc) = jfld - nb_obc_fld_sum559 nb_obc_fld_sum = nb_obc_fld_sum + nb_obc_fld(ib_obc)560 ENDIF561 562 ENDIF ! nn_dta .eq. 1563 ENDDO ! ib_obc564 565 566 DO jfld = 1, nb_obc_fld_sum567 ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) )568 IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) )569 nbmap_ptr(jfld)%ptr => idx_obc(iobc(jfld))%nbmap(:,igrid(jfld))570 ENDDO571 572 ! fill bf with blf_i and control print573 !-------------------------------------574 jstart = 1575 DO ib_obc = 1, nb_obc576 jend = jstart + nb_obc_fld(ib_obc) - 1577 CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(ib_obc), 'obc_dta', 'open boundary conditions', 'namobc_dta' )578 jstart = jend + 1579 ENDDO580 581 ! Initialise local boundary data arrays582 ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later583 ! nn_xxx_dta=1 : point to "fnow" arrays584 !-------------------------------------585 586 jfld = 0587 DO ib_obc=1, nb_obc588 589 nblen => idx_obc(ib_obc)%nblen590 nblenrim => idx_obc(ib_obc)%nblenrim591 592 IF (nn_dyn2d(ib_obc) .gt. 0) THEN593 IF( nn_dyn2d_dta(ib_obc) .eq. 0 .or. nn_dyn2d_dta(ib_obc) .eq. 2 .or. ln_full_vel_array(ib_obc) ) THEN594 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN595 ilen0(1:3) = nblen(1:3)596 ELSE597 ilen0(1:3) = nblenrim(1:3)598 ENDIF599 ALLOCATE( dta_obc(ib_obc)%ssh(ilen0(1)) )600 ALLOCATE( dta_obc(ib_obc)%u2d(ilen0(2)) )601 ALLOCATE( dta_obc(ib_obc)%v2d(ilen0(3)) )602 ELSE603 IF( nn_dyn2d(ib_obc) .ne. jp_frs ) THEN604 jfld = jfld + 1605 dta_obc(ib_obc)%ssh => bf(jfld)%fnow(:,1,1)606 ENDIF607 jfld = jfld + 1608 dta_obc(ib_obc)%u2d => bf(jfld)%fnow(:,1,1)609 jfld = jfld + 1610 dta_obc(ib_obc)%v2d => bf(jfld)%fnow(:,1,1)611 ENDIF612 ENDIF613 614 IF ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 0 ) THEN615 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN616 ilen0(1:3) = nblen(1:3)617 ELSE618 ilen0(1:3) = nblenrim(1:3)619 ENDIF620 ALLOCATE( dta_obc(ib_obc)%u3d(ilen0(2),jpk) )621 ALLOCATE( dta_obc(ib_obc)%v3d(ilen0(3),jpk) )622 ENDIF623 IF ( ( nn_dyn3d(ib_obc) .gt. 0 .and. nn_dyn3d_dta(ib_obc) .eq. 1 ).or. &624 & ( ln_full_vel_array(ib_obc) .and. nn_dyn2d(ib_obc) .gt. 0 .and. &625 & ( nn_dyn2d_dta(ib_obc) .eq. 1 .or. nn_dyn2d_dta(ib_obc) .eq. 3 ) ) ) THEN626 jfld = jfld + 1627 dta_obc(ib_obc)%u3d => bf(jfld)%fnow(:,1,:)628 jfld = jfld + 1629 dta_obc(ib_obc)%v3d => bf(jfld)%fnow(:,1,:)630 ENDIF631 632 IF (nn_tra(ib_obc) .gt. 0) THEN633 IF( nn_tra_dta(ib_obc) .eq. 0 ) THEN634 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN635 ilen0(1:3) = nblen(1:3)636 ELSE637 ilen0(1:3) = nblenrim(1:3)638 ENDIF639 ALLOCATE( dta_obc(ib_obc)%tem(ilen0(1),jpk) )640 ALLOCATE( dta_obc(ib_obc)%sal(ilen0(1),jpk) )641 ELSE642 jfld = jfld + 1643 dta_obc(ib_obc)%tem => bf(jfld)%fnow(:,1,:)644 jfld = jfld + 1645 dta_obc(ib_obc)%sal => bf(jfld)%fnow(:,1,:)646 ENDIF647 ENDIF648 649 #if defined key_lim2650 IF (nn_ice_lim2(ib_obc) .gt. 0) THEN651 IF( nn_ice_lim2_dta(ib_obc) .eq. 0 ) THEN652 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN653 ilen0(1:3) = nblen(1:3)654 ELSE655 ilen0(1:3) = nblenrim(1:3)656 ENDIF657 ALLOCATE( dta_obc(ib_obc)%frld(ilen0(1)) )658 ALLOCATE( dta_obc(ib_obc)%hicif(ilen0(1)) )659 ALLOCATE( dta_obc(ib_obc)%hsnif(ilen0(1)) )660 ELSE661 jfld = jfld + 1662 dta_obc(ib_obc)%frld => bf(jfld)%fnow(:,1,1)663 jfld = jfld + 1664 dta_obc(ib_obc)%hicif => bf(jfld)%fnow(:,1,1)665 jfld = jfld + 1666 dta_obc(ib_obc)%hsnif => bf(jfld)%fnow(:,1,1)667 ENDIF668 ENDIF669 #endif670 671 ENDDO ! ib_obc672 673 END SUBROUTINE obc_dta_init674 675 #else676 !!----------------------------------------------------------------------677 !! Dummy module NO Open Boundary Conditions678 !!----------------------------------------------------------------------679 CONTAINS680 SUBROUTINE obc_dta( kt, jit ) ! Empty routine681 INTEGER, INTENT( in ) :: kt682 INTEGER, INTENT( in ), OPTIONAL :: jit683 WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt684 END SUBROUTINE obc_dta685 SUBROUTINE obc_dta_init() ! Empty routine686 WRITE(*,*) 'obc_dta_init: You should not have seen this print! error?'687 END SUBROUTINE obc_dta_init688 #endif689 690 1240 !!============================================================================== 691 END MODULE obcdta1241 END MODULE obcdta -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn.F90
r2865 r2888 1 1 MODULE obcdyn 2 !!====================================================================== 2 #if defined key_obc 3 !!================================================================================= 3 4 !! *** MODULE obcdyn *** 4 !! Unstructured Open Boundary Cond. : Flow relaxation scheme on velocities 5 !!====================================================================== 6 !! History : 1.0 ! 2005-02 (J. Chanut, A. Sellar) Original code 7 !! - ! 2007-07 (D. Storkey) Move Flather implementation to separate routine. 8 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 9 !! 3.2 ! 2008-04 (R. Benshila) consider velocity instead of transport 10 !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 !!---------------------------------------------------------------------- 13 #if defined key_obc 14 !!---------------------------------------------------------------------- 15 !! 'key_obc' : Unstructured Open Boundary Condition 16 !!---------------------------------------------------------------------- 17 !! obc_dyn3d : apply open boundary conditions to baroclinic velocities 18 !! obc_dyn3d_frs : apply Flow Relaxation Scheme 19 !!---------------------------------------------------------------------- 5 !! Ocean dynamics: Radiation of velocities on each open boundary 6 !!================================================================================= 7 8 !!--------------------------------------------------------------------------------- 9 !! obc_dyn : call the subroutine for each open boundary 10 !! obc_dyn_east : radiation of the east open boundary velocities 11 !! obc_dyn_west : radiation of the west open boundary velocities 12 !! obc_dyn_north : radiation of the north open boundary velocities 13 !! obc_dyn_south : radiation of the south open boundary velocities 14 !!---------------------------------------------------------------------------------- 15 16 !!---------------------------------------------------------------------------------- 17 !! * Modules used 20 18 USE oce ! ocean dynamics and tracers 21 19 USE dom_oce ! ocean space and time domain 22 USE dynspg_oce20 USE phycst ! physical constants 23 21 USE obc_oce ! ocean open boundary conditions 24 USE obcdyn2d ! open boundary conditions for barotropic solution25 USE obcdyn3d ! open boundary conditions for baroclinic velocities26 USE lbclnk ! ocean lateral boundary conditions (or mpp link)27 USE in_out_manager !22 USE lbclnk ! ??? 23 USE lib_mpp ! ??? 24 USE in_out_manager ! I/O manager 25 USE dynspg_oce 28 26 29 27 IMPLICIT NONE 30 28 PRIVATE 31 29 32 PUBLIC obc_dyn ! routine called in dynspg_flt (if lk_dynspg_flt) or 33 ! dyn_nxt (if lk_dynspg_ts or lk_dynspg_exp) 34 35 # include "domzgr_substitute.h90" 36 !!---------------------------------------------------------------------- 37 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 38 !! $Id: obcdyn.F90 2528 2010-12-27 17:33:53Z rblod $ 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 !!---------------------------------------------------------------------- 30 !! * Accessibility 31 PUBLIC obc_dyn ! routine called in dynspg_flt (free surface case) 32 33 !! * Module variables 34 INTEGER :: ji, jj, jk ! dummy loop indices 35 36 INTEGER :: & ! ... boundary space indices 37 nib = 1, & ! nib = boundary point 38 nibm = 2, & ! nibm = 1st interior point 39 nibm2 = 3, & ! nibm2 = 2nd interior point 40 ! ... boundary time indices 41 nit = 1, & ! nit = now 42 nitm = 2, & ! nitm = before 43 nitm2 = 3 ! nitm2 = before-before 44 45 REAL(wp) :: rtaue , rtauw , rtaun , rtaus , & 46 rtauein, rtauwin, rtaunin, rtausin 47 48 !!--------------------------------------------------------------------------------- 49 41 50 CONTAINS 42 51 43 SUBROUTINE obc_dyn( kt, dyn3d_only ) 52 SUBROUTINE obc_dyn ( kt ) 53 !!------------------------------------------------------------------------------ 54 !! SUBROUTINE obc_dyn 55 !! ******************** 56 !! ** Purpose : 57 !! Compute dynamics (u,v) at the open boundaries. 58 !! if defined key_dynspg_flt: 59 !! this routine is called by dynspg_flt and updates 60 !! ua, va which are the actual velocities (not trends) 61 !! 62 !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 63 !! and/or lp_obc_south allow the user to determine which boundary is an 64 !! open one (must be done in the param_obc.h90 file). 65 !! 66 !! ** Reference : 67 !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 68 !! 69 !! History : 70 !! ! 95-03 (J.-M. Molines) Original, SPEM 71 !! ! 97-07 (G. Madec, J.-M. Molines) addition 72 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 73 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 44 74 !!---------------------------------------------------------------------- 45 !! *** SUBROUTINE obc_dyn *** 75 !! * Arguments 76 INTEGER, INTENT( in ) :: kt 77 78 !!---------------------------------------------------------------------- 79 !! OPA 9.0 , LOCEAN-IPSL (2005) 80 !! $Id: obcdyn.F90 1528 2009-07-23 14:38:47Z rblod $ 81 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 82 !!---------------------------------------------------------------------- 83 84 ! 0. Local constant initialization 85 ! -------------------------------- 86 87 IF( kt == nit000 .OR. ln_rstart) THEN 88 ! ... Boundary restoring coefficient 89 rtaue = 2. * rdt / rdpeob 90 rtauw = 2. * rdt / rdpwob 91 rtaun = 2. * rdt / rdpnob 92 rtaus = 2. * rdt / rdpsob 93 ! ... Boundary restoring coefficient for inflow ( all boundaries) 94 rtauein = 2. * rdt / rdpein 95 rtauwin = 2. * rdt / rdpwin 96 rtaunin = 2. * rdt / rdpnin 97 rtausin = 2. * rdt / rdpsin 98 END IF 99 100 IF( lp_obc_east ) CALL obc_dyn_east ( kt ) 101 IF( lp_obc_west ) CALL obc_dyn_west ( kt ) 102 IF( lp_obc_north ) CALL obc_dyn_north( kt ) 103 IF( lp_obc_south ) CALL obc_dyn_south( kt ) 104 105 IF( lk_mpp ) THEN 106 IF( kt >= nit000+3 .AND. ln_rstart ) THEN 107 CALL lbc_lnk( ub, 'U', -1. ) 108 CALL lbc_lnk( vb, 'V', -1. ) 109 END IF 110 CALL lbc_lnk( ua, 'U', -1. ) 111 CALL lbc_lnk( va, 'V', -1. ) 112 ENDIF 113 114 END SUBROUTINE obc_dyn 115 116 117 SUBROUTINE obc_dyn_east ( kt ) 118 !!------------------------------------------------------------------------------ 119 !! *** SUBROUTINE obc_dyn_east *** 120 !! 121 !! ** Purpose : 122 !! Apply the radiation algorithm on east OBC velocities ua, va using the 123 !! phase velocities calculated in obc_rad_east subroutine in obcrad.F90 module 124 !! If the logical lfbceast is .TRUE., there is no radiation but only fixed OBC 46 125 !! 47 !! ** Purpose : - Wrapper routine for obc_dyn2d and obc_dyn3d. 126 !! History : 127 !! ! 95-03 (J.-M. Molines) Original from SPEM 128 !! ! 97-07 (G. Madec, J.-M. Molines) additions 129 !! ! 97-12 (M. Imbard) Mpp adaptation 130 !! ! 00-06 (J.-M. Molines) 131 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 132 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 133 !!------------------------------------------------------------------------------ 134 !! * Arguments 135 INTEGER, INTENT( in ) :: kt 136 137 !! * Local declaration 138 REAL(wp) :: z05cx, ztau, zin 139 !!------------------------------------------------------------------------------ 140 141 ! 1. First three time steps and more if lfbceast is .TRUE. 142 ! In that case open boundary conditions are FIXED. 143 ! -------------------------------------------------------- 144 145 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast .OR. lk_dynspg_exp ) THEN 146 147 ! 1.1 U zonal velocity 148 ! -------------------- 149 DO ji = nie0, nie1 150 DO jk = 1, jpkm1 151 DO jj = 1, jpj 152 ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uemsk(jj,jk)) + & 153 uemsk(jj,jk)*ufoe(jj,jk) 154 END DO 155 END DO 156 END DO 157 158 ! 1.2 V meridional velocity 159 ! ------------------------- 160 DO ji = nie0+1, nie1+1 161 DO jk = 1, jpkm1 162 DO jj = 1, jpj 163 va(ji,jj,jk) = va(ji,jj,jk) * (1.-vemsk(jj,jk)) + & 164 vfoe(jj,jk)*vemsk(jj,jk) 165 END DO 166 END DO 167 END DO 168 169 ELSE 170 171 ! 2. Beyond the fourth time step if lfbceast is .FALSE. 172 ! ----------------------------------------------------- 173 174 ! 2.1. u-component of the velocity 175 ! --------------------------------- 176 ! 177 ! nibm2 nibm nib 178 ! | nibm | nib |/// 179 ! | | | | |/// 180 ! jj-line --f----v----f----v----f--- 181 ! | | | | |/// 182 ! | | |/// 183 ! jj-line u T u T u/// 184 ! | | |/// 185 ! | | | | |/// 186 ! jpieob-2 jpieob-1 jpieob 187 ! | | 188 ! jpieob-1 jpieob 189 ! 190 ! ... If free surface formulation: 191 ! ... radiative conditions on the total part + relaxation toward climatology 192 ! ... (jpjedp1, jpjefm1),jpieob 193 DO ji = nie0, nie1 194 DO jk = 1, jpkm1 195 DO jj = 1, jpj 196 z05cx = u_cxebnd(jj,jk) 197 z05cx = z05cx / e1t(ji,jj) 198 z05cx = min( z05cx, 1. ) 199 ! ... z05cx=< 0, inflow zin=0, ztau=1 200 ! > 0, outflow zin=1, ztau=rtaue 201 zin = sign( 1., z05cx ) 202 zin = 0.5*( zin + abs(zin) ) 203 ! ... for inflow rtauein is used for relaxation coefficient else rtaue 204 ztau = (1.-zin ) * rtauein + zin * rtaue 205 z05cx = z05cx * zin 206 ! ... update ua with radiative or climatological velocity 207 ua(ji,jj,jk) = ua(ji,jj,jk) * ( 1. - uemsk(jj,jk) ) + & 208 uemsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 209 * uebnd(jj,jk,nib ,nitm) + 2.*z05cx & 210 * uebnd(jj,jk,nibm,nit ) + ztau * ufoe (jj,jk) ) & 211 / (1. + z05cx) 212 END DO 213 END DO 214 END DO 215 216 ! 2.2 v-component of the velocity 217 ! ------------------------------- 218 ! 219 ! nibm2 nibm nib 220 ! | nibm | nib///|/// 221 ! | | | |////|/// 222 ! jj-line --v----f----v----f----v--- 223 ! | | | |////|/// 224 ! | | | |////|/// 225 ! | jpieob-1 | jpieob /|/// 226 ! | | | 227 ! jpieob-1 jpieob jpieob+1 228 ! 229 ! ... radiative condition 230 ! ... (jpjedp1, jpjefm1), jpieob+1 231 DO ji = nie0+1, nie1+1 232 DO jk = 1, jpkm1 233 DO jj = 1, jpj 234 z05cx = v_cxebnd(jj,jk) 235 z05cx = z05cx / e1f(ji-1,jj) 236 z05cx = min( z05cx, 1. ) 237 ! ... z05cx=< 0, inflow zin=0, ztau=1 238 ! > 0, outflow zin=1, ztau=rtaue 239 zin = sign( 1., z05cx ) 240 zin = 0.5*( zin + abs(zin) ) 241 ! ... for inflow rtauein is used for relaxation coefficient else rtaue 242 ztau = (1.-zin ) * rtauein + zin * rtaue 243 z05cx = z05cx * zin 244 ! ... update va with radiative or climatological velocity 245 va(ji,jj,jk) = va(ji,jj,jk) * (1. - vemsk(jj,jk) ) + & 246 vemsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 247 * vebnd(jj,jk,nib ,nitm) + 2.*z05cx & 248 * vebnd(jj,jk,nibm,nit ) + ztau * vfoe(jj,jk) ) & 249 / (1. + z05cx) 250 END DO 251 END DO 252 END DO 253 254 END IF 255 256 END SUBROUTINE obc_dyn_east 257 258 259 SUBROUTINE obc_dyn_west ( kt ) 260 !!------------------------------------------------------------------------------ 261 !! *** SUBROUTINE obc_dyn_west *** 262 !! 263 !! ** Purpose : 264 !! Apply the radiation algorithm on west OBC velocities ua, va using the 265 !! phase velocities calculated in obc_rad_west subroutine in obcrad.F90 module 266 !! If the logical lfbcwest is .TRUE., there is no radiation but only fixed OBC 48 267 !! 49 !!---------------------------------------------------------------------- 50 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 51 USE wrk_nemo, ONLY: wrk_2d_7, wrk_2d_8 ! 2D workspace 268 !! History : 269 !! ! 95-03 (J.-M. Molines) Original from SPEM 270 !! ! 97-07 (G. Madec, J.-M. Molines) additions 271 !! ! 97-12 (M. Imbard) Mpp adaptation 272 !! ! 00-06 (J.-M. Molines) 273 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 274 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 275 !!------------------------------------------------------------------------------ 276 !! * Arguments 277 INTEGER, INTENT( in ) :: kt 278 279 !! * Local declaration 280 REAL(wp) :: z05cx, ztau, zin 281 !!------------------------------------------------------------------------------ 282 283 ! 1. First three time steps and more if lfbcwest is .TRUE. 284 ! In that case open boundary conditions are FIXED. 285 ! -------------------------------------------------------- 286 287 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest .OR. lk_dynspg_exp ) THEN 288 289 ! 1.1 U zonal velocity 290 ! --------------------- 291 DO ji = niw0, niw1 292 DO jk = 1, jpkm1 293 DO jj = 1, jpj 294 ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uwmsk(jj,jk)) + & 295 uwmsk(jj,jk)*ufow(jj,jk) 296 END DO 297 END DO 298 END DO 299 300 ! 1.2 V meridional velocity 301 ! ------------------------- 302 DO ji = niw0, niw1 303 DO jk = 1, jpkm1 304 DO jj = 1, jpj 305 va(ji,jj,jk) = va(ji,jj,jk) * (1.-vwmsk(jj,jk)) + & 306 vfow(jj,jk)*vwmsk(jj,jk) 307 END DO 308 END DO 309 END DO 310 311 ELSE 312 313 ! 2. Beyond the fourth time step if lfbcwest is .FALSE. 314 ! ----------------------------------------------------- 315 316 ! 2.1. u-component of the velocity 317 ! --------------------------------- 318 ! 319 ! nib nibm nibm2 320 ! ///| nib | nibm | 321 ! ///| | | | | 322 ! ---f----v----f----v----f-- jj-line 323 ! ///| | | | | 324 ! ///| | | 325 ! ///u T u T u jj-line 326 ! ///| | | 327 ! ///| | | | | 328 ! jpiwob jpiwob+1 jpiwob+2 329 ! | | 330 ! jpiwob+1 jpiwob+2 331 ! 332 ! ... If free surface formulation: 333 ! ... radiative conditions on the total part + relaxation toward climatology 334 ! ... (jpjwdp1, jpjwfm1), jpiwob 335 DO ji = niw0, niw1 336 DO jk = 1, jpkm1 337 DO jj = 1, jpj 338 z05cx = u_cxwbnd(jj,jk) 339 z05cx = z05cx / e1t(ji+1,jj) 340 z05cx = max( z05cx, -1. ) 341 ! ... z05c > 0, inflow zin=0, ztau=1 342 ! =< 0, outflow zin=1, ztau=rtauw 343 zin = sign( 1., -1. * z05cx ) 344 zin = 0.5*( zin + abs(zin) ) 345 ztau = (1.-zin )* rtauwin + zin * rtauw 346 z05cx = z05cx * zin 347 ! ... update un with radiative or climatological velocity 348 ua(ji,jj,jk) = ua(ji,jj,jk) * ( 1. - uwmsk(jj,jk) ) + & 349 uwmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 350 * uwbnd(jj,jk,nib ,nitm) - 2.*z05cx & 351 * uwbnd(jj,jk,nibm,nit ) + ztau * ufow (jj,jk) ) & 352 / (1. - z05cx) 353 END DO 354 END DO 355 END DO 356 357 ! 2.2 v-component of the velocity 358 ! ------------------------------- 359 ! 360 ! nib nibm nibm2 361 ! ///|///nib | nibm | nibm2 362 ! ///|////| | | | | | 363 ! ---v----f----v----f----v----f----v-- jj-line 364 ! ///|////| | | | | | 365 ! ///|////| | | | | | 366 ! jpiwob jpiwob+1 jpiwob+2 367 ! | | | 368 ! jpiwob jpiwob+1 jpiwob+2 369 ! 370 ! ... radiative condition plus Raymond-Kuo 371 ! ... (jpjwdp1, jpjwfm1),jpiwob 372 DO ji = niw0, niw1 373 DO jk = 1, jpkm1 374 DO jj = 1, jpj 375 z05cx = v_cxwbnd(jj,jk) 376 z05cx = z05cx / e1f(ji,jj) 377 z05cx = max( z05cx, -1. ) 378 ! ... z05cx > 0, inflow zin=0, ztau=1 379 ! =< 0, outflow zin=1, ztau=rtauw 380 zin = sign( 1., -1. * z05cx ) 381 zin = 0.5*( zin + abs(zin) ) 382 ztau = (1.-zin )*rtauwin + zin * rtauw 383 z05cx = z05cx * zin 384 ! ... update va with radiative or climatological velocity 385 va(ji,jj,jk) = va(ji,jj,jk) * (1. - vwmsk(jj,jk) ) + & 386 vwmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 387 * vwbnd(jj,jk,nib ,nitm) - 2.*z05cx & 388 * vwbnd(jj,jk,nibm,nit ) + ztau * vfow (jj,jk) ) & 389 / (1. - z05cx) 390 END DO 391 END DO 392 END DO 393 394 END IF 395 396 END SUBROUTINE obc_dyn_west 397 398 SUBROUTINE obc_dyn_north ( kt ) 399 !!------------------------------------------------------------------------------ 400 !! SUBROUTINE obc_dyn_north 401 !! ************************* 402 !! ** Purpose : 403 !! Apply the radiation algorithm on north OBC velocities ua, va using the 404 !! phase velocities calculated in obc_rad_north subroutine in obcrad.F90 module 405 !! If the logical lfbcnorth is .TRUE., there is no radiation but only fixed OBC 52 406 !! 53 INTEGER, INTENT( in ) :: kt ! Main time step counter 54 LOGICAL, INTENT( in ), OPTIONAL :: dyn3d_only ! T => only update baroclinic velocities 407 !! History : 408 !! ! 95-03 (J.-M. Molines) Original from SPEM 409 !! ! 97-07 (G. Madec, J.-M. Molines) additions 410 !! ! 97-12 (M. Imbard) Mpp adaptation 411 !! ! 00-06 (J.-M. Molines) 412 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 413 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 414 !!------------------------------------------------------------------------------ 415 !! * Arguments 416 INTEGER, INTENT( in ) :: kt 417 418 !! * Local declaration 419 REAL(wp) :: z05cx, ztau, zin 420 !!------------------------------------------------------------------------------ 421 422 ! 1. First three time steps and more if lfbcnorth is .TRUE. 423 ! In that case open boundary conditions are FIXED. 424 ! --------------------------------------------------------- 425 426 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcnorth .OR. lk_dynspg_exp ) THEN 427 428 ! 1.1 U zonal velocity 429 ! -------------------- 430 DO jj = njn0+1, njn1+1 431 DO jk = 1, jpkm1 432 DO ji = 1, jpi 433 ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-unmsk(ji,jk)) + & 434 ufon(ji,jk)*unmsk(ji,jk) 435 END DO 436 END DO 437 END DO 438 439 ! 1.2 V meridional velocity 440 ! ------------------------- 441 DO jj = njn0, njn1 442 DO jk = 1, jpkm1 443 DO ji = 1, jpi 444 va(ji,jj,jk)= va(ji,jj,jk) * (1.-vnmsk(ji,jk)) + & 445 vfon(ji,jk)*vnmsk(ji,jk) 446 END DO 447 END DO 448 END DO 449 450 ELSE 451 452 ! 2. Beyond the fourth time step if lfbcnorth is .FALSE. 453 ! ------------------------------------------------------ 454 455 ! 2.1. u-component of the velocity 456 ! -------------------------------- 457 ! 458 ! ji-row 459 ! | 460 ! nib ///u////// jpjnob + 1 461 ! /////|////// 462 ! nib -----f----- jpjnob 463 ! | 464 ! nibm-- u ---- jpjnob 465 ! | 466 ! nibm -----f----- jpjnob-1 467 ! | 468 ! nibm2-- u ---- jpjnob-1 469 ! | 470 ! nibm2 -----f----- jpjnob-2 471 ! | 472 ! 473 ! ... radiative condition 474 ! ... jpjnob+1,(jpindp1, jpinfm1) 475 DO jj = njn0+1, njn1+1 476 DO jk = 1, jpkm1 477 DO ji = 1, jpi 478 z05cx= u_cynbnd(ji,jk) 479 z05cx = z05cx / e2f(ji, jj-1) 480 z05cx = min( z05cx, 1. ) 481 ! ... z05cx=< 0, inflow zin=0, ztau=1 482 ! > 0, outflow zin=1, ztau=rtaun 483 zin = sign( 1., z05cx ) 484 zin = 0.5*( zin + abs(zin) ) 485 ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 486 ztau = (1.-zin ) * rtaunin + zin * rtaun 487 ! ... for u, when inflow, ufon is prescribed 488 z05cx = z05cx * zin 489 ! ... update un with radiative or climatological velocity 490 ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-unmsk(ji,jk)) + & 491 unmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 492 * unbnd(ji,jk,nib ,nitm) + 2.*z05cx & 493 * unbnd(ji,jk,nibm,nit ) + ztau * ufon (ji,jk) ) & 494 / (1. + z05cx) 495 END DO 496 END DO 497 END DO 498 499 ! 2.2 v-component of the velocity 500 ! ------------------------------- 501 ! 502 ! ji-row ji-row 503 ! | | 504 ! /////|///////////////// 505 ! nib -----f----v----f---- jpjnob 506 ! | | 507 ! nib - u -- T -- u ---- jpjnob 508 ! | | 509 ! nibm -----f----v----f---- jpjnob-1 510 ! | | 511 ! nibm -- u -- T -- u --- jpjnob-1 512 ! | | 513 ! nibm2 -----f----v----f---- jpjnob-2 514 ! | | 515 ! 516 ! ... Free surface formulation: 517 ! ... radiative conditions on the total part + relaxation toward climatology 518 ! ... jpjnob,(jpindp1, jpinfm1) 519 DO jj = njn0, njn1 520 DO jk = 1, jpkm1 521 DO ji = 1, jpi 522 ! ... 2* gradj(v) (T-point i=nibm, time mean) 523 z05cx = v_cynbnd(ji,jk) 524 z05cx = z05cx / e2t(ji,jj) 525 z05cx = min( z05cx, 1. ) 526 ! ... z05cx=< 0, inflow zin=0, ztau=1 527 ! > 0, outflow zin=1, ztau=rtaun 528 zin = sign( 1., z05cx ) 529 zin = 0.5*( zin + abs(zin) ) 530 ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 531 ztau = (1.-zin ) * rtaunin + zin * rtaun 532 z05cx = z05cx * zin 533 ! ... update va with radiative or climatological velocity 534 va(ji,jj,jk) = va(ji,jj,jk) * (1.-vnmsk(ji,jk)) + & 535 vnmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 536 * vnbnd(ji,jk,nib ,nitm) + 2.*z05cx & 537 * vnbnd(ji,jk,nibm,nit ) + ztau * vfon (ji,jk) ) & 538 / (1. + z05cx) 539 END DO 540 END DO 541 END DO 542 END IF 543 544 END SUBROUTINE obc_dyn_north 545 546 SUBROUTINE obc_dyn_south ( kt ) 547 !!------------------------------------------------------------------------------ 548 !! SUBROUTINE obc_dyn_south 549 !! ************************* 550 !! ** Purpose : 551 !! Apply the radiation algorithm on south OBC velocities ua, va using the 552 !! phase velocities calculated in obc_rad_south subroutine in obcrad.F90 module 553 !! If the logical lfbcsouth is .TRUE., there is no radiation but only fixed OBC 55 554 !! 56 INTEGER :: jk,ii,ij,ib,igrd ! Loop counter 57 LOGICAL :: ll_dyn2d, ll_dyn3d 58 !! 59 60 IF(wrk_in_use(2, 7,8) ) THEN 61 CALL ctl_stop('obc_dyn: ERROR: requested workspace arrays are unavailable.') ; RETURN 555 !! History : 556 !! ! 95-03 (J.-M. Molines) Original from SPEM 557 !! ! 97-07 (G. Madec, J.-M. Molines) additions 558 !! ! 97-12 (M. Imbard) Mpp adaptation 559 !! ! 00-06 (J.-M. Molines) 560 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 561 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 562 !!------------------------------------------------------------------------------ 563 !! * Arguments 564 INTEGER, INTENT( in ) :: kt 565 566 !! * Local declaration 567 REAL(wp) :: z05cx, ztau, zin 568 569 !!------------------------------------------------------------------------------ 570 !! OPA 8.5, LODYC-IPSL (2002) 571 !!------------------------------------------------------------------------------ 572 573 ! 1. First three time steps and more if lfbcsouth is .TRUE. 574 ! In that case open boundary conditions are FIXED. 575 ! --------------------------------------------------------- 576 577 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcsouth .OR. lk_dynspg_exp ) THEN 578 579 ! 1.1 U zonal velocity 580 ! -------------------- 581 DO jj = njs0, njs1 582 DO jk = 1, jpkm1 583 DO ji = 1, jpi 584 ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-usmsk(ji,jk)) + & 585 usmsk(ji,jk) * ufos(ji,jk) 586 END DO 587 END DO 588 END DO 589 590 ! 1.2 V meridional velocity 591 ! ------------------------- 592 DO jj = njs0, njs1 593 DO jk = 1, jpkm1 594 DO ji = 1, jpi 595 va(ji,jj,jk)= va(ji,jj,jk) * (1.-vsmsk(ji,jk)) + & 596 vsmsk(ji,jk) * vfos(ji,jk) 597 END DO 598 END DO 599 END DO 600 601 ELSE 602 603 ! 2. Beyond the fourth time step if lfbcsouth is .FALSE. 604 ! ------------------------------------------------------ 605 606 ! 2.1. u-component of the velocity 607 ! -------------------------------- 608 ! 609 ! ji-row 610 ! | 611 ! nibm2 -----f----- jpjsob +2 612 ! | 613 ! nibm2 -- u ---- jpjsob +2 614 ! | 615 ! nibm -----f----- jpjsob +1 616 ! | 617 ! nibm -- u ---- jpjsob +1 618 ! | 619 ! nib -----f----- jpjsob 620 ! /////|////// 621 ! nib ////u///// jpjsob 622 ! 623 ! ... radiative condition plus Raymond-Kuo 624 ! ... jpjsob,(jpisdp1, jpisfm1) 625 DO jj = njs0, njs1 626 DO jk = 1, jpkm1 627 DO ji = 1, jpi 628 z05cx= u_cysbnd(ji,jk) 629 z05cx = z05cx / e2f(ji, jj) 630 z05cx = max( z05cx, -1. ) 631 ! ... z05cx > 0, inflow zin=0, ztau=1 632 ! =< 0, outflow zin=1, ztau=rtaus 633 zin = sign( 1., -1. * z05cx ) 634 zin = 0.5*( zin + abs(zin) ) 635 ztau = (1.-zin ) * rtausin + zin * rtaus 636 z05cx = z05cx * zin 637 ! ... update ua with radiative or climatological velocity 638 ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-usmsk(ji,jk)) + & 639 usmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 640 * usbnd(ji,jk,nib ,nitm) - 2.*z05cx & 641 * usbnd(ji,jk,nibm,nit ) + ztau * ufos (ji,jk) ) & 642 / (1. - z05cx) 643 END DO 644 END DO 645 END DO 646 647 ! 2.2 v-component of the velocity 648 ! ------------------------------- 649 ! 650 ! ji-row ji-row 651 ! | | 652 ! nibm2 -----f----v----f---- jpjsob+2 653 ! | | 654 ! nibm - u -- T -- u ---- jpjsob+2 655 ! | | 656 ! nibm -----f----v----f---- jpjsob+1 657 ! | | 658 ! nib -- u -- T -- u --- jpjsob+1 659 ! | | 660 ! nib -----f----v----f---- jpjsob 661 ! ///////////////////// 662 ! 663 ! ... Free surface formulation: 664 ! ... radiative conditions on the total part + relaxation toward climatology 665 ! ... jpjsob,(jpisdp1,jpisfm1) 666 DO jj = njs0, njs1 667 DO jk = 1, jpkm1 668 DO ji = 1, jpi 669 z05cx = v_cysbnd(ji,jk) 670 z05cx = z05cx / e2t(ji,jj+1) 671 z05cx = max( z05cx, -1. ) 672 ! ... z05c > 0, inflow zin=0, ztau=1 673 ! =< 0, outflow zin=1, ztau=rtaus 674 zin = sign( 1., -1. * z05cx ) 675 zin = 0.5*( zin + abs(zin) ) 676 ztau = (1.-zin )*rtausin + zin * rtaus 677 z05cx = z05cx * zin 678 ! ... update va with radiative or climatological velocity 679 va(ji,jj,jk) = va(ji,jj,jk) * (1.-vsmsk(ji,jk)) + & 680 vsmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 681 * vsbnd(ji,jk,nib ,nitm) - 2.*z05cx & 682 * vsbnd(ji,jk,nibm,nit ) + ztau * vfos (ji,jk) ) & 683 / (1. - z05cx) 684 END DO 685 END DO 686 END DO 62 687 END IF 63 688 64 ll_dyn2d = .true. 65 ll_dyn3d = .true. 66 67 IF( PRESENT(dyn3d_only) ) THEN 68 IF( dyn3d_only ) ll_dyn2d = .false. 69 ENDIF 70 71 !------------------------------------------------------- 72 ! Set pointers 73 !------------------------------------------------------- 74 75 pssh => sshn 76 phur => hur 77 phvr => hvr 78 pu2d => wrk_2d_7 79 pv2d => wrk_2d_8 80 81 !------------------------------------------------------- 82 ! Split velocities into barotropic and baroclinic parts 83 !------------------------------------------------------- 84 85 pu2d(:,:) = 0.e0 86 pv2d(:,:) = 0.e0 87 DO jk = 1, jpkm1 !! Vertically integrated momentum trends 88 pu2d(:,:) = pu2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 89 pv2d(:,:) = pv2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 90 END DO 91 pu2d(:,:) = pu2d(:,:) * phur(:,:) 92 pv2d(:,:) = pv2d(:,:) * phvr(:,:) 93 DO jk = 1 , jpkm1 94 ua(:,:,jk) = ua(:,:,jk) - pu2d(:,:) 95 va(:,:,jk) = va(:,:,jk) - pv2d(:,:) 96 END DO 97 98 !------------------------------------------------------- 99 ! Apply boundary conditions to barotropic and baroclinic 100 ! parts separately 101 !------------------------------------------------------- 102 103 IF( ll_dyn2d ) CALL obc_dyn2d( kt ) 104 105 IF( ll_dyn3d ) CALL obc_dyn3d( kt ) 106 107 !------------------------------------------------------- 108 ! Recombine velocities 109 !------------------------------------------------------- 110 111 DO jk = 1 , jpkm1 112 ua(:,:,jk) = ( ua(:,:,jk) + pu2d(:,:) ) * umask(:,:,jk) 113 va(:,:,jk) = ( va(:,:,jk) + pv2d(:,:) ) * vmask(:,:,jk) 114 END DO 115 116 IF(wrk_not_released(2, 7,8) ) CALL ctl_stop('obc_dyn: ERROR: failed to release workspace arrays.') 117 118 END SUBROUTINE obc_dyn 119 689 END SUBROUTINE obc_dyn_south 120 690 #else 121 !!---------------------------------------------------------------------- 122 !! Dummy module NO Unstruct Open Boundary Conditions 123 !!---------------------------------------------------------------------- 691 !!================================================================================= 692 !! *** MODULE obcdyn *** 693 !! Ocean dynamics: Radiation of velocities on each open boundary 694 !!================================================================================= 124 695 CONTAINS 125 SUBROUTINE obc_dyn( kt ) ! Empty routine 126 WRITE(*,*) 'obc_dyn: You should not have seen this print! error?', kt 696 697 SUBROUTINE obc_dyn 698 ! No open boundaries ==> empty routine 127 699 END SUBROUTINE obc_dyn 128 700 #endif 129 701 130 !!======================================================================131 702 END MODULE obcdyn -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90
r2865 r2888 1 MODULE obcini1 MODULE obcini 2 2 !!====================================================================== 3 3 !! *** MODULE obcini *** 4 !! Unstructured open boundaries : initialisation4 !! OBC initial state : Open boundary initial state 5 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! - ! 2007-01 (D. Storkey) Update to use IOM module 8 !! - ! 2007-01 (D. Storkey) Tidal forcing 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !! 3.3 ! 2010-09 (E.O'Dea) updates for Shelf configurations 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 !! 3.4 ! 2011 (D. Storkey, J. Chanut) OBC-BDY merge 13 !! ! --- Renamed bdyini.F90 -> obcini.F90 --- 6 !! History : 8.0 ! 97-07 (J.M. Molines, G. Madec) Original code 7 !! NEMO 1.0 ! 02-11 (C. Talandier, A-M. Treguier) Free surface, F90 8 !! 2.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 14 9 !!---------------------------------------------------------------------- 15 10 #if defined key_obc 16 11 !!---------------------------------------------------------------------- 17 !! 'key_obc' UnstructuredOpen Boundary Conditions12 !! 'key_obc' Open Boundary Conditions 18 13 !!---------------------------------------------------------------------- 19 !! obc_init : Initialization of unstructured open boundaries14 !! obc_init : initialization for the open boundary condition 20 15 !!---------------------------------------------------------------------- 21 16 USE oce ! ocean dynamics and tracers variables 22 USE dom_oce ! ocean space and time domain 23 USE obc_oce ! unstructured open boundary conditions 17 USE dom_oce ! ocean space and time domain variables 18 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 19 USE phycst ! physical constants 20 USE obc_oce ! open boundary condition: ocean 21 USE obcdta ! open boundary condition: data 24 22 USE in_out_manager ! I/O units 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE lib_mpp ! for mpp_sum 27 USE iom ! I/O 23 USE lib_mpp ! MPP library 24 USE dynspg_oce ! flag lk_dynspg_flt 28 25 29 26 IMPLICIT NONE … … 32 29 PUBLIC obc_init ! routine called by opa.F90 33 30 31 !! * Substitutions 32 # include "obc_vectopt_loop_substitute.h90" 34 33 !!---------------------------------------------------------------------- 35 !! NEMO/OPA 4.0 , NEMO Consortium (2011)34 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 36 35 !! $Id$ 37 36 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 43 42 !! *** ROUTINE obc_init *** 44 43 !! 45 !! ** Purpose : Initialization of the dynamics and tracer fields with46 !! unstructuredopen boundaries.44 !! ** Purpose : Initialization of the dynamics and tracer fields at 45 !! the open boundaries. 47 46 !! 48 !! ** Method : Read initialization arrays (mask, indices) to identify 49 !! an unstructured open boundary 47 !! ** Method : initialization of open boundary variables 48 !! (u, v) over 3 time step and 3 rows 49 !! (t, s) over 2 time step and 2 rows 50 !! if ln_rstart = .FALSE. : no restart, fields set to zero 51 !! if ln_rstart = .TRUE. : restart, fields are read in a file 52 !! if rdpxxx = 0 then lfbc is set true for this boundary. 50 53 !! 51 !! ** Input : obc_init.nc, input file for unstructured open boundaries 52 !!---------------------------------------------------------------------- 53 ! namelist variables 54 !------------------- 55 INTEGER, PARAMETER :: jp_nseg = 100 56 INTEGER :: nobcsege, nobcsegw, nobcsegn, nobcsegs 57 INTEGER, DIMENSION(jp_nseg) :: jpieob, jpjedt, jpjeft 58 INTEGER, DIMENSION(jp_nseg) :: jpiwob, jpjwdt, jpjwft 59 INTEGER, DIMENSION(jp_nseg) :: jpjnob, jpindt, jpinft 60 INTEGER, DIMENSION(jp_nseg) :: jpjsob, jpisdt, jpisft 61 62 ! local variables 63 !------------------- 64 INTEGER :: ib_obc, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 65 INTEGER :: icount, icountr, ibr_max, ilen1, ibm1 ! local integers 66 INTEGER :: iw, ie, is, in, inum, id_dummy ! - - 67 INTEGER :: igrd_start, igrd_end, jpbdta ! - - 68 INTEGER, POINTER :: nbi, nbj, nbr ! short cuts 69 REAL , POINTER :: flagu, flagv ! - - 70 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 71 INTEGER, DIMENSION (2) :: kdimsz 72 INTEGER, DIMENSION(jpbgrd,jp_obc) :: nblendta ! Length of index arrays 73 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of obc dta 74 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 75 REAL(wp), DIMENSION(jpidta,jpjdta) :: zmask ! global domain mask 76 CHARACTER(LEN=80),DIMENSION(jpbgrd) :: clfile 77 CHARACTER(LEN=1),DIMENSION(jpbgrd) :: cgrid 54 !! ** Input : restart.obc file, restart file for open boundaries 55 !!---------------------------------------------------------------------- 56 USE obcrst, ONLY : obc_rst_read ! Make obc_rst_read routine available 78 57 !! 79 NAMELIST/namobc/ nb_obc, ln_coords_file, cn_coords_file, & 80 & ln_mask_file, cn_mask_file, nn_dyn2d, nn_dyn2d_dta, & 81 & nn_dyn3d, nn_dyn3d_dta, nn_tra, nn_tra_dta, & 82 #if defined key_lim2 83 & nn_ice_lim2, nn_ice_lim2_dta, & 84 #endif 85 & ln_vol, nn_volctl, & 86 & nn_rimwidth, nn_dmp2d_in, nn_dmp2d_out, & 87 & nn_dmp3d_in, nn_dmp3d_out 58 INTEGER :: ji, jj, istop , inumfbc 59 INTEGER, DIMENSION(4) :: icorner 60 REAL(wp), DIMENSION(2) :: ztestmask 88 61 !! 89 NAMELIST/namobc_index/ nobcsege, jpieob, jpjedt, jpjeft, & 90 nobcsegw, jpiwob, jpjwdt, jpjwft, & 91 nobcsegn, jpjnob, jpindt, jpinft, & 92 nobcsegs, jpjsob, jpisdt, jpisft 93 62 NAMELIST/namobc/ rn_dpein, rn_dpwin, rn_dpnin, rn_dpsin, & 63 & rn_dpeob, rn_dpwob, rn_dpnob, rn_dpsob, & 64 & rn_volemp, nn_obcdta, cn_obcdta, & 65 & ln_obc_clim, ln_vol_cst, ln_obc_fla 94 66 !!---------------------------------------------------------------------- 95 67 96 IF( obc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate oce arrays' ) 68 REWIND( numnam ) ! Namelist namobc : open boundaries 69 READ ( numnam, namobc ) 70 71 ! convert DOCTOR namelist name into the OLD names 72 nobc_dta = nn_obcdta 73 cffile = cn_obcdta 74 rdpein = rn_dpein 75 rdpwin = rn_dpwin 76 rdpsin = rn_dpsin 77 rdpnin = rn_dpnin 78 rdpeob = rn_dpeob 79 rdpwob = rn_dpwob 80 rdpsob = rn_dpsob 81 rdpnob = rn_dpnob 82 volemp = rn_volemp 83 84 ! ! allocate obc arrays 85 IF( obc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_oce arrays' ) 86 IF( obc_dta_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_dta arrays' ) 87 88 ! By security we set rdpxin and rdpxob respectively to 1. and 15. if the corresponding OBC is not activated 89 IF( .NOT.lp_obc_east ) THEN ; rdpein = 1. ; rdpeob = 15. ; END IF 90 IF( .NOT.lp_obc_west ) THEN ; rdpwin = 1. ; rdpwob = 15. ; END IF 91 IF( .NOT.lp_obc_north ) THEN ; rdpnin = 1. ; rdpnob = 15. ; END IF 92 IF( .NOT.lp_obc_south ) THEN ; rdpsin = 1. ; rdpsob = 15. ; END IF 93 94 ! number of open boudaries and open boundary indicators 95 nbobc = 0 96 IF( lp_obc_east ) nbobc = nbobc + 1 97 IF( lp_obc_west ) nbobc = nbobc + 1 98 IF( lp_obc_north ) nbobc = nbobc + 1 99 IF( lp_obc_south ) nbobc = nbobc + 1 97 100 98 101 IF(lwp) WRITE(numout,*) 99 102 IF(lwp) WRITE(numout,*) 'obc_init : initialization of open boundaries' 100 103 IF(lwp) WRITE(numout,*) '~~~~~~~~' 101 ! 102 103 IF( jperio /= 0 ) CALL ctl_stop( 'Cyclic or symmetric,', & 104 & ' and general open boundary condition are not compatible' ) 105 106 cgrid= (/'t','u','v'/) 107 108 ! ----------------------------------------- 109 ! Initialise and read namelist parameters 110 ! ----------------------------------------- 111 112 nb_obc = 0 113 ln_coords_file(:) = .false. 114 cn_coords_file(:) = '' 115 ln_mask_file = .false. 116 cn_mask_file(:) = '' 117 nn_dyn2d(:) = 0 118 nn_dyn2d_dta(:) = -1 ! uninitialised flag 119 nn_dyn3d(:) = 0 120 nn_dyn3d_dta(:) = -1 ! uninitialised flag 121 nn_tra(:) = 0 122 nn_tra_dta(:) = -1 ! uninitialised flag 123 #if defined key_lim2 124 nn_ice_lim2(:) = 0 125 nn_ice_lim2_dta(:)= -1 ! uninitialised flag 126 #endif 127 ln_vol = .false. 128 nn_volctl = -1 ! uninitialised flag 129 nn_rimwidth(:) = -1 ! uninitialised flag 130 nn_dmp2d_in(:) = -1 ! uninitialised flag 131 nn_dmp2d_out(:) = -1 ! uninitialised flag 132 nn_dmp3d_in(:) = -1 ! uninitialised flag 133 nn_dmp3d_out(:) = -1 ! uninitialised flag 134 135 REWIND( numnam ) 136 READ ( numnam, namobc ) 137 138 ! ----------------------------------------- 139 ! Check and write out namelist parameters 140 ! ----------------------------------------- 141 142 ! ! control prints 143 IF(lwp) WRITE(numout,*) ' namobc' 144 145 IF( nb_obc .eq. 0 ) THEN 146 IF(lwp) WRITE(numout,*) 'nb_obc = 0, NO OPEN BOUNDARIES APPLIED.' 104 IF(lwp) WRITE(numout,*) ' Number of open boundaries nbobc = ', nbobc 105 IF(lwp) WRITE(numout,*) 106 107 ! control prints 108 IF(lwp) WRITE(numout,*) ' Namelist namobc' 109 IF(lwp) WRITE(numout,*) ' data in file (=1) or initial state used (=0) nn_obcdta = ', nn_obcdta 110 IF(lwp) WRITE(numout,*) ' climatology (true) or not ln_obc_clim = ', ln_obc_clim 111 IF(lwp) WRITE(numout,*) ' vol_cst (true) or not: ln_vol_cst = ', ln_vol_cst 112 IF(lwp) WRITE(numout,*) ' ' 113 IF(lwp) WRITE(numout,*) ' WARNING ' 114 IF(lwp) WRITE(numout,*) ' Flather"s algorithm is applied with explicit free surface scheme ' 115 IF(lwp) WRITE(numout,*) ' or with free surface time-splitting scheme ' 116 IF(lwp) WRITE(numout,*) ' Nor radiation neither relaxation is allowed with explicit free surface scheme: ' 117 IF(lwp) WRITE(numout,*) ' Radiation and/or relaxation is allowed with free surface time-splitting scheme ' 118 IF(lwp) WRITE(numout,*) ' depending of the choice of rdpXin = rdpXob = 0. for open boundaries ' 119 IF(lwp) WRITE(numout,*) 120 IF(lwp) WRITE(numout,*) ' For the filtered free surface case, ' 121 IF(lwp) WRITE(numout,*) ' radiation, relaxation or presciption of data can be applied ' 122 IF(lwp) WRITE(numout,*) 123 124 IF( lwp.AND.lp_obc_east ) THEN 125 WRITE(numout,*) ' East open boundary :' 126 WRITE(numout,*) ' i index jpieob = ', jpieob 127 WRITE(numout,*) ' damping time scale (days) rn_dpeob = ', rn_dpeob 128 WRITE(numout,*) ' damping time scale (days) rn_dpein = ', rn_dpein 129 ENDIF 130 131 IF( lwp.AND.lp_obc_west ) THEN 132 WRITE(numout,*) ' West open boundary :' 133 WRITE(numout,*) ' i index jpiwob = ', jpiwob 134 WRITE(numout,*) ' damping time scale (days) rn_dpwob = ', rn_dpwob 135 WRITE(numout,*) ' damping time scale (days) rn_dpwin = ', rn_dpwin 136 ENDIF 137 138 IF( lwp.AND.lp_obc_north ) THEN 139 WRITE(numout,*) ' North open boundary :' 140 WRITE(numout,*) ' j index jpjnob = ', jpjnob 141 WRITE(numout,*) ' damping time scale (days) rn_dpnob = ', rn_dpnob 142 WRITE(numout,*) ' damping time scale (days) rn_dpnin = ', rn_dpnin 143 ENDIF 144 145 IF( lwp.AND.lp_obc_south ) THEN 146 WRITE(numout,*) ' South open boundary :' 147 WRITE(numout,*) ' j index jpjsob = ', jpjsob 148 WRITE(numout,*) ' damping time scale (days) rn_dpsob = ', rn_dpsob 149 WRITE(numout,*) ' damping time scale (days) rn_dpsin = ', rn_dpsin 150 WRITE(numout,*) 151 ENDIF 152 153 IF( nbobc >= 2 .AND. jperio /= 0 ) & 154 & CALL ctl_stop( ' Cyclic or symmetric, and open boundary condition are not compatible' ) 155 156 ! 1. Initialisation of constants 157 ! ------------------------------ 158 ! ... convert rdp$ob in seconds 159 ! Fixed Bdy flag inbound outbound 160 lfbceast = .FALSE. ; rdpein = rdpein * rday ; rdpeob = rdpeob * rday 161 lfbcwest = .FALSE. ; rdpwin = rdpwin * rday ; rdpwob = rdpwob * rday 162 lfbcnorth = .FALSE. ; rdpnin = rdpnin * rday ; rdpnob = rdpnob * rday 163 lfbcsouth = .FALSE. ; rdpsin = rdpsin * rday ; rdpsob = rdpsob * rday 164 inumfbc = 0 165 ! ... look for Fixed Boundaries (rdp = 0 ) 166 ! ... When specified, lbcxxx flags are set to TRUE and rdpxxx are set to 167 ! ... a small arbitrary value, (to avoid division by zero further on). 168 ! ... rdpxxx is not used anymore. 169 IF( lp_obc_east ) THEN 170 IF( (rdpein+rdpeob) == 0 ) THEN 171 lfbceast = .TRUE. ; rdpein = 1e-3 ; rdpeob = 1e-3 172 inumfbc = inumfbc+1 173 ELSEIF ( (rdpein*rdpeob) == 0 ) THEN 174 CALL ctl_stop( 'obc_init : rn_dpein & rn_dpeob must be both zero or non zero' ) 175 END IF 176 END IF 177 178 IF( lp_obc_west ) THEN 179 IF( (rdpwin + rdpwob) == 0 ) THEN 180 lfbcwest = .TRUE. ; rdpwin = 1e-3 ; rdpwob = 1e-3 181 inumfbc = inumfbc+1 182 ELSEIF ( (rdpwin*rdpwob) == 0 ) THEN 183 CALL ctl_stop( 'obc_init : rn_dpwin & rn_dpwob must be both zero or non zero' ) 184 END IF 185 END IF 186 IF( lp_obc_north ) THEN 187 IF( (rdpnin + rdpnob) == 0 ) THEN 188 lfbcnorth = .TRUE. ; rdpnin = 1e-3 ; rdpnob = 1e-3 189 inumfbc = inumfbc+1 190 ELSEIF ( (rdpnin*rdpnob) == 0 ) THEN 191 CALL ctl_stop( 'obc_init : rn_dpnin & rn_dpnob must be both zero or non zero' ) 192 END IF 193 END IF 194 IF( lp_obc_south ) THEN 195 IF( (rdpsin + rdpsob) == 0 ) THEN 196 lfbcsouth = .TRUE. ; rdpsin = 1e-3 ; rdpsob = 1e-3 197 inumfbc = inumfbc+1 198 ELSEIF ( (rdpsin*rdpsob) == 0 ) THEN 199 CALL ctl_stop( 'obc_init : rn_dpsin & rn_dpsob must be both zero or non zero' ) 200 END IF 201 END IF 202 203 ! 2. Clever mpp indices for loops on the open boundaries. 204 ! The loops will be performed only on the processors 205 ! that contain a given open boundary. 206 ! -------------------------------------------------------- 207 208 IF( lp_obc_east ) THEN 209 ! ... mpp initialization 210 nie0 = max( 1, min(jpieob - nimpp+1, jpi ) ) 211 nie1 = max( 0, min(jpieob - nimpp+1, jpi - 1 ) ) 212 nie0p1 = max( 1, min(jpieob+1 - nimpp+1, jpi ) ) 213 nie1p1 = max( 0, min(jpieob+1 - nimpp+1, jpi - 1 ) ) 214 nie0m1 = max( 1, min(jpieob-1 - nimpp+1, jpi ) ) 215 nie1m1 = max( 0, min(jpieob-1 - nimpp+1, jpi - 1 ) ) 216 nje0 = max( 2, min(jpjed - njmpp+1, jpj ) ) 217 nje1 = max( 0, min(jpjef - njmpp+1, jpj - 1 ) ) 218 nje0p1 = max( 1, min(jpjedp1 - njmpp+1, jpj ) ) 219 nje0m1 = max( 1, min(jpjed - njmpp+1, jpj ) ) 220 nje1m1 = max( 0, min(jpjefm1 - njmpp+1, jpj - 1 ) ) 221 nje1m2 = max( 0, min(jpjefm1-1- njmpp+1, jpj - 1 ) ) 222 IF(lwp) THEN 223 IF( lfbceast ) THEN 224 WRITE(numout,*)' ' 225 WRITE(numout,*)' Specified East Open Boundary' 226 ELSE 227 WRITE(numout,*)' ' 228 WRITE(numout,*)' Radiative East Open Boundary' 229 END IF 230 END IF 231 END IF 232 233 IF( lp_obc_west ) THEN 234 ! ... mpp initialization 235 niw0 = max( 1, min(jpiwob - nimpp+1, jpi ) ) 236 niw1 = max( 0, min(jpiwob - nimpp+1, jpi - 1 ) ) 237 niw0p1 = max( 1, min(jpiwob+1 - nimpp+1, jpi ) ) 238 niw1p1 = max( 0, min(jpiwob+1 - nimpp+1, jpi - 1 ) ) 239 njw0 = max( 2, min(jpjwd - njmpp+1, jpj ) ) 240 njw1 = max( 0, min(jpjwf - njmpp+1, jpj - 1 ) ) 241 njw0p1 = max( 1, min(jpjwdp1 - njmpp+1, jpj ) ) 242 njw0m1 = max( 1, min(jpjwd - njmpp+1, jpj ) ) 243 njw1m1 = max( 0, min(jpjwfm1 - njmpp+1, jpj - 1 ) ) 244 njw1m2 = max( 0, min(jpjwfm1-1- njmpp+1, jpj - 1 ) ) 245 IF(lwp) THEN 246 IF( lfbcwest ) THEN 247 WRITE(numout,*)' ' 248 WRITE(numout,*)' Specified West Open Boundary' 249 ELSE 250 WRITE(numout,*)' ' 251 WRITE(numout,*)' Radiative West Open Boundary' 252 END IF 253 END IF 254 END IF 255 256 IF( lp_obc_north ) THEN 257 ! ... mpp initialization 258 nin0 = max( 2, min(jpind - nimpp+1, jpi ) ) 259 nin1 = max( 0, min(jpinf - nimpp+1, jpi - 1 ) ) 260 nin0p1 = max( 1, min(jpindp1 - nimpp+1, jpi ) ) 261 nin0m1 = max( 1, min(jpind - nimpp+1, jpi ) ) 262 nin1m1 = max( 0, min(jpinfm1 - nimpp+1, jpi - 1 ) ) 263 nin1m2 = max( 0, min(jpinfm1-1- nimpp+1, jpi - 1 ) ) 264 njn0 = max( 1, min(jpjnob - njmpp+1, jpj ) ) 265 njn1 = max( 0, min(jpjnob - njmpp+1, jpj - 1 ) ) 266 njn0p1 = max( 1, min(jpjnob+1 - njmpp+1, jpj ) ) 267 njn1p1 = max( 0, min(jpjnob+1 - njmpp+1, jpj - 1 ) ) 268 njn0m1 = max( 1, min(jpjnob-1 - njmpp+1, jpj ) ) 269 njn1m1 = max( 0, min(jpjnob-1 - njmpp+1, jpj - 1 ) ) 270 IF(lwp) THEN 271 IF( lfbcnorth ) THEN 272 WRITE(numout,*)' ' 273 WRITE(numout,*)' Specified North Open Boundary' 274 ELSE 275 WRITE(numout,*)' ' 276 WRITE(numout,*)' Radiative North Open Boundary' 277 END IF 278 END IF 279 END IF 280 281 IF( lp_obc_south ) THEN 282 ! ... mpp initialization 283 nis0 = max( 2, min(jpisd - nimpp+1, jpi ) ) 284 nis1 = max( 0, min(jpisf - nimpp+1, jpi - 1 ) ) 285 nis0p1 = max( 1, min(jpisdp1 - nimpp+1, jpi ) ) 286 nis0m1 = max( 1, min(jpisd - nimpp+1, jpi ) ) 287 nis1m1 = max( 0, min(jpisfm1 - nimpp+1, jpi - 1 ) ) 288 nis1m2 = max( 0, min(jpisfm1-1- nimpp+1, jpi - 1 ) ) 289 njs0 = max( 1, min(jpjsob - njmpp+1, jpj ) ) 290 njs1 = max( 0, min(jpjsob - njmpp+1, jpj - 1 ) ) 291 njs0p1 = max( 1, min(jpjsob+1 - njmpp+1, jpj ) ) 292 njs1p1 = max( 0, min(jpjsob+1 - njmpp+1, jpj - 1 ) ) 293 IF(lwp) THEN 294 IF( lfbcsouth ) THEN 295 WRITE(numout,*)' ' 296 WRITE(numout,*)' Specified South Open Boundary' 297 ELSE 298 WRITE(numout,*)' ' 299 WRITE(numout,*)' Radiative South Open Boundary' 300 END IF 301 END IF 302 END IF 303 304 ! 3. mask correction for OBCs 305 ! --------------------------- 306 307 IF( lp_obc_east ) THEN 308 !... (jpjed,jpjefm1),jpieob 309 bmask(nie0p1:nie1p1,nje0:nje1m1) = 0.e0 310 311 ! ... initilization to zero 312 uemsk(:,:) = 0.e0 ; vemsk(:,:) = 0.e0 ; temsk(:,:) = 0.e0 313 314 ! ... set 2D mask on East OBC, Vopt 315 DO ji = fs_nie0, fs_nie1 316 DO jj = nje0, nje1 317 uemsk(jj,:) = umask(ji, jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj) 318 vemsk(jj,:) = vmask(ji+1,jj,:) * tmask_i(ji+1,jj) 319 temsk(jj,:) = tmask(ji+1,jj,:) * tmask_i(ji+1,jj) 320 END DO 321 END DO 322 323 END IF 324 325 IF( lp_obc_west ) THEN 326 ! ... (jpjwd,jpjwfm1),jpiwob 327 bmask(niw0:niw1,njw0:njw1m1) = 0.e0 328 329 ! ... initilization to zero 330 uwmsk(:,:) = 0.e0 ; vwmsk(:,:) = 0.e0 ; twmsk(:,:) = 0.e0 331 332 ! ... set 2D mask on West OBC, Vopt 333 DO ji = fs_niw0, fs_niw1 334 DO jj = njw0, njw1 335 uwmsk(jj,:) = umask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj) 336 vwmsk(jj,:) = vmask(ji,jj,:) * tmask_i(ji,jj) 337 twmsk(jj,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 338 END DO 339 END DO 340 341 END IF 342 343 IF( lp_obc_north ) THEN 344 ! ... jpjnob,(jpind,jpisfm1) 345 bmask(nin0:nin1m1,njn0p1:njn1p1) = 0.e0 346 347 ! ... initilization to zero 348 unmsk(:,:) = 0.e0 ; vnmsk(:,:) = 0.e0 ; tnmsk(:,:) = 0.e0 349 350 ! ... set 2D mask on North OBC, Vopt 351 DO jj = fs_njn0, fs_njn1 352 DO ji = nin0, nin1 353 unmsk(ji,:) = umask(ji,jj+1,:) * tmask_i(ji,jj+1) 354 vnmsk(ji,:) = vmask(ji,jj ,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1) 355 tnmsk(ji,:) = tmask(ji,jj+1,:) * tmask_i(ji,jj+1) 356 END DO 357 END DO 358 359 END IF 360 361 IF( lp_obc_south ) THEN 362 ! ... jpjsob,(jpisd,jpisfm1) 363 bmask(nis0:nis1m1,njs0:njs1) = 0.e0 364 365 ! ... initilization to zero 366 usmsk(:,:) = 0.e0 ; vsmsk(:,:) = 0.e0 ; tsmsk(:,:) = 0.e0 367 368 ! ... set 2D mask on South OBC, Vopt 369 DO jj = fs_njs0, fs_njs1 370 DO ji = nis0, nis1 371 usmsk(ji,:) = umask(ji,jj,:) * tmask_i(ji,jj) 372 vsmsk(ji,:) = vmask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1) 373 tsmsk(ji,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 374 END DO 375 END DO 376 377 END IF 378 379 ! ... Initialize obcumask and obcvmask for the Force filtering 380 ! boundary condition in dynspg_flt 381 obcumask(:,:) = umask(:,:,1) 382 obcvmask(:,:) = vmask(:,:,1) 383 384 ! ... Initialize obctmsk on overlap region and obcs. This mask 385 ! is used in obcvol.F90 to calculate cumulate flux E-P. 386 ! obc Tracer point are outside the domain ( U/V obc points) ==> masked by obctmsk 387 ! - no flux E-P on obcs and overlap region (jpreci = jprecj = 1) 388 obctmsk(:,:) = tmask_i(:,:) 389 390 IF( lp_obc_east ) THEN 391 ! ... East obc Force filtering mask for the grad D 392 obcumask(nie0 :nie1 ,nje0p1:nje1m1) = 0.e0 393 obcvmask(nie0p1:nie1p1,nje0p1:nje1m1) = 0.e0 394 ! ... set to 0 on East OBC 395 obctmsk(nie0p1:nie1p1,nje0:nje1) = 0.e0 396 END IF 397 398 IF( lp_obc_west ) THEN 399 ! ... West obc Force filtering mask for the grad D 400 obcumask(niw0:niw1,njw0:njw1) = 0.e0 401 obcvmask(niw0:niw1,njw0:njw1) = 0.e0 402 ! ... set to 0 on West OBC 403 obctmsk(niw0:niw1,njw0:njw1) = 0.e0 404 END IF 405 406 IF( lp_obc_north ) THEN 407 ! ... North obc Force filtering mask for the grad D 408 obcumask(nin0p1:nin1m1,njn0p1:njn1p1) = 0.e0 409 obcvmask(nin0p1:nin1m1,njn0 :njn1 ) = 0.e0 410 ! ... set to 0 on North OBC 411 obctmsk(nin0:nin1,njn0p1:njn1p1) = 0.e0 412 END IF 413 414 IF( lp_obc_south ) THEN 415 ! ... South obc Force filtering mask for the grad D 416 obcumask(nis0p1:nis1m1,njs0:njs1) = 0.e0 417 obcvmask(nis0p1:nis1m1,njs0:njs1) = 0.e0 418 ! ... set to 0 on South OBC 419 obctmsk(nis0:nis1,njs0:njs1) = 0.e0 420 END IF 421 422 ! 3.1 Total lateral surface 423 ! ------------------------- 424 obcsurftot = 0.e0 425 426 IF( lp_obc_east ) THEN ! ... East open boundary lateral surface 427 DO ji = nie0, nie1 428 DO jj = 1, jpj 429 obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uemsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 430 END DO 431 END DO 432 END IF 433 434 IF( lp_obc_west ) THEN ! ... West open boundary lateral surface 435 DO ji = niw0, niw1 436 DO jj = 1, jpj 437 obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uwmsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 438 END DO 439 END DO 440 END IF 441 442 IF( lp_obc_north ) THEN ! ... North open boundary lateral surface 443 DO jj = njn0, njn1 444 DO ji = 1, jpi 445 obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vnmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 446 END DO 447 END DO 448 END IF 449 450 IF( lp_obc_south ) THEN ! ... South open boundary lateral surface 451 DO jj = njs0, njs1 452 DO ji = 1, jpi 453 obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vsmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 454 END DO 455 END DO 456 END IF 457 458 IF( lk_mpp ) CALL mpp_sum( obcsurftot ) ! sum over the global domain 459 460 ! 5. Control print on mask 461 ! The extremities of the open boundaries must be in land 462 ! or else correspond to an "ocean corner" between two open boundaries. 463 ! corner 1 is southwest, 2 is south east, 3 is northeast, 4 is northwest. 464 ! -------------------------------------------------------------------------- 465 466 icorner(:)=0 467 468 ! ... control of the west boundary 469 IF( lp_obc_west ) THEN 470 IF( jpiwob < 2 .OR. jpiwob >= jpiglo-2 ) THEN 471 WRITE(ctmp1,*) ' jpiwob exceed ', jpiglo-2, 'or less than 2' 472 CALL ctl_stop( ctmp1 ) 473 END IF 474 ztestmask(:)=0. 475 DO ji=niw0,niw1 476 IF( (njw0 + njmpp - 1) == jpjwd ) ztestmask(1)=ztestmask(1)+ tmask(ji,njw0,1) 477 IF( (njw1 + njmpp - 1) == jpjwf ) ztestmask(2)=ztestmask(2)+ tmask(ji,njw1,1) 478 END DO 479 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 480 481 IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 482 IF( ztestmask(2) /= 0. ) icorner(4)=icorner(4)+1 483 END IF 484 485 ! ... control of the east boundary 486 IF( lp_obc_east ) THEN 487 IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN 488 WRITE(ctmp1,*) ' jpieob exceed ', jpiglo, ' or less than 4' 489 CALL ctl_stop( ctmp1 ) 490 END IF 491 ztestmask(:)=0. 492 DO ji=nie0p1,nie1p1 493 IF( (nje0 + njmpp - 1) == jpjed ) ztestmask(1)=ztestmask(1)+ tmask(ji,nje0,1) 494 IF( (nje1 + njmpp - 1) == jpjef ) ztestmask(2)=ztestmask(2)+ tmask(ji,nje1,1) 495 END DO 496 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 497 498 IF( ztestmask(1) /= 0. ) icorner(2)=icorner(2)+1 499 IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 500 END IF 501 502 ! ... control of the north boundary 503 IF( lp_obc_north ) THEN 504 IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN 505 WRITE(ctmp1,*) 'jpjnob exceed ', jpjglo, ' or less than 4' 506 CALL ctl_stop( ctmp1 ) 507 END IF 508 ztestmask(:)=0. 509 DO jj=njn0p1,njn1p1 510 IF( (nin0 + nimpp - 1) == jpind ) ztestmask(1)=ztestmask(1)+ tmask(nin0,jj,1) 511 IF( (nin1 + nimpp - 1) == jpinf ) ztestmask(2)=ztestmask(2)+ tmask(nin1,jj,1) 512 END DO 513 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 514 515 IF( ztestmask(1) /= 0. ) icorner(4)=icorner(4)+1 516 IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 517 END IF 518 519 ! ... control of the south boundary 520 IF( lp_obc_south ) THEN 521 IF( jpjsob < 2 .OR. jpjsob >= jpjglo-2 ) THEN 522 WRITE(ctmp1,*) ' jpjsob exceed ', jpjglo-2, ' or less than 2' 523 CALL ctl_stop( ctmp1 ) 524 END IF 525 ztestmask(:)=0. 526 DO jj=njs0,njs1 527 IF( (nis0 + nimpp - 1) == jpisd ) ztestmask(1)=ztestmask(1)+ tmask(nis0,jj,1) 528 IF( (nis1 + nimpp - 1) == jpisf ) ztestmask(2)=ztestmask(2)+ tmask(nis1,jj,1) 529 END DO 530 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 531 532 IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 533 IF( ztestmask(2) /= 0. ) icorner(2)=icorner(2)+1 534 END IF 535 536 IF( icorner(1) == 2 ) THEN 537 IF(lwp) WRITE(numout,*) 538 IF(lwp) WRITE(numout,*) ' South West ocean corner, two open boudaries' 539 IF(lwp) WRITE(numout,*) ' ========== ' 540 IF(lwp) WRITE(numout,*) 541 IF( jpisd /= jpiwob.OR.jpjsob /= jpjwd ) & 542 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 543 544 ELSE IF( icorner(1) == 1 ) THEN 545 CALL ctl_stop( ' Open boundaries do not fit at SW corner, we stop' ) 546 END IF 547 548 IF( icorner(2) == 2 ) THEN 549 IF(lwp) WRITE(numout,*) 550 IF(lwp) WRITE(numout,*) ' South East ocean corner, two open boudaries' 551 IF(lwp) WRITE(numout,*) ' ========== ' 552 IF(lwp) WRITE(numout,*) 553 IF( jpisf /= jpieob+1.OR.jpjsob /= jpjed ) & 554 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 555 ELSE IF( icorner(2) == 1 ) THEN 556 CALL ctl_stop( ' Open boundaries do not fit at SE corner, we stop' ) 557 END IF 558 559 IF( icorner(3) == 2 ) THEN 560 IF(lwp) WRITE(numout,*) 561 IF(lwp) WRITE(numout,*) ' North East ocean corner, two open boudaries' 562 IF(lwp) WRITE(numout,*) ' ========== ' 563 IF(lwp) WRITE(numout,*) 564 IF( jpinf /= jpieob+1 .OR. jpjnob+1 /= jpjef ) & 565 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 566 ELSE IF( icorner(3) == 1 ) THEN 567 CALL ctl_stop( ' Open boundaries do not fit at NE corner, we stop' ) 568 END IF 569 570 IF( icorner(4) == 2 ) THEN 571 IF(lwp) WRITE(numout,*) 572 IF(lwp) WRITE(numout,*) ' North West ocean corner, two open boudaries' 573 IF(lwp) WRITE(numout,*) ' ========== ' 574 IF(lwp) WRITE(numout,*) 575 IF( jpind /= jpiwob.OR.jpjnob+1 /= jpjwf ) & 576 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 577 ELSE IF( icorner(4) == 1 ) THEN 578 CALL ctl_stop( ' Open boundaries do not fit at NW corner, we stop' ) 579 END IF 580 581 ! 6. Initialization of open boundary variables (u, v, t, s) 582 ! -------------------------------------------------------------- 583 ! only if at least one boundary is radiative 584 IF ( inumfbc < nbobc .AND. ln_rstart ) THEN 585 ! Restart from restart.obc 586 CALL obc_rst_read 147 587 ELSE 148 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ',nb_obc 588 589 ! ! ... Initialization to zero of radiation arrays. 590 ! ! Those have dimensions of local subdomains 591 592 uebnd(:,:,:,:) = 0.e0 ; unbnd(:,:,:,:) = 0.e0 593 vebnd(:,:,:,:) = 0.e0 ; vnbnd(:,:,:,:) = 0.e0 594 tebnd(:,:,:,:) = 0.e0 ; tnbnd(:,:,:,:) = 0.e0 595 sebnd(:,:,:,:) = 0.e0 ; snbnd(:,:,:,:) = 0.e0 596 597 uwbnd(:,:,:,:) = 0.e0 ; usbnd(:,:,:,:) = 0.e0 598 vwbnd(:,:,:,:) = 0.e0 ; vsbnd(:,:,:,:) = 0.e0 599 twbnd(:,:,:,:) = 0.e0 ; tsbnd(:,:,:,:) = 0.e0 600 swbnd(:,:,:,:) = 0.e0 ; ssbnd(:,:,:,:) = 0.e0 601 602 END IF 603 604 ! 7. Control print 605 ! ----------------------------------------------------------------- 606 607 ! ... control of the east boundary 608 IF( lp_obc_east ) THEN 609 istop = 0 610 IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN 611 IF(lwp) WRITE(numout,cform_err) 612 IF(lwp) WRITE(numout,*) ' jpieob exceed ', jpim1, ' or less than 4' 613 istop = istop + 1 614 END IF 615 616 IF( lk_mpp ) THEN 617 ! ... 618 IF( nimpp > jpieob-5) THEN 619 IF(lwp) WRITE(numout,cform_err) 620 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the East OBC' 621 IF(lwp) WRITE(numout,*) ' nimpp must be < jpieob-5' 622 istop = istop + 1 623 ENDIF 624 ELSE 625 626 ! ... stop if e r r o r (s) detected 627 IF( istop /= 0 ) THEN 628 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 629 CALL ctl_stop( ctmp1 ) 630 ENDIF 631 ENDIF 149 632 ENDIF 150 633 151 DO ib_obc = 1,nb_obc 152 IF(lwp) WRITE(numout,*) ' ' 153 IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_obc,'------' 154 155 IF( ln_coords_file(ib_obc) ) THEN 156 IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_obc)) 157 ELSE 158 IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.' 159 ENDIF 160 IF(lwp) WRITE(numout,*) 161 162 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 163 SELECT CASE( nn_dyn2d(ib_obc) ) 164 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 165 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 166 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Flather radiation condition' 167 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn2d' ) 168 END SELECT 169 IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 170 SELECT CASE( nn_dyn2d_dta(ib_obc) ) ! 171 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for obc data' 172 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 173 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' tidal harmonic forcing taken from file' 174 CASE( 3 ) ; IF(lwp) WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' 175 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 176 END SELECT 177 ENDIF 178 IF(lwp) WRITE(numout,*) 179 180 IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' 181 SELECT CASE( nn_dyn3d(ib_obc) ) 182 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 183 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 184 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn3d' ) 185 END SELECT 186 IF( nn_dyn3d(ib_obc) .gt. 0 ) THEN 187 SELECT CASE( nn_dyn3d_dta(ib_obc) ) ! 188 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for obc data' 189 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 190 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 191 END SELECT 192 ENDIF 193 IF(lwp) WRITE(numout,*) 194 195 IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' 196 SELECT CASE( nn_tra(ib_obc) ) 197 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 198 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 199 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 200 END SELECT 201 IF( nn_tra(ib_obc) .gt. 0 ) THEN 202 SELECT CASE( nn_tra_dta(ib_obc) ) ! 203 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for obc data' 204 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 205 CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 206 END SELECT 207 ENDIF 208 IF(lwp) WRITE(numout,*) 209 210 #if defined key_lim2 211 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 212 SELECT CASE( nn_ice_lim2(ib_obc) ) 213 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 214 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 215 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 216 END SELECT 217 IF( nn_ice_lim2(ib_obc) .gt. 0 ) THEN 218 SELECT CASE( nn_ice_lim2_dta(ib_obc) ) ! 219 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for obc data' 220 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 221 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim2_dta must be 0 or 1' ) 222 END SELECT 223 ENDIF 224 IF(lwp) WRITE(numout,*) 225 #endif 226 227 IF(lwp) WRITE(numout,*) 'Boundary rim width for the FRS scheme = ', nn_rimwidth(ib_obc) 228 IF(lwp) WRITE(numout,*) 229 230 ENDDO 231 232 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) 233 IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 234 IF(lwp) WRITE(numout,*) 235 SELECT CASE ( nn_volctl ) 236 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' The total volume will be constant' 237 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' 238 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 239 END SELECT 240 IF(lwp) WRITE(numout,*) 241 ELSE 242 IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 243 IF(lwp) WRITE(numout,*) 244 ENDIF 245 246 ! ------------------------------------------------- 247 ! Initialise indices arrays for open boundaries 248 ! ------------------------------------------------- 249 250 ! Work out global dimensions of boundary data 251 ! --------------------------------------------- 252 REWIND( numnam ) 253 DO ib_obc = 1, nb_obc 254 255 jpbdta = 1 256 IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Work out size of global arrays from namelist parameters 257 258 ! No REWIND here because may need to read more than one namobc_index namelist. 259 READ ( numnam, namobc_index ) 260 261 ! Automatic boundary definition: if nobcsegX = -1 262 ! set boundary to whole side of model domain. 263 IF( nobcsege == -1 ) THEN 264 nobcsege = 1 265 jpieob(1) = jpiglo - 1 266 jpjedt(1) = 2 267 jpjeft(1) = jpjglo - 1 634 ! ... control of the west boundary 635 IF( lp_obc_west ) THEN 636 istop = 0 637 IF( jpiwob < 2 .OR. jpiwob >= jpiglo ) THEN 638 IF(lwp) WRITE(numout,cform_err) 639 IF(lwp) WRITE(numout,*) ' jpiwob exceed ', jpim1, ' or less than 2' 640 istop = istop + 1 641 END IF 642 643 IF( lk_mpp ) THEN 644 IF( (nimpp < jpiwob+5) .AND. (nimpp > 1) ) THEN 645 IF(lwp) WRITE(numout,cform_err) 646 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the West OBC' 647 IF(lwp) WRITE(numout,*) ' nimpp must be > jpiwob-5 or =1' 648 istop = istop + 1 268 649 ENDIF 269 IF( nobcsegw == -1 ) THEN 270 nobcsegw = 1 271 jpiwob(1) = 2 272 jpjwdt(1) = 2 273 jpjwft(1) = jpjglo - 1 650 ELSE 651 652 ! ... stop if e r r o r (s) detected 653 IF( istop /= 0 ) THEN 654 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 655 CALL ctl_stop( ctmp1 ) 274 656 ENDIF 275 IF( nobcsegn == -1 ) THEN 276 nobcsegn = 1 277 jpjnob(1) = jpjglo - 1 278 jpindt(1) = 2 279 jpinft(1) = jpiglo - 1 657 ENDIF 658 ENDIF 659 660 ! control of the north boundary 661 IF( lp_obc_north ) THEN 662 istop = 0 663 IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN 664 IF(lwp) WRITE(numout,cform_err) 665 IF(lwp) WRITE(numout,*) ' jpjnob exceed ', jpjm1,' or less than 4' 666 istop = istop + 1 667 END IF 668 669 IF( lk_mpp ) THEN 670 IF( njmpp > jpjnob-5) THEN 671 IF(lwp) WRITE(numout,cform_err) 672 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the North OBC' 673 IF(lwp) WRITE(numout,*) ' njmpp must be < jpjnob-5' 674 istop = istop + 1 280 675 ENDIF 281 IF( nobcsegs == -1 ) THEN 282 nobcsegs = 1 283 jpjsob(1) = 2 284 jpisdt(1) = 2 285 jpisft(1) = jpiglo - 1 676 ELSE 677 678 ! ... stop if e r r o r (s) detected 679 IF( istop /= 0 ) THEN 680 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 681 CALL ctl_stop( ctmp1 ) 682 ENDIF 683 ENDIF 684 ENDIF 685 686 ! control of the south boundary 687 IF( lp_obc_south ) THEN 688 istop = 0 689 IF( jpjsob < 2 .OR. jpjsob >= jpjglo ) THEN 690 IF(lwp) WRITE(numout,cform_err) 691 IF(lwp) WRITE(numout,*) ' jpjsob exceed ', jpjm1,' or less than 2' 692 istop = istop + 1 693 END IF 694 695 IF( lk_mpp ) THEN 696 IF( (njmpp < jpjsob+5) .AND. (njmpp > 1) ) THEN 697 IF(lwp) WRITE(numout,cform_err) 698 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the South OBC' 699 IF(lwp) WRITE(numout,*) ' njmpp must be > jpjsob+5 or =1' 700 istop = istop + 1 286 701 ENDIF 287 288 nblendta(:,ib_obc) = 0 289 DO iseg = 1, nobcsege 290 igrd = 1 291 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg) + 1 292 igrd = 2 293 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg) + 1 294 igrd = 3 295 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjeft(iseg) - jpjedt(iseg) 296 ENDDO 297 DO iseg = 1, nobcsegw 298 igrd = 1 299 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg) + 1 300 igrd = 2 301 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg) + 1 302 igrd = 3 303 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpjwft(iseg) - jpjwdt(iseg) 304 ENDDO 305 DO iseg = 1, nobcsegn 306 igrd = 1 307 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg) + 1 308 igrd = 2 309 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg) 310 igrd = 3 311 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpinft(iseg) - jpindt(iseg) + 1 312 ENDDO 313 DO iseg = 1, nobcsegs 314 igrd = 1 315 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) + 1 316 igrd = 2 317 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) 318 igrd = 3 319 nblendta(igrd,ib_obc) = nblendta(igrd,ib_obc) + jpisft(iseg) - jpisdt(iseg) + 1 320 ENDDO 321 322 nblendta(:,ib_obc) = nblendta(:,ib_obc) * nn_rimwidth(ib_obc) 323 jpbdta = MAXVAL(nblendta(:,ib_obc)) 324 325 326 ELSE ! Read size of arrays in boundary coordinates file. 327 328 329 CALL iom_open( cn_coords_file(ib_obc), inum ) 330 jpbdta = 1 331 DO igrd = 1, jpbgrd 332 id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) 333 nblendta(igrd,ib_obc) = kdimsz(1) 334 jpbdta = MAX(jpbdta, kdimsz(1)) 335 ENDDO 336 337 ENDIF 338 339 ENDDO ! ib_obc 340 341 ! Allocate arrays 342 !--------------- 343 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_obc), nbjdta(jpbdta, jpbgrd, nb_obc), & 344 & nbrdta(jpbdta, jpbgrd, nb_obc) ) 345 346 ALLOCATE( dta_global(jpbdta, 1, jpk) ) 347 348 ! Calculate global boundary index arrays or read in from file 349 !------------------------------------------------------------ 350 REWIND( numnam ) 351 DO ib_obc = 1, nb_obc 352 353 IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Calculate global index arrays from namelist parameters 354 355 ! No REWIND here because may need to read more than one namobc_index namelist. 356 READ ( numnam, namobc_index ) 357 358 ! Automatic boundary definition: if nobcsegX = -1 359 ! set boundary to whole side of model domain. 360 IF( nobcsege == -1 ) THEN 361 nobcsege = 1 362 jpieob(1) = jpiglo - 1 363 jpjedt(1) = 2 364 jpjeft(1) = jpjglo - 1 702 ELSE 703 704 ! ... stop if e r r o r (s) detected 705 IF( istop /= 0 ) THEN 706 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 707 CALL ctl_stop( ctmp1 ) 365 708 ENDIF 366 IF( nobcsegw == -1 ) THEN 367 nobcsegw = 1 368 jpiwob(1) = 2 369 jpjwdt(1) = 2 370 jpjwft(1) = jpjglo - 1 371 ENDIF 372 IF( nobcsegn == -1 ) THEN 373 nobcsegn = 1 374 jpjnob(1) = jpjglo - 1 375 jpindt(1) = 2 376 jpinft(1) = jpiglo - 1 377 ENDIF 378 IF( nobcsegs == -1 ) THEN 379 nobcsegs = 1 380 jpjsob(1) = 2 381 jpisdt(1) = 2 382 jpisft(1) = jpiglo - 1 383 ENDIF 384 385 ! ------------ T points ------------- 386 igrd = 1 387 icount = 0 388 DO ir = 1, nn_rimwidth(ib_obc) 389 ! east 390 DO iseg = 1, nobcsege 391 DO ij = jpjedt(iseg), jpjeft(iseg) 392 icount = icount + 1 393 nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir + 1 394 nbjdta(icount, igrd, ib_obc) = ij 395 nbrdta(icount, igrd, ib_obc) = ir 396 ENDDO 397 ENDDO 398 ! west 399 DO iseg = 1, nobcsegw 400 DO ij = jpjwdt(iseg), jpjwft(iseg) 401 icount = icount + 1 402 nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 403 nbjdta(icount, igrd, ib_obc) = ij 404 nbrdta(icount, igrd, ib_obc) = ir 405 ENDDO 406 ENDDO 407 ! north 408 DO iseg = 1, nobcsegn 409 DO ii = jpindt(iseg), jpinft(iseg) 410 icount = icount + 1 411 nbidta(icount, igrd, ib_obc) = ii 412 nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir + 1 413 nbrdta(icount, igrd, ib_obc) = ir 414 ENDDO 415 ENDDO 416 ! south 417 DO iseg = 1, nobcsegs 418 DO ii = jpisdt(iseg), jpisft(iseg) 419 icount = icount + 1 420 nbidta(icount, igrd, ib_obc) = ii 421 nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 422 nbrdta(icount, igrd, ib_obc) = ir 423 ENDDO 424 ENDDO 425 ENDDO 426 427 ! ------------ U points ------------- 428 igrd = 2 429 icount = 0 430 DO ir = 1, nn_rimwidth(ib_obc) 431 ! east 432 DO iseg = 1, nobcsege 433 DO ij = jpjedt(iseg), jpjeft(iseg) 434 icount = icount + 1 435 nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir 436 nbjdta(icount, igrd, ib_obc) = ij 437 nbrdta(icount, igrd, ib_obc) = ir 438 ENDDO 439 ENDDO 440 ! west 441 DO iseg = 1, nobcsegw 442 DO ij = jpjwdt(iseg), jpjwft(iseg) 443 icount = icount + 1 444 nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 445 nbjdta(icount, igrd, ib_obc) = ij 446 nbrdta(icount, igrd, ib_obc) = ir 447 ENDDO 448 ENDDO 449 ! north 450 DO iseg = 1, nobcsegn 451 DO ii = jpindt(iseg), jpinft(iseg) - 1 452 icount = icount + 1 453 nbidta(icount, igrd, ib_obc) = ii 454 nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir + 1 455 nbrdta(icount, igrd, ib_obc) = ir 456 ENDDO 457 ENDDO 458 ! south 459 DO iseg = 1, nobcsegs 460 DO ii = jpisdt(iseg), jpisft(iseg) - 1 461 icount = icount + 1 462 nbidta(icount, igrd, ib_obc) = ii 463 nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 464 nbrdta(icount, igrd, ib_obc) = ir 465 ENDDO 466 ENDDO 467 ENDDO 468 469 ! ------------ V points ------------- 470 igrd = 3 471 icount = 0 472 DO ir = 1, nn_rimwidth(ib_obc) 473 ! east 474 DO iseg = 1, nobcsege 475 DO ij = jpjedt(iseg), jpjeft(iseg) - 1 476 icount = icount + 1 477 nbidta(icount, igrd, ib_obc) = jpieob(iseg) - ir + 1 478 nbjdta(icount, igrd, ib_obc) = ij 479 nbrdta(icount, igrd, ib_obc) = ir 480 ENDDO 481 ENDDO 482 ! west 483 DO iseg = 1, nobcsegw 484 DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 485 icount = icount + 1 486 nbidta(icount, igrd, ib_obc) = jpiwob(iseg) + ir - 1 487 nbjdta(icount, igrd, ib_obc) = ij 488 nbrdta(icount, igrd, ib_obc) = ir 489 ENDDO 490 ENDDO 491 ! north 492 DO iseg = 1, nobcsegn 493 DO ii = jpindt(iseg), jpinft(iseg) 494 icount = icount + 1 495 nbidta(icount, igrd, ib_obc) = ii 496 nbjdta(icount, igrd, ib_obc) = jpjnob(iseg) - ir 497 nbrdta(icount, igrd, ib_obc) = ir 498 ENDDO 499 ENDDO 500 ! south 501 DO iseg = 1, nobcsegs 502 DO ii = jpisdt(iseg), jpisft(iseg) 503 icount = icount + 1 504 nbidta(icount, igrd, ib_obc) = ii 505 nbjdta(icount, igrd, ib_obc) = jpjsob(iseg) + ir + 1 506 nbrdta(icount, igrd, ib_obc) = ir 507 ENDDO 508 ENDDO 509 ENDDO 510 511 ELSE ! Read global index arrays from boundary coordinates file. 512 513 DO igrd = 1, jpbgrd 514 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 515 DO ii = 1,nblendta(igrd,ib_obc) 516 nbidta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 517 END DO 518 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 519 DO ii = 1,nblendta(igrd,ib_obc) 520 nbjdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 521 END DO 522 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 523 DO ii = 1,nblendta(igrd,ib_obc) 524 nbrdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 525 END DO 526 527 ibr_max = MAXVAL( nbrdta(:,igrd,ib_obc) ) 528 IF(lwp) WRITE(numout,*) 529 IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max 530 IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_obc) 531 IF (ibr_max < nn_rimwidth(ib_obc)) & 532 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_obc) ) 533 534 END DO 535 CALL iom_close( inum ) 536 537 ENDIF 538 539 ENDDO 540 541 ! Work out dimensions of boundary data on each processor 542 ! ------------------------------------------------------ 543 544 iw = mig(1) + 1 ! if monotasking and no zoom, iw=2 545 ie = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 546 is = mjg(1) + 1 ! if monotasking and no zoom, is=2 547 in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 548 549 DO ib_obc = 1, nb_obc 550 DO igrd = 1, jpbgrd 551 icount = 0 552 icountr = 0 553 idx_obc(ib_obc)%nblen(igrd) = 0 554 idx_obc(ib_obc)%nblenrim(igrd) = 0 555 DO ib = 1, nblendta(igrd,ib_obc) 556 ! check that data is in correct order in file 557 ibm1 = MAX(1,ib-1) 558 IF(lwp) THEN ! Since all procs read global data only need to do this check on one proc... 559 IF( nbrdta(ib,igrd,ib_obc) < nbrdta(ibm1,igrd,ib_obc) ) THEN 560 CALL ctl_stop('obc_init : ERROR : boundary data in file must be defined in order of distance from edge nbr.', & 561 'A utility for re-ordering boundary coordinates and data files exists in CDFTOOLS') 562 ENDIF 563 ENDIF 564 ! check if point is in local domain 565 IF( nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND. & 566 & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in ) THEN 567 ! 568 icount = icount + 1 569 ! 570 IF( nbrdta(ib,igrd,ib_obc) == 1 ) icountr = icountr+1 571 ENDIF 572 ENDDO 573 idx_obc(ib_obc)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 574 idx_obc(ib_obc)%nblen (igrd) = icount !: length of boundary data on each proc 575 ENDDO ! igrd 576 577 ! Allocate index arrays for this boundary set 578 !-------------------------------------------- 579 ilen1 = MAXVAL(idx_obc(ib_obc)%nblen(:)) 580 ALLOCATE( idx_obc(ib_obc)%nbi(ilen1,jpbgrd) ) 581 ALLOCATE( idx_obc(ib_obc)%nbj(ilen1,jpbgrd) ) 582 ALLOCATE( idx_obc(ib_obc)%nbr(ilen1,jpbgrd) ) 583 ALLOCATE( idx_obc(ib_obc)%nbmap(ilen1,jpbgrd) ) 584 ALLOCATE( idx_obc(ib_obc)%nbw(ilen1,jpbgrd) ) 585 ALLOCATE( idx_obc(ib_obc)%flagu(ilen1) ) 586 ALLOCATE( idx_obc(ib_obc)%flagv(ilen1) ) 587 588 ! Dispatch mapping indices and discrete distances on each processor 589 ! ----------------------------------------------------------------- 590 591 DO igrd = 1, jpbgrd 592 icount = 0 593 ! Loop on rimwidth to ensure outermost points come first in the local arrays. 594 DO ir=1, nn_rimwidth(ib_obc) 595 DO ib = 1, nblendta(igrd,ib_obc) 596 ! check if point is in local domain and equals ir 597 IF( nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND. & 598 & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in .AND. & 599 & nbrdta(ib,igrd,ib_obc) == ir ) THEN 600 ! 601 icount = icount + 1 602 idx_obc(ib_obc)%nbi(icount,igrd) = nbidta(ib,igrd,ib_obc)- mig(1)+1 603 idx_obc(ib_obc)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_obc)- mjg(1)+1 604 idx_obc(ib_obc)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_obc) 605 idx_obc(ib_obc)%nbmap(icount,igrd) = ib 606 ENDIF 607 ENDDO 608 ENDDO 609 ENDDO 610 611 ! Compute rim weights for FRS scheme 612 ! ---------------------------------- 613 DO igrd = 1, jpbgrd 614 DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 615 nbr => idx_obc(ib_obc)%nbr(ib,igrd) 616 idx_obc(ib_obc)%nbw(ib,igrd) = 1.- TANH( FLOAT( nbr - 1 ) *0.5 ) ! tanh formulation 617 ! idx_obc(ib_obc)%nbw(ib,igrd) = (FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth))**2 ! quadratic 618 ! idx_obc(ib_obc)%nbw(ib,igrd) = FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth) ! linear 619 END DO 620 END DO 621 622 ENDDO 623 624 ! ------------------------------------------------------ 625 ! Initialise masks and find normal/tangential directions 626 ! ------------------------------------------------------ 627 628 ! Read global 2D mask at T-points: obctmask 629 ! ----------------------------------------- 630 ! obctmask = 1 on the computational domain AND on open boundaries 631 ! = 0 elsewhere 632 633 IF( cp_cfg == "eel" .AND. jp_cfg == 5 ) THEN ! EEL configuration at 5km resolution 634 zmask( : ,:) = 0.e0 635 zmask(jpizoom+1:jpizoom+jpiglo-2,:) = 1.e0 636 ELSE IF( ln_mask_file ) THEN 637 CALL iom_open( cn_mask_file, inum ) 638 CALL iom_get ( inum, jpdom_data, 'obc_msk', zmask(:,:) ) 639 CALL iom_close( inum ) 640 ELSE 641 zmask(:,:) = 1.e0 709 ENDIF 642 710 ENDIF 643 644 DO ij = 1, nlcj ! Save mask over local domain645 DO ii = 1, nlci646 obctmask(ii,ij) = zmask( mig(ii), mjg(ij) )647 END DO648 END DO649 650 ! Derive mask on U and V grid from mask on T grid651 obcumask(:,:) = 0.e0652 obcvmask(:,:) = 0.e0653 DO ij=1, jpjm1654 DO ii=1, jpim1655 obcumask(ii,ij)=obctmask(ii,ij)*obctmask(ii+1, ij )656 obcvmask(ii,ij)=obctmask(ii,ij)*obctmask(ii ,ij+1)657 END DO658 END DO659 CALL lbc_lnk( obcumask(:,:), 'U', 1. ) ; CALL lbc_lnk( obcvmask(:,:), 'V', 1. ) ! Lateral boundary cond.660 661 662 ! Mask corrections663 ! ----------------664 DO ik = 1, jpkm1665 DO ij = 1, jpj666 DO ii = 1, jpi667 tmask(ii,ij,ik) = tmask(ii,ij,ik) * obctmask(ii,ij)668 umask(ii,ij,ik) = umask(ii,ij,ik) * obcumask(ii,ij)669 vmask(ii,ij,ik) = vmask(ii,ij,ik) * obcvmask(ii,ij)670 bmask(ii,ij) = bmask(ii,ij) * obctmask(ii,ij)671 END DO672 END DO673 END DO674 675 DO ik = 1, jpkm1676 DO ij = 2, jpjm1677 DO ii = 2, jpim1678 fmask(ii,ij,ik) = fmask(ii,ij,ik) * obctmask(ii,ij ) * obctmask(ii+1,ij ) &679 & * obctmask(ii,ij+1) * obctmask(ii+1,ij+1)680 END DO681 END DO682 END DO683 684 tmask_i (:,:) = tmask(:,:,1) * tmask_i(:,:)685 obctmask(:,:) = tmask(:,:,1)686 687 ! obc masks and bmask are now set to zero on boundary points:688 igrd = 1 ! In the free surface case, bmask is at T-points689 DO ib_obc = 1, nb_obc690 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)691 bmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0692 ENDDO693 ENDDO694 !695 igrd = 1696 DO ib_obc = 1, nb_obc697 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)698 obctmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0699 ENDDO700 ENDDO701 !702 igrd = 2703 DO ib_obc = 1, nb_obc704 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)705 obcumask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0706 ENDDO707 ENDDO708 !709 igrd = 3710 DO ib_obc = 1, nb_obc711 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)712 obcvmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0713 ENDDO714 ENDDO715 716 ! Lateral boundary conditions717 CALL lbc_lnk( fmask , 'F', 1. ) ; CALL lbc_lnk( obctmask(:,:), 'T', 1. )718 CALL lbc_lnk( obcumask(:,:), 'U', 1. ) ; CALL lbc_lnk( obcvmask(:,:), 'V', 1. )719 720 DO ib_obc = 1, nb_obc ! Indices and directions of rim velocity components721 722 idx_obc(ib_obc)%flagu(:) = 0.e0723 idx_obc(ib_obc)%flagv(:) = 0.e0724 icount = 0725 726 !flagu = -1 : u component is normal to the dynamical boundary but its direction is outward727 !flagu = 0 : u is tangential728 !flagu = 1 : u is normal to the boundary and is direction is inward729 730 igrd = 2 ! u-component731 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)732 nbi => idx_obc(ib_obc)%nbi(ib,igrd)733 nbj => idx_obc(ib_obc)%nbj(ib,igrd)734 zefl = obctmask(nbi ,nbj)735 zwfl = obctmask(nbi+1,nbj)736 IF( zefl + zwfl == 2 ) THEN737 icount = icount + 1738 ELSE739 idx_obc(ib_obc)%flagu(ib)=-zefl+zwfl740 ENDIF741 END DO742 743 !flagv = -1 : u component is normal to the dynamical boundary but its direction is outward744 !flagv = 0 : u is tangential745 !flagv = 1 : u is normal to the boundary and is direction is inward746 747 igrd = 3 ! v-component748 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)749 nbi => idx_obc(ib_obc)%nbi(ib,igrd)750 nbj => idx_obc(ib_obc)%nbj(ib,igrd)751 znfl = obctmask(nbi,nbj )752 zsfl = obctmask(nbi,nbj+1)753 IF( znfl + zsfl == 2 ) THEN754 icount = icount + 1755 ELSE756 idx_obc(ib_obc)%flagv(ib) = -znfl + zsfl757 END IF758 END DO759 760 IF( icount /= 0 ) THEN761 IF(lwp) WRITE(numout,*)762 IF(lwp) WRITE(numout,*) ' E R R O R : Some data velocity points,', &763 ' are not boundary points. Check nbi, nbj, indices for boundary set ',ib_obc764 IF(lwp) WRITE(numout,*) ' ========== '765 IF(lwp) WRITE(numout,*)766 nstop = nstop + 1767 ENDIF768 769 ENDDO770 771 ! Compute total lateral surface for volume correction:772 ! ----------------------------------------------------773 obcsurftot = 0.e0774 IF( ln_vol ) THEN775 igrd = 2 ! Lateral surface at U-points776 DO ib_obc = 1, nb_obc777 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)778 nbi => idx_obc(ib_obc)%nbi(ib,igrd)779 nbj => idx_obc(ib_obc)%nbi(ib,igrd)780 flagu => idx_obc(ib_obc)%flagu(ib)781 obcsurftot = obcsurftot + hu (nbi , nbj) &782 & * e2u (nbi , nbj) * ABS( flagu ) &783 & * tmask_i(nbi , nbj) &784 & * tmask_i(nbi+1, nbj)785 ENDDO786 ENDDO787 788 igrd=3 ! Add lateral surface at V-points789 DO ib_obc = 1, nb_obc790 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd)791 nbi => idx_obc(ib_obc)%nbi(ib,igrd)792 nbj => idx_obc(ib_obc)%nbi(ib,igrd)793 flagv => idx_obc(ib_obc)%flagv(ib)794 obcsurftot = obcsurftot + hv (nbi, nbj ) &795 & * e1v (nbi, nbj ) * ABS( flagv ) &796 & * tmask_i(nbi, nbj ) &797 & * tmask_i(nbi, nbj+1)798 ENDDO799 ENDDO800 !801 IF( lk_mpp ) CALL mpp_sum( obcsurftot ) ! sum over the global domain802 END IF803 !804 ! Tidy up805 !--------806 DEALLOCATE(nbidta, nbjdta, nbrdta)807 711 808 712 END SUBROUTINE obc_init … … 810 714 #else 811 715 !!--------------------------------------------------------------------------------- 812 !! Dummy module NO open boundaries716 !! Dummy module NO open boundaries 813 717 !!--------------------------------------------------------------------------------- 814 718 CONTAINS -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcrad.F90
r2797 r2888 5 5 !!================================================================================= 6 6 #if defined key_obc 7 !!$!!---------------------------------------------------------------------------------8 !!$!! obc_rad : call the subroutine for each open boundary9 !!$!! obc_rad_east : compute the east phase velocities10 !!$!! obc_rad_west : compute the west phase velocities11 !!$!! obc_rad_north : compute the north phase velocities12 !!$!! obc_rad_south : compute the south phase velocities13 !!$!!---------------------------------------------------------------------------------14 !!$USE oce ! ocean dynamics and tracers variables15 !!$USE dom_oce ! ocean space and time domain variables16 !!$USE lbclnk ! ocean lateral boundary conditions (or mpp link)17 !!$USE phycst ! physical constants18 !!$USE obc_oce ! ocean open boundary conditions19 !!$USE lib_mpp ! for mppobc20 !!$USE in_out_manager ! I/O units21 !!$ 22 !!$IMPLICIT NONE23 !!$PRIVATE24 !!$ 25 !!$PUBLIC obc_rad ! routine called by step.F9026 !!$ 27 !!$INTEGER :: ji, jj, jk ! dummy loop indices28 !!$ 29 !!$INTEGER :: & ! ... boundary space indices30 !!$nib = 1, & ! nib = boundary point31 !!$nibm = 2, & ! nibm = 1st interior point32 !!$nibm2 = 3, & ! nibm2 = 2nd interior point33 !!$! ... boundary time indices34 !!$nit = 1, & ! nit = now35 !!$nitm = 2, & ! nitm = before36 !!$nitm2 = 3 ! nitm2 = before-before37 !!$ 38 !!$!! * Substitutions39 !!$# include "obc_vectopt_loop_substitute.h90"40 !!$!!---------------------------------------------------------------------------------41 !!$!! NEMO/OPA 3.3 , NEMO Consortium (2010)42 !!$!! $Id$43 !!$!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)44 !!$!!---------------------------------------------------------------------------------45 !!$ 46 !!$CONTAINS47 !!$ 48 !!$SUBROUTINE obc_rad ( kt )49 !!$!!------------------------------------------------------------------------------50 !!$!! SUBROUTINE obc_rad51 !!$!! ********************52 !!$!! ** Purpose :53 !!$!! Perform swap of arrays to calculate radiative phase speeds at the open54 !!$!! boundaries and calculate those phase speeds if the open boundaries are55 !!$!! not fixed. In case of fixed open boundaries does nothing.56 !!$!!57 !!$!! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north,58 !!$!! and/or lp_obc_south allow the user to determine which boundary is an59 !!$!! open one (must be done in the param_obc.h90 file).60 !!$!!61 !!$!! ** Reference :62 !!$!! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France.63 !!$!!64 !!$!! History :65 !!$!! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 from the66 !!$!! J. Molines and G. Madec version67 !!$!!------------------------------------------------------------------------------68 !!$INTEGER, INTENT( in ) :: kt69 !!$!!----------------------------------------------------------------------70 !!$ 71 !!$IF( lp_obc_east .AND. .NOT.lfbceast ) CALL obc_rad_east ( kt ) ! East open boundary72 !!$ 73 !!$IF( lp_obc_west .AND. .NOT.lfbcwest ) CALL obc_rad_west ( kt ) ! West open boundary74 !!$ 75 !!$IF( lp_obc_north .AND. .NOT.lfbcnorth ) CALL obc_rad_north( kt ) ! North open boundary76 !!$ 77 !!$IF( lp_obc_south .AND. .NOT.lfbcsouth ) CALL obc_rad_south( kt ) ! South open boundary78 !!$ 79 !!$END SUBROUTINE obc_rad80 !!$ 81 !!$ 82 !!$SUBROUTINE obc_rad_east ( kt )83 !!$!!------------------------------------------------------------------------------84 !!$!! *** SUBROUTINE obc_rad_east ***85 !!$!!86 !!$!! ** Purpose :87 !!$!! Perform swap of arrays to calculate radiative phase speeds at the open88 !!$!! east boundary and calculate those phase speeds if this OBC is not fixed.89 !!$!! In case of fixed OBC, this subrountine is not called.90 !!$!!91 !!$!! History :92 !!$!! ! 95-03 (J.-M. Molines) Original from SPEM93 !!$!! ! 97-07 (G. Madec, J.-M. Molines) additions94 !!$!! ! 97-12 (M. Imbard) Mpp adaptation95 !!$!! ! 00-06 (J.-M. Molines)96 !!$!! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F9097 !!$!!------------------------------------------------------------------------------98 !!$!! * Arguments99 !!$INTEGER, INTENT( in ) :: kt100 !!$ 101 !!$!! * Local declarations102 !!$INTEGER :: ij103 !!$REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy104 !!$REAL(wp) :: zucb, zucbm, zucbm2105 !!$!!------------------------------------------------------------------------------106 !!$ 107 !!$! 1. Swap arrays before calculating radiative velocities108 !!$! ------------------------------------------------------109 !!$ 110 !!$! 1.1 zonal velocity111 !!$! -------------------112 !!$ 113 !!$IF( kt > nit000 .OR. ln_rstart ) THEN114 !!$ 115 !!$! ... advance in time (time filter, array swap)116 !!$DO jk = 1, jpkm1117 !!$DO jj = 1, jpj118 !!$uebnd(jj,jk,nib ,nitm2) = uebnd(jj,jk,nib ,nitm)*uemsk(jj,jk)119 !!$uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk)120 !!$uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk)121 !!$END DO122 !!$END DO123 !!$! ... fields nitm <== nit plus time filter at the boundary124 !!$DO ji = fs_nie0, fs_nie1 ! Vector opt.125 !!$DO jk = 1, jpkm1126 !!$DO jj = 1, jpj127 !!$uebnd(jj,jk,nib ,nitm) = uebnd(jj,jk,nib, nit)*uemsk(jj,jk)128 !!$uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk)129 !!$uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk)130 !!$! ... fields nit <== now (kt+1)131 !!$! ... Total or baroclinic velocity at b, bm and bm2132 !!$zucb = un(ji,jj,jk)133 !!$zucbm = un(ji-1,jj,jk)134 !!$zucbm2 = un(ji-2,jj,jk)135 !!$uebnd(jj,jk,nib ,nit) = zucb *uemsk(jj,jk)136 !!$uebnd(jj,jk,nibm ,nit) = zucbm *uemsk(jj,jk)137 !!$uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk)138 !!$END DO139 !!$END DO140 !!$END DO141 !!$IF( lk_mpp ) CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout )142 !!$ 143 !!$! ... extremeties nie0, nie1144 !!$ij = jpjed +1 - njmpp145 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN146 !!$DO jk = 1,jpkm1147 !!$uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm)148 !!$END DO149 !!$END IF150 !!$ij = jpjef +1 - njmpp151 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN152 !!$DO jk = 1,jpkm1153 !!$uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm)154 !!$END DO155 !!$END IF156 !!$ 157 !!$! 1.2 tangential velocity158 !!$! -----------------------159 !!$ 160 !!$! ... advance in time (time filter, array swap)161 !!$DO jk = 1, jpkm1162 !!$DO jj = 1, jpj163 !!$! ... fields nitm2 <== nitm164 !!$vebnd(jj,jk,nib ,nitm2) = vebnd(jj,jk,nib ,nitm)*vemsk(jj,jk)165 !!$vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk)166 !!$vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk)167 !!$END DO168 !!$END DO169 !!$ 170 !!$DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.171 !!$DO jk = 1, jpkm1172 !!$DO jj = 1, jpj173 !!$vebnd(jj,jk,nib ,nitm) = vebnd(jj,jk,nib, nit)*vemsk(jj,jk)174 !!$vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk)175 !!$vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk)176 !!$! ... fields nit <== now (kt+1)177 !!$vebnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vemsk(jj,jk)178 !!$vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk)179 !!$vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk)180 !!$END DO181 !!$END DO182 !!$END DO183 !!$IF( lk_mpp ) CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout )184 !!$ 185 !!$!... extremeties nie0, nie1186 !!$ij = jpjed +1 - njmpp187 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN188 !!$DO jk = 1,jpkm1189 !!$vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm)190 !!$END DO191 !!$END IF192 !!$ij = jpjef +1 - njmpp193 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN194 !!$DO jk = 1,jpkm1195 !!$vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm)196 !!$END DO197 !!$END IF198 !!$ 199 !!$! 1.3 Temperature and salinity200 !!$! ----------------------------201 !!$ 202 !!$! ... advance in time (time filter, array swap)203 !!$DO jk = 1, jpkm1204 !!$DO jj = 1, jpj205 !!$! ... fields nitm <== nit plus time filter at the boundary206 !!$tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk)207 !!$sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk)208 !!$END DO209 !!$END DO210 !!$ 211 !!$DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.212 !!$DO jk = 1, jpkm1213 !!$DO jj = 1, jpj214 !!$tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk)215 !!$sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk)216 !!$! ... fields nit <== now (kt+1)217 !!$tebnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*temsk(jj,jk)218 !!$tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk)219 !!$sebnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*temsk(jj,jk)220 !!$sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk)221 !!$END DO222 !!$END DO223 !!$END DO224 !!$IF( lk_mpp ) CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout )225 !!$IF( lk_mpp ) CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout )226 !!$ 227 !!$! ... extremeties nie0, nie1228 !!$ij = jpjed +1 - njmpp229 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN230 !!$DO jk = 1,jpkm1231 !!$tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm)232 !!$sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm)233 !!$END DO234 !!$END IF235 !!$ij = jpjef +1 - njmpp236 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN237 !!$DO jk = 1,jpkm1238 !!$tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm)239 !!$sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm)240 !!$END DO241 !!$END IF242 !!$ 243 !!$END IF ! End of array swap244 !!$ 245 !!$! 2 - Calculation of radiation velocities246 !!$! ---------------------------------------247 !!$ 248 !!$IF( kt >= nit000 +3 .OR. ln_rstart ) THEN249 !!$ 250 !!$! 2.1 Calculate the normal velocity U based on phase velocity u_cxebnd251 !!$! ---------------------------------------------------------------------252 !!$!253 !!$! nibm2 nibm nib254 !!$! | nibm | nib |///255 !!$! | | | | |///256 !!$! jj-line --f----v----f----v----f---257 !!$! | | | | |///258 !!$! | | |///259 !!$! jj-line u T u T u///260 !!$! | | |///261 !!$! | | | | |///262 !!$! jpieob-2 jpieob-1 jpieob263 !!$! | |264 !!$! jpieob-1 jpieob265 !!$!266 !!$! ... (jpjedp1, jpjefm1),jpieob267 !!$DO ji = fs_nie0, fs_nie1 ! Vector opt.268 !!$DO jk = 1, jpkm1269 !!$DO jj = 2, jpjm1270 !!$! ... 2* gradi(u) (T-point i=nibm, time mean)271 !!$z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) &272 !!$- 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj)273 !!$! ... 2* gradj(u) (u-point i=nibm, time nitm)274 !!$z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj)275 !!$! ... square of the norm of grad(u)276 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy277 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt278 !!$zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit)279 !!$! ... i-phase speed ratio (bounded by 1)280 !!$IF( z4nor2 == 0. ) THEN281 !!$z4nor2=.00001282 !!$END IF283 !!$z05cx = zdt * z2dx / z4nor2284 !!$u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk)285 !!$END DO286 !!$END DO287 !!$END DO288 !!$ 289 !!$! 2.2 Calculate the tangential velocity based on phase velocity v_cxebnd290 !!$! -----------------------------------------------------------------------291 !!$!292 !!$! nibm2 nibm nib293 !!$! | nibm | nib///|///294 !!$! | | | |////|///295 !!$! jj-line --v----f----v----f----v---296 !!$! | | | |////|///297 !!$! | | | |////|///298 !!$! | jpieob-1| jpieob /|///299 !!$! | | |300 !!$! jpieob-1 jpieob jpieob+1301 !!$!302 !!$! ... (jpjedp1, jpjefm1), jpieob+1303 !!$DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.304 !!$DO jk = 1, jpkm1305 !!$DO jj = 2, jpjm1306 !!$! ... 2* i-gradient of v (f-point i=nibm, time mean)307 !!$z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) &308 !!$- 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj)309 !!$! ... 2* j-gradient of v (v-point i=nibm, time nitm)310 !!$z2dy = ( vebnd(jj+1,jk,nibm,nitm) - vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj)311 !!$! ... square of the norm of grad(v)312 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy313 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt314 !!$zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit)315 !!$! ... i-phase speed ratio (bounded by 1) and save the unbounded phase316 !!$! velocity ratio no divided by e1f for the tracer radiation317 !!$IF( z4nor2 == 0. ) THEN318 !!$z4nor2=.000001319 !!$END IF320 !!$z05cx = zdt * z2dx / z4nor2321 !!$v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk)322 !!$END DO323 !!$END DO324 !!$END DO325 !!$IF( lk_mpp ) CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout )326 !!$ 327 !!$! ... extremeties nie0, nie1328 !!$ij = jpjed +1 - njmpp329 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN330 !!$DO jk = 1,jpkm1331 !!$v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk)332 !!$END DO333 !!$END IF334 !!$ij = jpjef +1 - njmpp335 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN336 !!$DO jk = 1,jpkm1337 !!$v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk)338 !!$END DO339 !!$END IF340 !!$ 341 !!$END IF342 !!$ 343 !!$END SUBROUTINE obc_rad_east344 !!$ 345 !!$ 346 !!$SUBROUTINE obc_rad_west ( kt )347 !!$!!------------------------------------------------------------------------------348 !!$!! *** SUBROUTINE obc_rad_west ***349 !!$!!350 !!$!! ** Purpose :351 !!$!! Perform swap of arrays to calculate radiative phase speeds at the open352 !!$!! west boundary and calculate those phase speeds if this OBC is not fixed.353 !!$!! In case of fixed OBC, this subrountine is not called.354 !!$!!355 !!$!! History :356 !!$!! ! 95-03 (J.-M. Molines) Original from SPEM357 !!$!! ! 97-07 (G. Madec, J.-M. Molines) additions358 !!$!! ! 97-12 (M. Imbard) Mpp adaptation359 !!$!! ! 00-06 (J.-M. Molines)360 !!$!! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90361 !!$!!------------------------------------------------------------------------------362 !!$!! * Arguments363 !!$INTEGER, INTENT( in ) :: kt364 !!$ 365 !!$!! * Local declarations366 !!$INTEGER :: ij367 !!$REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy368 !!$REAL(wp) :: zucb, zucbm, zucbm2369 !!$!!------------------------------------------------------------------------------370 !!$ 371 !!$! 1. Swap arrays before calculating radiative velocities372 !!$! ------------------------------------------------------373 !!$ 374 !!$! 1.1 zonal velocity375 !!$! -------------------376 !!$ 377 !!$IF( kt > nit000 .OR. ln_rstart ) THEN378 !!$ 379 !!$! ... advance in time (time filter, array swap)380 !!$DO jk = 1, jpkm1381 !!$DO jj = 1, jpj382 !!$uwbnd(jj,jk,nib ,nitm2) = uwbnd(jj,jk,nib ,nitm)*uwmsk(jj,jk)383 !!$uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk)384 !!$uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk)385 !!$END DO386 !!$END DO387 !!$ 388 !!$! ... fields nitm <== nit plus time filter at the boundary389 !!$DO ji = fs_niw0, fs_niw1 ! Vector opt.390 !!$DO jk = 1, jpkm1391 !!$DO jj = 1, jpj392 !!$uwbnd(jj,jk,nib ,nitm) = uwbnd(jj,jk,nib ,nit)*uwmsk(jj,jk)393 !!$uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk)394 !!$uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk)395 !!$! ... total or baroclinic velocity at b, bm and bm2396 !!$zucb = un (ji,jj,jk)397 !!$zucbm = un (ji+1,jj,jk)398 !!$zucbm2 = un (ji+2,jj,jk)399 !!$ 400 !!$! ... fields nit <== now (kt+1)401 !!$uwbnd(jj,jk,nib ,nit) = zucb *uwmsk(jj,jk)402 !!$uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk)403 !!$uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk)404 !!$END DO405 !!$END DO406 !!$END DO407 !!$IF( lk_mpp ) CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout )408 !!$ 409 !!$! ... extremeties niw0, niw1410 !!$ij = jpjwd +1 - njmpp411 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN412 !!$DO jk = 1,jpkm1413 !!$uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm)414 !!$END DO415 !!$END IF416 !!$ij = jpjwf +1 - njmpp417 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN418 !!$DO jk = 1,jpkm1419 !!$uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm)420 !!$END DO421 !!$END IF422 !!$ 423 !!$! 1.2 tangential velocity424 !!$! -----------------------425 !!$ 426 !!$! ... advance in time (time filter, array swap)427 !!$DO jk = 1, jpkm1428 !!$DO jj = 1, jpj429 !!$! ... fields nitm2 <== nitm430 !!$vwbnd(jj,jk,nib ,nitm2) = vwbnd(jj,jk,nib ,nitm)*vwmsk(jj,jk)431 !!$vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk)432 !!$vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk)433 !!$END DO434 !!$END DO435 !!$ 436 !!$DO ji = fs_niw0, fs_niw1 ! Vector opt.437 !!$DO jk = 1, jpkm1438 !!$DO jj = 1, jpj439 !!$vwbnd(jj,jk,nib ,nitm) = vwbnd(jj,jk,nib, nit)*vwmsk(jj,jk)440 !!$vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk)441 !!$vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk)442 !!$! ... fields nit <== now (kt+1)443 !!$vwbnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vwmsk(jj,jk)444 !!$vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk)445 !!$vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk)446 !!$END DO447 !!$END DO448 !!$END DO449 !!$IF( lk_mpp ) CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout )450 !!$ 451 !!$! ... extremeties niw0, niw1452 !!$ij = jpjwd +1 - njmpp453 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN454 !!$DO jk = 1,jpkm1455 !!$vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm)456 !!$END DO457 !!$END IF458 !!$ij = jpjwf +1 - njmpp459 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN460 !!$DO jk = 1,jpkm1461 !!$vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm)462 !!$END DO463 !!$END IF464 !!$465 !!$! 1.3 Temperature and salinity466 !!$! ----------------------------467 !!$468 !!$! ... advance in time (time filter, array swap)469 !!$DO jk = 1, jpkm1470 !!$DO jj = 1, jpj471 !!$! ... fields nitm <== nit plus time filter at the boundary472 !!$twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk)473 !!$swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk)474 !!$END DO475 !!$END DO476 !!$477 !!$DO ji = fs_niw0, fs_niw1 ! Vector opt.478 !!$DO jk = 1, jpkm1479 !!$DO jj = 1, jpj480 !!$twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk)481 !!$swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk)482 !!$! ... fields nit <== now (kt+1)483 !!$twbnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*twmsk(jj,jk)484 !!$twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk)485 !!$swbnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*twmsk(jj,jk)486 !!$swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk)487 !!$END DO488 !!$END DO489 !!$END DO490 !!$IF( lk_mpp ) CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout )491 !!$IF( lk_mpp ) CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout )492 !!$ 493 !!$! ... extremeties niw0, niw1494 !!$ij = jpjwd +1 - njmpp495 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN496 !!$DO jk = 1,jpkm1497 !!$twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm)498 !!$swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm)499 !!$END DO500 !!$END IF501 !!$ij = jpjwf +1 - njmpp502 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN503 !!$DO jk = 1,jpkm1504 !!$twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm)505 !!$swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm)506 !!$END DO507 !!$END IF508 !!$509 !!$END IF ! End of array swap510 !!$ 511 !!$! 2 - Calculation of radiation velocities512 !!$! ---------------------------------------513 !!$514 !!$IF( kt >= nit000 +3 .OR. ln_rstart ) THEN515 !!$516 !!$! 2.1 Calculate the normal velocity U based on phase velocity u_cxwbnd517 !!$! ----------------------------------------------------------------------518 !!$!519 !!$! nib nibm nibm2520 !!$! ///| nib | nibm |521 !!$! ///| | | | |522 !!$! ---f----v----f----v----f-- jj-line523 !!$! ///| | | | |524 !!$! ///| | |525 !!$! ///u T u T u jj-line526 !!$! ///| | |527 !!$! ///| | | | |528 !!$! jpiwob jpiwob+1 jpiwob+2529 !!$! | |530 !!$! jpiwob+1 jpiwob+2531 !!$!532 !!$! ... If free surface formulation:533 !!$! ... radiative conditions on the total part + relaxation toward climatology534 !!$! ... (jpjwdp1, jpjwfm1), jpiwob535 !!$DO ji = fs_niw0, fs_niw1 ! Vector opt.536 !!$DO jk = 1, jpkm1537 !!$DO jj = 2, jpjm1538 !!$! ... 2* gradi(u) (T-point i=nibm, time mean)539 !!$z2dx = ( - uwbnd(jj,jk,nibm ,nit) - uwbnd(jj,jk,nibm ,nitm2) &540 !!$+ 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj)541 !!$! ... 2* gradj(u) (u-point i=nibm, time nitm)542 !!$z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj)543 !!$! ... square of the norm of grad(u)544 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy545 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt546 !!$zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit)547 !!$! ... i-phase speed ratio (bounded by -1)548 !!$IF( z4nor2 == 0. ) THEN549 !!$z4nor2=0.00001550 !!$END IF551 !!$z05cx = zdt * z2dx / z4nor2552 !!$u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk)553 !!$END DO554 !!$END DO555 !!$END DO556 !!$ 557 !!$! 2.2 Calculate the tangential velocity based on phase velocity v_cxwbnd558 !!$! -----------------------------------------------------------------------559 !!$!560 !!$! nib nibm nibm2561 !!$! ///|///nib | nibm | nibm2562 !!$! ///|////| | | | | |563 !!$! ---v----f----v----f----v----f----v-- jj-line564 !!$! ///|////| | | | | |565 !!$! ///|////| | | | | |566 !!$! jpiwob jpiwob+1 jpiwob+2567 !!$! | | |568 !!$! jpiwob jpiwob+1 jpiwob+2569 !!$!570 !!$! ... radiative condition plus Raymond-Kuo571 !!$! ... (jpjwdp1, jpjwfm1),jpiwob572 !!$DO ji = fs_niw0, fs_niw1 ! Vector opt.573 !!$DO jk = 1, jpkm1574 !!$DO jj = 2, jpjm1575 !!$! ... 2* i-gradient of v (f-point i=nibm, time mean)576 !!$z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) &577 !!$+ 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj)578 !!$! ... 2* j-gradient of v (v-point i=nibm, time nitm)579 !!$z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj)580 !!$! ... square of the norm of grad(v)581 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy582 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt583 !!$zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit)584 !!$! ... i-phase speed ratio (bounded by -1) and save the unbounded phase585 !!$! velocity ratio no divided by e1f for the tracer radiation586 !!$IF( z4nor2 == 0) THEN587 !!$z4nor2=0.000001588 !!$endif589 !!$z05cx = zdt * z2dx / z4nor2590 !!$v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk)591 !!$END DO592 !!$END DO593 !!$END DO594 !!$IF( lk_mpp ) CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout )595 !!$ 596 !!$! ... extremeties niw0, niw1597 !!$ij = jpjwd +1 - njmpp598 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN599 !!$DO jk = 1,jpkm1600 !!$v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk)601 !!$END DO602 !!$END IF603 !!$ij = jpjwf +1 - njmpp604 !!$IF( ij >= 2 .AND. ij < jpjm1 ) THEN605 !!$DO jk = 1,jpkm1606 !!$v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk)607 !!$END DO608 !!$END IF609 !!$ 610 !!$END IF611 !!$ 612 !!$END SUBROUTINE obc_rad_west613 !!$ 614 !!$ 615 !!$SUBROUTINE obc_rad_north ( kt )616 !!$!!------------------------------------------------------------------------------617 !!$!! *** SUBROUTINE obc_rad_north ***618 !!$!!619 !!$!! ** Purpose :620 !!$!! Perform swap of arrays to calculate radiative phase speeds at the open621 !!$!! north boundary and calculate those phase speeds if this OBC is not fixed.622 !!$!! In case of fixed OBC, this subrountine is not called.623 !!$!!624 !!$!! History :625 !!$!! ! 95-03 (J.-M. Molines) Original from SPEM626 !!$!! ! 97-07 (G. Madec, J.-M. Molines) additions627 !!$!! ! 97-12 (M. Imbard) Mpp adaptation628 !!$!! ! 00-06 (J.-M. Molines)629 !!$!! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90630 !!$!!------------------------------------------------------------------------------631 !!$!! * Arguments632 !!$INTEGER, INTENT( in ) :: kt633 !!$ 634 !!$!! * Local declarations635 !!$INTEGER :: ii636 !!$REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy637 !!$REAL(wp) :: zvcb, zvcbm, zvcbm2638 !!$!!------------------------------------------------------------------------------639 !!$ 640 !!$! 1. Swap arrays before calculating radiative velocities641 !!$! ------------------------------------------------------642 !!$ 643 !!$! 1.1 zonal velocity644 !!$! -------------------645 !!$ 646 !!$IF( kt > nit000 .OR. ln_rstart ) THEN647 !!$ 648 !!$! ... advance in time (time filter, array swap)649 !!$DO jk = 1, jpkm1650 !!$DO ji = 1, jpi651 !!$! ... fields nitm2 <== nitm652 !!$unbnd(ji,jk,nib ,nitm2) = unbnd(ji,jk,nib ,nitm)*unmsk(ji,jk)653 !!$unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk)654 !!$unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk)655 !!$END DO656 !!$END DO657 !!$ 658 !!$DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.659 !!$DO jk = 1, jpkm1660 !!$DO ji = 1, jpi661 !!$unbnd(ji,jk,nib ,nitm) = unbnd(ji,jk,nib, nit)*unmsk(ji,jk)662 !!$unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk)663 !!$unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk)664 !!$! ... fields nit <== now (kt+1)665 !!$unbnd(ji,jk,nib ,nit) = un(ji,jj, jk)*unmsk(ji,jk)666 !!$unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk)667 !!$unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk)668 !!$END DO669 !!$END DO670 !!$END DO671 !!$IF( lk_mpp ) CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout )672 !!$ 673 !!$! ... extremeties njn0,njn1674 !!$ii = jpind + 1 - nimpp675 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN676 !!$DO jk = 1, jpkm1677 !!$unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm)678 !!$END DO679 !!$END IF680 !!$ii = jpinf + 1 - nimpp681 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN682 !!$DO jk = 1, jpkm1683 !!$unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm)684 !!$END DO685 !!$END IF686 !!$687 !!$! 1.2. normal velocity688 !!$! --------------------689 !!$ 690 !!$! ... advance in time (time filter, array swap)691 !!$DO jk = 1, jpkm1692 !!$DO ji = 1, jpi693 !!$! ... fields nitm2 <== nitm694 !!$vnbnd(ji,jk,nib ,nitm2) = vnbnd(ji,jk,nib ,nitm)*vnmsk(ji,jk)695 !!$vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk)696 !!$vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk)697 !!$END DO698 !!$END DO699 !!$ 700 !!$DO jj = fs_njn0, fs_njn1 ! Vector opt.701 !!$DO jk = 1, jpkm1702 !!$DO ji = 1, jpi703 !!$vnbnd(ji,jk,nib ,nitm) = vnbnd(ji,jk,nib, nit)*vnmsk(ji,jk)704 !!$vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk)705 !!$vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk)706 !!$! ... fields nit <== now (kt+1)707 !!$! ... total or baroclinic velocity at b, bm and bm2708 !!$zvcb = vn (ji,jj,jk)709 !!$zvcbm = vn (ji,jj-1,jk)710 !!$zvcbm2 = vn (ji,jj-2,jk)711 !!$! ... fields nit <== now (kt+1)712 !!$vnbnd(ji,jk,nib ,nit) = zvcb *vnmsk(ji,jk)713 !!$vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk)714 !!$vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk)715 !!$END DO716 !!$END DO717 !!$END DO718 !!$IF( lk_mpp ) CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout )719 !!$ 720 !!$! ... extremeties njn0,njn1721 !!$ii = jpind + 1 - nimpp722 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN723 !!$DO jk = 1, jpkm1724 !!$vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm)725 !!$END DO726 !!$END IF727 !!$ii = jpinf + 1 - nimpp728 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN729 !!$DO jk = 1, jpkm1730 !!$vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm)731 !!$END DO732 !!$END IF733 !!$ 734 !!$! 1.3 Temperature and salinity735 !!$! ----------------------------736 !!$ 737 !!$! ... advance in time (time filter, array swap)738 !!$DO jk = 1, jpkm1739 !!$DO ji = 1, jpi740 !!$! ... fields nitm <== nit plus time filter at the boundary741 !!$tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk)742 !!$snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk)743 !!$END DO744 !!$END DO745 !!$ 746 !!$DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.747 !!$DO jk = 1, jpkm1748 !!$DO ji = 1, jpi749 !!$tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk)750 !!$snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk)751 !!$! ... fields nit <== now (kt+1)752 !!$tnbnd(ji,jk,nib ,nit) = tn(ji,jj, jk)*tnmsk(ji,jk)753 !!$tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk)754 !!$snbnd(ji,jk,nib ,nit) = sn(ji,jj, jk)*tnmsk(ji,jk)755 !!$snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk)756 !!$END DO757 !!$END DO758 !!$END DO759 !!$IF( lk_mpp ) CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout )760 !!$IF( lk_mpp ) CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout )761 !!$ 762 !!$! ... extremeties njn0,njn1763 !!$ii = jpind + 1 - nimpp764 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN765 !!$DO jk = 1, jpkm1766 !!$tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm)767 !!$snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm)768 !!$END DO769 !!$END IF770 !!$ii = jpinf + 1 - nimpp771 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN772 !!$DO jk = 1, jpkm1773 !!$tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm)774 !!$snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm)775 !!$END DO776 !!$END IF777 !!$ 778 !!$END IF ! End of array swap779 !!$ 780 !!$! 2 - Calculation of radiation velocities781 !!$! ---------------------------------------782 !!$ 783 !!$IF( kt >= nit000 +3 .OR. ln_rstart ) THEN784 !!$ 785 !!$! 2.1 Calculate the normal velocity based on phase velocity u_cynbnd786 !!$! -------------------------------------------------------------------787 !!$!788 !!$! ji-row789 !!$! |790 !!$! nib -///u////// jpjnob + 1791 !!$! /////|//////792 !!$! nib -----f----- jpjnob793 !!$! |794 !!$! nibm-- u ---- jpjnob795 !!$! |796 !!$! nibm -----f----- jpjnob-1797 !!$! |798 !!$! nibm2-- u ---- jpjnob-1799 !!$! |800 !!$! nibm2 -----f----- jpjnob-2801 !!$! |802 !!$! ... radiative condition803 !!$! ... jpjnob+1,(jpindp1, jpinfm1)804 !!$DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.805 !!$DO jk = 1, jpkm1806 !!$DO ji = 2, jpim1807 !!$! ... 2* j-gradient of u (f-point i=nibm, time mean)808 !!$z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) &809 !!$- 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2)810 !!$! ... 2* i-gradient of u (u-point i=nibm, time nitm)811 !!$z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1)812 !!$! ... square of the norm of grad(v)813 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy814 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt815 !!$zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit)816 !!$! ... i-phase speed ratio (bounded by 1) and save the unbounded phase817 !!$! velocity ratio no divided by e1f for the tracer radiation818 !!$IF( z4nor2 == 0.) THEN819 !!$z4nor2=.000001820 !!$END IF821 !!$z05cx = zdt * z2dx / z4nor2822 !!$u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk)823 !!$END DO824 !!$END DO825 !!$END DO826 !!$IF( lk_mpp ) CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout )827 !!$ 828 !!$! ... extremeties njn0,njn1829 !!$ii = jpind + 1 - nimpp830 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN831 !!$DO jk = 1, jpkm1832 !!$u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk)833 !!$END DO834 !!$END IF835 !!$ii = jpinf + 1 - nimpp836 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN837 !!$DO jk = 1, jpkm1838 !!$u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk)839 !!$END DO840 !!$END IF841 !!$ 842 !!$! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd843 !!$! ------------------------------------------------------------------844 !!$!845 !!$! ji-row ji-row846 !!$! |847 !!$! /////|/////////////////848 !!$! nib -----f----v----f---- jpjnob849 !!$! | |850 !!$! nib - u -- T -- u ---- jpjnob851 !!$! | |852 !!$! nibm -----f----v----f---- jpjnob-1853 !!$! | |854 !!$! nibm -- u -- T -- u --- jpjnob-1855 !!$! | |856 !!$! nibm2 -----f----v----f---- jpjnob-2857 !!$! | |858 !!$! ... Free surface formulation:859 !!$! ... radiative conditions on the total part + relaxation toward climatology860 !!$! ... jpjnob,(jpindp1, jpinfm1)861 !!$DO jj = fs_njn0, fs_njn1 ! Vector opt.862 !!$DO jk = 1, jpkm1863 !!$DO ji = 2, jpim1864 !!$! ... 2* gradj(v) (T-point i=nibm, time mean)865 !!$ii = ji -1 + nimpp866 !!$z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) &867 !!$- 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1)868 !!$! ... 2* gradi(v) (v-point i=nibm, time nitm)869 !!$z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1)870 !!$! ... square of the norm of grad(u)871 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy872 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt873 !!$zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit)874 !!$! ... j-phase speed ratio (bounded by 1)875 !!$IF( z4nor2 == 0. ) THEN876 !!$z4nor2=.00001877 !!$END IF878 !!$z05cx = zdt * z2dx / z4nor2879 !!$v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk)880 !!$END DO881 !!$END DO882 !!$END DO883 !!$ 884 !!$END IF885 !!$ 886 !!$END SUBROUTINE obc_rad_north887 !!$ 888 !!$ 889 !!$SUBROUTINE obc_rad_south ( kt )890 !!$!!------------------------------------------------------------------------------891 !!$!! *** SUBROUTINE obc_rad_south ***892 !!$!!893 !!$!! ** Purpose :894 !!$!! Perform swap of arrays to calculate radiative phase speeds at the open895 !!$!! south boundary and calculate those phase speeds if this OBC is not fixed.896 !!$!! In case of fixed OBC, this subrountine is not called.897 !!$!!898 !!$!! History :899 !!$!! ! 95-03 (J.-M. Molines) Original from SPEM900 !!$!! ! 97-07 (G. Madec, J.-M. Molines) additions901 !!$!! ! 97-12 (M. Imbard) Mpp adaptation902 !!$!! ! 00-06 (J.-M. Molines)903 !!$!! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90904 !!$!!------------------------------------------------------------------------------905 !!$!! * Arguments906 !!$INTEGER, INTENT( in ) :: kt907 !!$ 908 !!$!! * Local declarations909 !!$INTEGER :: ii910 !!$REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy911 !!$REAL(wp) :: zvcb, zvcbm, zvcbm2912 !!$!!------------------------------------------------------------------------------913 !!$ 914 !!$! 1. Swap arrays before calculating radiative velocities915 !!$! ------------------------------------------------------916 !!$ 917 !!$! 1.1 zonal velocity918 !!$! --------------------919 !!$920 !!$IF( kt > nit000 .OR. ln_rstart ) THEN921 !!$ 922 !!$! ... advance in time (time filter, array swap)923 !!$DO jk = 1, jpkm1924 !!$DO ji = 1, jpi925 !!$! ... fields nitm2 <== nitm926 !!$usbnd(ji,jk,nib ,nitm2) = usbnd(ji,jk,nib ,nitm)*usmsk(ji,jk)927 !!$usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk)928 !!$usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk)929 !!$END DO930 !!$END DO931 !!$932 !!$DO jj = fs_njs0, fs_njs1 ! Vector opt.933 !!$DO jk = 1, jpkm1934 !!$DO ji = 1, jpi935 !!$usbnd(ji,jk,nib ,nitm) = usbnd(ji,jk,nib, nit)*usmsk(ji,jk)936 !!$usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk)937 !!$usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk)938 !!$! ... fields nit <== now (kt+1)939 !!$usbnd(ji,jk,nib ,nit) = un(ji,jj ,jk)*usmsk(ji,jk)940 !!$usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk)941 !!$usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk)942 !!$END DO943 !!$END DO944 !!$END DO945 !!$IF( lk_mpp ) CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout )946 !!$ 947 !!$! ... extremeties njs0,njs1948 !!$ii = jpisd + 1 - nimpp949 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN950 !!$DO jk = 1, jpkm1951 !!$usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm)952 !!$END DO953 !!$END IF954 !!$ii = jpisf + 1 - nimpp955 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN956 !!$DO jk = 1, jpkm1957 !!$usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm)958 !!$END DO959 !!$END IF960 !!$961 !!$! 1.2 normal velocity962 !!$! -------------------963 !!$964 !!$!.. advance in time (time filter, array swap)965 !!$DO jk = 1, jpkm1966 !!$DO ji = 1, jpi967 !!$! ... fields nitm2 <== nitm968 !!$vsbnd(ji,jk,nib ,nitm2) = vsbnd(ji,jk,nib ,nitm)*vsmsk(ji,jk)969 !!$vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk)970 !!$END DO971 !!$END DO972 !!$ 973 !!$DO jj = fs_njs0, fs_njs1 ! Vector opt.974 !!$DO jk = 1, jpkm1975 !!$DO ji = 1, jpi976 !!$vsbnd(ji,jk,nib ,nitm) = vsbnd(ji,jk,nib, nit)*vsmsk(ji,jk)977 !!$vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk)978 !!$vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk)979 !!$! ... total or baroclinic velocity at b, bm and bm2980 !!$zvcb = vn (ji,jj,jk)981 !!$zvcbm = vn (ji,jj+1,jk)982 !!$zvcbm2 = vn (ji,jj+2,jk)983 !!$! ... fields nit <== now (kt+1)984 !!$vsbnd(ji,jk,nib ,nit) = zvcb *vsmsk(ji,jk)985 !!$vsbnd(ji,jk,nibm ,nit) = zvcbm *vsmsk(ji,jk)986 !!$vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk)987 !!$END DO988 !!$END DO989 !!$END DO990 !!$IF( lk_mpp ) CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout )991 !!$ 992 !!$! ... extremeties njs0,njs1993 !!$ii = jpisd + 1 - nimpp994 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN995 !!$DO jk = 1, jpkm1996 !!$vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm)997 !!$END DO998 !!$END IF999 !!$ii = jpisf + 1 - nimpp1000 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN1001 !!$DO jk = 1, jpkm11002 !!$vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm)1003 !!$END DO1004 !!$END IF1005 !!$ 1006 !!$! 1.3 Temperature and salinity1007 !!$! ----------------------------1008 !!$ 1009 !!$! ... advance in time (time filter, array swap)1010 !!$DO jk = 1, jpkm11011 !!$DO ji = 1, jpi1012 !!$! ... fields nitm <== nit plus time filter at the boundary1013 !!$tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk)1014 !!$ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk)1015 !!$END DO1016 !!$END DO1017 !!$ 1018 !!$DO jj = fs_njs0, fs_njs1 ! Vector opt.1019 !!$DO jk = 1, jpkm11020 !!$DO ji = 1, jpi1021 !!$tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk)1022 !!$ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk)1023 !!$! ... fields nit <== now (kt+1)1024 !!$tsbnd(ji,jk,nib ,nit) = tn(ji,jj ,jk)*tsmsk(ji,jk)1025 !!$tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk)1026 !!$ssbnd(ji,jk,nib ,nit) = sn(ji,jj ,jk)*tsmsk(ji,jk)1027 !!$ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk)1028 !!$END DO1029 !!$END DO1030 !!$END DO1031 !!$IF( lk_mpp ) CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout )1032 !!$IF( lk_mpp ) CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout )1033 !!$ 1034 !!$! ... extremeties njs0,njs11035 !!$ii = jpisd + 1 - nimpp1036 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN1037 !!$DO jk = 1, jpkm11038 !!$tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm)1039 !!$ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm)1040 !!$END DO1041 !!$END IF1042 !!$ii = jpisf + 1 - nimpp1043 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN1044 !!$DO jk = 1, jpkm11045 !!$tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm)1046 !!$ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm)1047 !!$END DO1048 !!$END IF1049 !!$ 1050 !!$END IF ! End of array swap1051 !!$ 1052 !!$! 2 - Calculation of radiation velocities1053 !!$! ---------------------------------------1054 !!$ 1055 !!$IF( kt >= nit000 +3 .OR. ln_rstart ) THEN1056 !!$ 1057 !!$! 2.1 Calculate the normal velocity based on phase velocity u_cysbnd1058 !!$! -------------------------------------------------------------------1059 !!$!1060 !!$! ji-row1061 !!$! |1062 !!$! nibm2 -----f----- jpjsob +21063 !!$! |1064 !!$! nibm2 -- u ----- jpjsob +21065 !!$! |1066 !!$! nibm -----f----- jpjsob +11067 !!$! |1068 !!$! nibm -- u ----- jpjsob +11069 !!$! |1070 !!$! nib -----f----- jpjsob1071 !!$! /////|//////1072 !!$! nib ////u///// jpjsob1073 !!$!1074 !!$! ... radiative condition plus Raymond-Kuo1075 !!$! ... jpjsob,(jpisdp1, jpisfm1)1076 !!$DO jj = fs_njs0, fs_njs1 ! Vector opt.1077 !!$DO jk = 1, jpkm11078 !!$DO ji = 2, jpim11079 !!$! ... 2* j-gradient of u (f-point i=nibm, time mean)1080 !!$z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) &1081 !!$+ 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1)1082 !!$! ... 2* i-gradient of u (u-point i=nibm, time nitm)1083 !!$z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1)1084 !!$! ... square of the norm of grad(v)1085 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy1086 !!$IF( z4nor2 == 0.) THEN1087 !!$z4nor2 = 0.0000011088 !!$END IF1089 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt1090 !!$zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit)1091 !!$! ... i-phase speed ratio (bounded by -1) and save the unbounded phase1092 !!$! velocity ratio no divided by e1f for the tracer radiation1093 !!$z05cx = zdt * z2dx / z4nor21094 !!$u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk)1095 !!$END DO1096 !!$END DO1097 !!$END DO1098 !!$IF( lk_mpp ) CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout )1099 !!$ 1100 !!$! ... extremeties njs0,njs11101 !!$ii = jpisd + 1 - nimpp1102 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN1103 !!$DO jk = 1, jpkm11104 !!$u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk)1105 !!$END DO1106 !!$END IF1107 !!$ii = jpisf + 1 - nimpp1108 !!$IF( ii >= 2 .AND. ii < jpim1 ) THEN1109 !!$DO jk = 1, jpkm11110 !!$u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk)1111 !!$END DO1112 !!$END IF1113 !!$ 1114 !!$! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd1115 !!$! -------------------------------------------------------------------1116 !!$!1117 !!$! ji-row ji-row1118 !!$! | |1119 !!$! nibm2 -----f----v----f---- jpjsob+21120 !!$! | |1121 !!$! nibm - u -- T -- u ---- jpjsob+21122 !!$! | |1123 !!$! nibm -----f----v----f---- jpjsob+11124 !!$! | |1125 !!$! nib -- u -- T -- u --- jpjsob+11126 !!$! | |1127 !!$! nib -----f----v----f---- jpjsob1128 !!$! /////////////////////1129 !!$!1130 !!$! ... Free surface formulation:1131 !!$! ... radiative conditions on the total part + relaxation toward climatology1132 !!$! ... jpjsob,(jpisdp1,jpisfm1)1133 !!$DO jj = fs_njs0, fs_njs1 ! Vector opt.1134 !!$DO jk = 1, jpkm11135 !!$DO ji = 2, jpim11136 !!$! ... 2* gradj(v) (T-point i=nibm, time mean)1137 !!$z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) &1138 !!$+ 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1)1139 !!$! ... 2* gradi(v) (v-point i=nibm, time nitm)1140 !!$z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1)1141 !!$! ... square of the norm of grad(u)1142 !!$z4nor2 = z2dx * z2dx + z2dy * z2dy1143 !!$IF( z4nor2 == 0.) THEN1144 !!$z4nor2 = 0.0000011145 !!$END IF1146 !!$! ... minus time derivative (leap-frog) at nibm, without / 2 dt1147 !!$zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit)1148 !!$! ... j-phase speed ratio (bounded by -1)1149 !!$z05cx = zdt * z2dx / z4nor21150 !!$v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk)1151 !!$END DO1152 !!$END DO1153 !!$END DO1154 !!$ 1155 !!$ENDIF1156 !!$1157 !!$END SUBROUTINE obc_rad_south1158 !!$ 1159 !!$#else7 !!--------------------------------------------------------------------------------- 8 !! obc_rad : call the subroutine for each open boundary 9 !! obc_rad_east : compute the east phase velocities 10 !! obc_rad_west : compute the west phase velocities 11 !! obc_rad_north : compute the north phase velocities 12 !! obc_rad_south : compute the south phase velocities 13 !!--------------------------------------------------------------------------------- 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 16 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 17 USE phycst ! physical constants 18 USE obc_oce ! ocean open boundary conditions 19 USE lib_mpp ! for mppobc 20 USE in_out_manager ! I/O units 21 22 IMPLICIT NONE 23 PRIVATE 24 25 PUBLIC obc_rad ! routine called by step.F90 26 27 INTEGER :: ji, jj, jk ! dummy loop indices 28 29 INTEGER :: & ! ... boundary space indices 30 nib = 1, & ! nib = boundary point 31 nibm = 2, & ! nibm = 1st interior point 32 nibm2 = 3, & ! nibm2 = 2nd interior point 33 ! ... boundary time indices 34 nit = 1, & ! nit = now 35 nitm = 2, & ! nitm = before 36 nitm2 = 3 ! nitm2 = before-before 37 38 !! * Substitutions 39 # include "obc_vectopt_loop_substitute.h90" 40 !!--------------------------------------------------------------------------------- 41 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 42 !! $Id$ 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 44 !!--------------------------------------------------------------------------------- 45 46 CONTAINS 47 48 SUBROUTINE obc_rad ( kt ) 49 !!------------------------------------------------------------------------------ 50 !! SUBROUTINE obc_rad 51 !! ******************** 52 !! ** Purpose : 53 !! Perform swap of arrays to calculate radiative phase speeds at the open 54 !! boundaries and calculate those phase speeds if the open boundaries are 55 !! not fixed. In case of fixed open boundaries does nothing. 56 !! 57 !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 58 !! and/or lp_obc_south allow the user to determine which boundary is an 59 !! open one (must be done in the param_obc.h90 file). 60 !! 61 !! ** Reference : 62 !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 63 !! 64 !! History : 65 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 from the 66 !! J. Molines and G. Madec version 67 !!------------------------------------------------------------------------------ 68 INTEGER, INTENT( in ) :: kt 69 !!---------------------------------------------------------------------- 70 71 IF( lp_obc_east .AND. .NOT.lfbceast ) CALL obc_rad_east ( kt ) ! East open boundary 72 73 IF( lp_obc_west .AND. .NOT.lfbcwest ) CALL obc_rad_west ( kt ) ! West open boundary 74 75 IF( lp_obc_north .AND. .NOT.lfbcnorth ) CALL obc_rad_north( kt ) ! North open boundary 76 77 IF( lp_obc_south .AND. .NOT.lfbcsouth ) CALL obc_rad_south( kt ) ! South open boundary 78 79 END SUBROUTINE obc_rad 80 81 82 SUBROUTINE obc_rad_east ( kt ) 83 !!------------------------------------------------------------------------------ 84 !! *** SUBROUTINE obc_rad_east *** 85 !! 86 !! ** Purpose : 87 !! Perform swap of arrays to calculate radiative phase speeds at the open 88 !! east boundary and calculate those phase speeds if this OBC is not fixed. 89 !! In case of fixed OBC, this subrountine is not called. 90 !! 91 !! History : 92 !! ! 95-03 (J.-M. Molines) Original from SPEM 93 !! ! 97-07 (G. Madec, J.-M. Molines) additions 94 !! ! 97-12 (M. Imbard) Mpp adaptation 95 !! ! 00-06 (J.-M. Molines) 96 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 97 !!------------------------------------------------------------------------------ 98 !! * Arguments 99 INTEGER, INTENT( in ) :: kt 100 101 !! * Local declarations 102 INTEGER :: ij 103 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 104 REAL(wp) :: zucb, zucbm, zucbm2 105 !!------------------------------------------------------------------------------ 106 107 ! 1. Swap arrays before calculating radiative velocities 108 ! ------------------------------------------------------ 109 110 ! 1.1 zonal velocity 111 ! ------------------- 112 113 IF( kt > nit000 .OR. ln_rstart ) THEN 114 115 ! ... advance in time (time filter, array swap) 116 DO jk = 1, jpkm1 117 DO jj = 1, jpj 118 uebnd(jj,jk,nib ,nitm2) = uebnd(jj,jk,nib ,nitm)*uemsk(jj,jk) 119 uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk) 120 uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk) 121 END DO 122 END DO 123 ! ... fields nitm <== nit plus time filter at the boundary 124 DO ji = fs_nie0, fs_nie1 ! Vector opt. 125 DO jk = 1, jpkm1 126 DO jj = 1, jpj 127 uebnd(jj,jk,nib ,nitm) = uebnd(jj,jk,nib, nit)*uemsk(jj,jk) 128 uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk) 129 uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk) 130 ! ... fields nit <== now (kt+1) 131 ! ... Total or baroclinic velocity at b, bm and bm2 132 zucb = un(ji,jj,jk) 133 zucbm = un(ji-1,jj,jk) 134 zucbm2 = un(ji-2,jj,jk) 135 uebnd(jj,jk,nib ,nit) = zucb *uemsk(jj,jk) 136 uebnd(jj,jk,nibm ,nit) = zucbm *uemsk(jj,jk) 137 uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk) 138 END DO 139 END DO 140 END DO 141 IF( lk_mpp ) CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout ) 142 143 ! ... extremeties nie0, nie1 144 ij = jpjed +1 - njmpp 145 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 146 DO jk = 1,jpkm1 147 uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm) 148 END DO 149 END IF 150 ij = jpjef +1 - njmpp 151 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 152 DO jk = 1,jpkm1 153 uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm) 154 END DO 155 END IF 156 157 ! 1.2 tangential velocity 158 ! ----------------------- 159 160 ! ... advance in time (time filter, array swap) 161 DO jk = 1, jpkm1 162 DO jj = 1, jpj 163 ! ... fields nitm2 <== nitm 164 vebnd(jj,jk,nib ,nitm2) = vebnd(jj,jk,nib ,nitm)*vemsk(jj,jk) 165 vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk) 166 vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk) 167 END DO 168 END DO 169 170 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 171 DO jk = 1, jpkm1 172 DO jj = 1, jpj 173 vebnd(jj,jk,nib ,nitm) = vebnd(jj,jk,nib, nit)*vemsk(jj,jk) 174 vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk) 175 vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk) 176 ! ... fields nit <== now (kt+1) 177 vebnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vemsk(jj,jk) 178 vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk) 179 vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk) 180 END DO 181 END DO 182 END DO 183 IF( lk_mpp ) CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout ) 184 185 !... extremeties nie0, nie1 186 ij = jpjed +1 - njmpp 187 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 188 DO jk = 1,jpkm1 189 vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm) 190 END DO 191 END IF 192 ij = jpjef +1 - njmpp 193 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 194 DO jk = 1,jpkm1 195 vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm) 196 END DO 197 END IF 198 199 ! 1.3 Temperature and salinity 200 ! ---------------------------- 201 202 ! ... advance in time (time filter, array swap) 203 DO jk = 1, jpkm1 204 DO jj = 1, jpj 205 ! ... fields nitm <== nit plus time filter at the boundary 206 tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk) 207 sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk) 208 END DO 209 END DO 210 211 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 212 DO jk = 1, jpkm1 213 DO jj = 1, jpj 214 tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk) 215 sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk) 216 ! ... fields nit <== now (kt+1) 217 tebnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*temsk(jj,jk) 218 tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk) 219 sebnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*temsk(jj,jk) 220 sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk) 221 END DO 222 END DO 223 END DO 224 IF( lk_mpp ) CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 225 IF( lk_mpp ) CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 226 227 ! ... extremeties nie0, nie1 228 ij = jpjed +1 - njmpp 229 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 230 DO jk = 1,jpkm1 231 tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm) 232 sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm) 233 END DO 234 END IF 235 ij = jpjef +1 - njmpp 236 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 237 DO jk = 1,jpkm1 238 tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm) 239 sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm) 240 END DO 241 END IF 242 243 END IF ! End of array swap 244 245 ! 2 - Calculation of radiation velocities 246 ! --------------------------------------- 247 248 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 249 250 ! 2.1 Calculate the normal velocity U based on phase velocity u_cxebnd 251 ! --------------------------------------------------------------------- 252 ! 253 ! nibm2 nibm nib 254 ! | nibm | nib |/// 255 ! | | | | |/// 256 ! jj-line --f----v----f----v----f--- 257 ! | | | | |/// 258 ! | | |/// 259 ! jj-line u T u T u/// 260 ! | | |/// 261 ! | | | | |/// 262 ! jpieob-2 jpieob-1 jpieob 263 ! | | 264 ! jpieob-1 jpieob 265 ! 266 ! ... (jpjedp1, jpjefm1),jpieob 267 DO ji = fs_nie0, fs_nie1 ! Vector opt. 268 DO jk = 1, jpkm1 269 DO jj = 2, jpjm1 270 ! ... 2* gradi(u) (T-point i=nibm, time mean) 271 z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) & 272 - 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj) 273 ! ... 2* gradj(u) (u-point i=nibm, time nitm) 274 z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj) 275 ! ... square of the norm of grad(u) 276 z4nor2 = z2dx * z2dx + z2dy * z2dy 277 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 278 zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit) 279 ! ... i-phase speed ratio (bounded by 1) 280 IF( z4nor2 == 0. ) THEN 281 z4nor2=.00001 282 END IF 283 z05cx = zdt * z2dx / z4nor2 284 u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk) 285 END DO 286 END DO 287 END DO 288 289 ! 2.2 Calculate the tangential velocity based on phase velocity v_cxebnd 290 ! ----------------------------------------------------------------------- 291 ! 292 ! nibm2 nibm nib 293 ! | nibm | nib///|/// 294 ! | | | |////|/// 295 ! jj-line --v----f----v----f----v--- 296 ! | | | |////|/// 297 ! | | | |////|/// 298 ! | jpieob-1| jpieob /|/// 299 ! | | | 300 ! jpieob-1 jpieob jpieob+1 301 ! 302 ! ... (jpjedp1, jpjefm1), jpieob+1 303 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 304 DO jk = 1, jpkm1 305 DO jj = 2, jpjm1 306 ! ... 2* i-gradient of v (f-point i=nibm, time mean) 307 z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) & 308 - 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj) 309 ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 310 z2dy = ( vebnd(jj+1,jk,nibm,nitm) - vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj) 311 ! ... square of the norm of grad(v) 312 z4nor2 = z2dx * z2dx + z2dy * z2dy 313 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 314 zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit) 315 ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 316 ! velocity ratio no divided by e1f for the tracer radiation 317 IF( z4nor2 == 0. ) THEN 318 z4nor2=.000001 319 END IF 320 z05cx = zdt * z2dx / z4nor2 321 v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk) 322 END DO 323 END DO 324 END DO 325 IF( lk_mpp ) CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout ) 326 327 ! ... extremeties nie0, nie1 328 ij = jpjed +1 - njmpp 329 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 330 DO jk = 1,jpkm1 331 v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk) 332 END DO 333 END IF 334 ij = jpjef +1 - njmpp 335 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 336 DO jk = 1,jpkm1 337 v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk) 338 END DO 339 END IF 340 341 END IF 342 343 END SUBROUTINE obc_rad_east 344 345 346 SUBROUTINE obc_rad_west ( kt ) 347 !!------------------------------------------------------------------------------ 348 !! *** SUBROUTINE obc_rad_west *** 349 !! 350 !! ** Purpose : 351 !! Perform swap of arrays to calculate radiative phase speeds at the open 352 !! west boundary and calculate those phase speeds if this OBC is not fixed. 353 !! In case of fixed OBC, this subrountine is not called. 354 !! 355 !! History : 356 !! ! 95-03 (J.-M. Molines) Original from SPEM 357 !! ! 97-07 (G. Madec, J.-M. Molines) additions 358 !! ! 97-12 (M. Imbard) Mpp adaptation 359 !! ! 00-06 (J.-M. Molines) 360 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 361 !!------------------------------------------------------------------------------ 362 !! * Arguments 363 INTEGER, INTENT( in ) :: kt 364 365 !! * Local declarations 366 INTEGER :: ij 367 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 368 REAL(wp) :: zucb, zucbm, zucbm2 369 !!------------------------------------------------------------------------------ 370 371 ! 1. Swap arrays before calculating radiative velocities 372 ! ------------------------------------------------------ 373 374 ! 1.1 zonal velocity 375 ! ------------------- 376 377 IF( kt > nit000 .OR. ln_rstart ) THEN 378 379 ! ... advance in time (time filter, array swap) 380 DO jk = 1, jpkm1 381 DO jj = 1, jpj 382 uwbnd(jj,jk,nib ,nitm2) = uwbnd(jj,jk,nib ,nitm)*uwmsk(jj,jk) 383 uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk) 384 uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk) 385 END DO 386 END DO 387 388 ! ... fields nitm <== nit plus time filter at the boundary 389 DO ji = fs_niw0, fs_niw1 ! Vector opt. 390 DO jk = 1, jpkm1 391 DO jj = 1, jpj 392 uwbnd(jj,jk,nib ,nitm) = uwbnd(jj,jk,nib ,nit)*uwmsk(jj,jk) 393 uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk) 394 uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk) 395 ! ... total or baroclinic velocity at b, bm and bm2 396 zucb = un (ji,jj,jk) 397 zucbm = un (ji+1,jj,jk) 398 zucbm2 = un (ji+2,jj,jk) 399 400 ! ... fields nit <== now (kt+1) 401 uwbnd(jj,jk,nib ,nit) = zucb *uwmsk(jj,jk) 402 uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk) 403 uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk) 404 END DO 405 END DO 406 END DO 407 IF( lk_mpp ) CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 408 409 ! ... extremeties niw0, niw1 410 ij = jpjwd +1 - njmpp 411 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 412 DO jk = 1,jpkm1 413 uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm) 414 END DO 415 END IF 416 ij = jpjwf +1 - njmpp 417 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 418 DO jk = 1,jpkm1 419 uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm) 420 END DO 421 END IF 422 423 ! 1.2 tangential velocity 424 ! ----------------------- 425 426 ! ... advance in time (time filter, array swap) 427 DO jk = 1, jpkm1 428 DO jj = 1, jpj 429 ! ... fields nitm2 <== nitm 430 vwbnd(jj,jk,nib ,nitm2) = vwbnd(jj,jk,nib ,nitm)*vwmsk(jj,jk) 431 vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk) 432 vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk) 433 END DO 434 END DO 435 436 DO ji = fs_niw0, fs_niw1 ! Vector opt. 437 DO jk = 1, jpkm1 438 DO jj = 1, jpj 439 vwbnd(jj,jk,nib ,nitm) = vwbnd(jj,jk,nib, nit)*vwmsk(jj,jk) 440 vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk) 441 vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk) 442 ! ... fields nit <== now (kt+1) 443 vwbnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vwmsk(jj,jk) 444 vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk) 445 vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk) 446 END DO 447 END DO 448 END DO 449 IF( lk_mpp ) CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 450 451 ! ... extremeties niw0, niw1 452 ij = jpjwd +1 - njmpp 453 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 454 DO jk = 1,jpkm1 455 vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm) 456 END DO 457 END IF 458 ij = jpjwf +1 - njmpp 459 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 460 DO jk = 1,jpkm1 461 vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm) 462 END DO 463 END IF 464 465 ! 1.3 Temperature and salinity 466 ! ---------------------------- 467 468 ! ... advance in time (time filter, array swap) 469 DO jk = 1, jpkm1 470 DO jj = 1, jpj 471 ! ... fields nitm <== nit plus time filter at the boundary 472 twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk) 473 swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk) 474 END DO 475 END DO 476 477 DO ji = fs_niw0, fs_niw1 ! Vector opt. 478 DO jk = 1, jpkm1 479 DO jj = 1, jpj 480 twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 481 swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 482 ! ... fields nit <== now (kt+1) 483 twbnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*twmsk(jj,jk) 484 twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk) 485 swbnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*twmsk(jj,jk) 486 swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk) 487 END DO 488 END DO 489 END DO 490 IF( lk_mpp ) CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 491 IF( lk_mpp ) CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 492 493 ! ... extremeties niw0, niw1 494 ij = jpjwd +1 - njmpp 495 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 496 DO jk = 1,jpkm1 497 twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm) 498 swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm) 499 END DO 500 END IF 501 ij = jpjwf +1 - njmpp 502 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 503 DO jk = 1,jpkm1 504 twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm) 505 swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm) 506 END DO 507 END IF 508 509 END IF ! End of array swap 510 511 ! 2 - Calculation of radiation velocities 512 ! --------------------------------------- 513 514 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 515 516 ! 2.1 Calculate the normal velocity U based on phase velocity u_cxwbnd 517 ! ---------------------------------------------------------------------- 518 ! 519 ! nib nibm nibm2 520 ! ///| nib | nibm | 521 ! ///| | | | | 522 ! ---f----v----f----v----f-- jj-line 523 ! ///| | | | | 524 ! ///| | | 525 ! ///u T u T u jj-line 526 ! ///| | | 527 ! ///| | | | | 528 ! jpiwob jpiwob+1 jpiwob+2 529 ! | | 530 ! jpiwob+1 jpiwob+2 531 ! 532 ! ... If free surface formulation: 533 ! ... radiative conditions on the total part + relaxation toward climatology 534 ! ... (jpjwdp1, jpjwfm1), jpiwob 535 DO ji = fs_niw0, fs_niw1 ! Vector opt. 536 DO jk = 1, jpkm1 537 DO jj = 2, jpjm1 538 ! ... 2* gradi(u) (T-point i=nibm, time mean) 539 z2dx = ( - uwbnd(jj,jk,nibm ,nit) - uwbnd(jj,jk,nibm ,nitm2) & 540 + 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj) 541 ! ... 2* gradj(u) (u-point i=nibm, time nitm) 542 z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj) 543 ! ... square of the norm of grad(u) 544 z4nor2 = z2dx * z2dx + z2dy * z2dy 545 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 546 zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit) 547 ! ... i-phase speed ratio (bounded by -1) 548 IF( z4nor2 == 0. ) THEN 549 z4nor2=0.00001 550 END IF 551 z05cx = zdt * z2dx / z4nor2 552 u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk) 553 END DO 554 END DO 555 END DO 556 557 ! 2.2 Calculate the tangential velocity based on phase velocity v_cxwbnd 558 ! ----------------------------------------------------------------------- 559 ! 560 ! nib nibm nibm2 561 ! ///|///nib | nibm | nibm2 562 ! ///|////| | | | | | 563 ! ---v----f----v----f----v----f----v-- jj-line 564 ! ///|////| | | | | | 565 ! ///|////| | | | | | 566 ! jpiwob jpiwob+1 jpiwob+2 567 ! | | | 568 ! jpiwob jpiwob+1 jpiwob+2 569 ! 570 ! ... radiative condition plus Raymond-Kuo 571 ! ... (jpjwdp1, jpjwfm1),jpiwob 572 DO ji = fs_niw0, fs_niw1 ! Vector opt. 573 DO jk = 1, jpkm1 574 DO jj = 2, jpjm1 575 ! ... 2* i-gradient of v (f-point i=nibm, time mean) 576 z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) & 577 + 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj) 578 ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 579 z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj) 580 ! ... square of the norm of grad(v) 581 z4nor2 = z2dx * z2dx + z2dy * z2dy 582 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 583 zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit) 584 ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 585 ! velocity ratio no divided by e1f for the tracer radiation 586 IF( z4nor2 == 0) THEN 587 z4nor2=0.000001 588 endif 589 z05cx = zdt * z2dx / z4nor2 590 v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk) 591 END DO 592 END DO 593 END DO 594 IF( lk_mpp ) CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout ) 595 596 ! ... extremeties niw0, niw1 597 ij = jpjwd +1 - njmpp 598 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 599 DO jk = 1,jpkm1 600 v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk) 601 END DO 602 END IF 603 ij = jpjwf +1 - njmpp 604 IF( ij >= 2 .AND. ij < jpjm1 ) THEN 605 DO jk = 1,jpkm1 606 v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk) 607 END DO 608 END IF 609 610 END IF 611 612 END SUBROUTINE obc_rad_west 613 614 615 SUBROUTINE obc_rad_north ( kt ) 616 !!------------------------------------------------------------------------------ 617 !! *** SUBROUTINE obc_rad_north *** 618 !! 619 !! ** Purpose : 620 !! Perform swap of arrays to calculate radiative phase speeds at the open 621 !! north boundary and calculate those phase speeds if this OBC is not fixed. 622 !! In case of fixed OBC, this subrountine is not called. 623 !! 624 !! History : 625 !! ! 95-03 (J.-M. Molines) Original from SPEM 626 !! ! 97-07 (G. Madec, J.-M. Molines) additions 627 !! ! 97-12 (M. Imbard) Mpp adaptation 628 !! ! 00-06 (J.-M. Molines) 629 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 630 !!------------------------------------------------------------------------------ 631 !! * Arguments 632 INTEGER, INTENT( in ) :: kt 633 634 !! * Local declarations 635 INTEGER :: ii 636 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 637 REAL(wp) :: zvcb, zvcbm, zvcbm2 638 !!------------------------------------------------------------------------------ 639 640 ! 1. Swap arrays before calculating radiative velocities 641 ! ------------------------------------------------------ 642 643 ! 1.1 zonal velocity 644 ! ------------------- 645 646 IF( kt > nit000 .OR. ln_rstart ) THEN 647 648 ! ... advance in time (time filter, array swap) 649 DO jk = 1, jpkm1 650 DO ji = 1, jpi 651 ! ... fields nitm2 <== nitm 652 unbnd(ji,jk,nib ,nitm2) = unbnd(ji,jk,nib ,nitm)*unmsk(ji,jk) 653 unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk) 654 unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk) 655 END DO 656 END DO 657 658 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 659 DO jk = 1, jpkm1 660 DO ji = 1, jpi 661 unbnd(ji,jk,nib ,nitm) = unbnd(ji,jk,nib, nit)*unmsk(ji,jk) 662 unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk) 663 unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk) 664 ! ... fields nit <== now (kt+1) 665 unbnd(ji,jk,nib ,nit) = un(ji,jj, jk)*unmsk(ji,jk) 666 unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk) 667 unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk) 668 END DO 669 END DO 670 END DO 671 IF( lk_mpp ) CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout ) 672 673 ! ... extremeties njn0,njn1 674 ii = jpind + 1 - nimpp 675 IF( ii >= 2 .AND. ii < jpim1 ) THEN 676 DO jk = 1, jpkm1 677 unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm) 678 END DO 679 END IF 680 ii = jpinf + 1 - nimpp 681 IF( ii >= 2 .AND. ii < jpim1 ) THEN 682 DO jk = 1, jpkm1 683 unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm) 684 END DO 685 END IF 686 687 ! 1.2. normal velocity 688 ! -------------------- 689 690 ! ... advance in time (time filter, array swap) 691 DO jk = 1, jpkm1 692 DO ji = 1, jpi 693 ! ... fields nitm2 <== nitm 694 vnbnd(ji,jk,nib ,nitm2) = vnbnd(ji,jk,nib ,nitm)*vnmsk(ji,jk) 695 vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk) 696 vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk) 697 END DO 698 END DO 699 700 DO jj = fs_njn0, fs_njn1 ! Vector opt. 701 DO jk = 1, jpkm1 702 DO ji = 1, jpi 703 vnbnd(ji,jk,nib ,nitm) = vnbnd(ji,jk,nib, nit)*vnmsk(ji,jk) 704 vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk) 705 vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk) 706 ! ... fields nit <== now (kt+1) 707 ! ... total or baroclinic velocity at b, bm and bm2 708 zvcb = vn (ji,jj,jk) 709 zvcbm = vn (ji,jj-1,jk) 710 zvcbm2 = vn (ji,jj-2,jk) 711 ! ... fields nit <== now (kt+1) 712 vnbnd(ji,jk,nib ,nit) = zvcb *vnmsk(ji,jk) 713 vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk) 714 vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk) 715 END DO 716 END DO 717 END DO 718 IF( lk_mpp ) CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout ) 719 720 ! ... extremeties njn0,njn1 721 ii = jpind + 1 - nimpp 722 IF( ii >= 2 .AND. ii < jpim1 ) THEN 723 DO jk = 1, jpkm1 724 vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm) 725 END DO 726 END IF 727 ii = jpinf + 1 - nimpp 728 IF( ii >= 2 .AND. ii < jpim1 ) THEN 729 DO jk = 1, jpkm1 730 vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm) 731 END DO 732 END IF 733 734 ! 1.3 Temperature and salinity 735 ! ---------------------------- 736 737 ! ... advance in time (time filter, array swap) 738 DO jk = 1, jpkm1 739 DO ji = 1, jpi 740 ! ... fields nitm <== nit plus time filter at the boundary 741 tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 742 snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 743 END DO 744 END DO 745 746 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 747 DO jk = 1, jpkm1 748 DO ji = 1, jpi 749 tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 750 snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 751 ! ... fields nit <== now (kt+1) 752 tnbnd(ji,jk,nib ,nit) = tn(ji,jj, jk)*tnmsk(ji,jk) 753 tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk) 754 snbnd(ji,jk,nib ,nit) = sn(ji,jj, jk)*tnmsk(ji,jk) 755 snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk) 756 END DO 757 END DO 758 END DO 759 IF( lk_mpp ) CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 760 IF( lk_mpp ) CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 761 762 ! ... extremeties njn0,njn1 763 ii = jpind + 1 - nimpp 764 IF( ii >= 2 .AND. ii < jpim1 ) THEN 765 DO jk = 1, jpkm1 766 tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm) 767 snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm) 768 END DO 769 END IF 770 ii = jpinf + 1 - nimpp 771 IF( ii >= 2 .AND. ii < jpim1 ) THEN 772 DO jk = 1, jpkm1 773 tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm) 774 snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm) 775 END DO 776 END IF 777 778 END IF ! End of array swap 779 780 ! 2 - Calculation of radiation velocities 781 ! --------------------------------------- 782 783 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 784 785 ! 2.1 Calculate the normal velocity based on phase velocity u_cynbnd 786 ! ------------------------------------------------------------------- 787 ! 788 ! ji-row 789 ! | 790 ! nib -///u////// jpjnob + 1 791 ! /////|////// 792 ! nib -----f----- jpjnob 793 ! | 794 ! nibm-- u ---- jpjnob 795 ! | 796 ! nibm -----f----- jpjnob-1 797 ! | 798 ! nibm2-- u ---- jpjnob-1 799 ! | 800 ! nibm2 -----f----- jpjnob-2 801 ! | 802 ! ... radiative condition 803 ! ... jpjnob+1,(jpindp1, jpinfm1) 804 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 805 DO jk = 1, jpkm1 806 DO ji = 2, jpim1 807 ! ... 2* j-gradient of u (f-point i=nibm, time mean) 808 z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) & 809 - 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2) 810 ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 811 z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1) 812 ! ... square of the norm of grad(v) 813 z4nor2 = z2dx * z2dx + z2dy * z2dy 814 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 815 zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit) 816 ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 817 ! velocity ratio no divided by e1f for the tracer radiation 818 IF( z4nor2 == 0.) THEN 819 z4nor2=.000001 820 END IF 821 z05cx = zdt * z2dx / z4nor2 822 u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk) 823 END DO 824 END DO 825 END DO 826 IF( lk_mpp ) CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout ) 827 828 ! ... extremeties njn0,njn1 829 ii = jpind + 1 - nimpp 830 IF( ii >= 2 .AND. ii < jpim1 ) THEN 831 DO jk = 1, jpkm1 832 u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk) 833 END DO 834 END IF 835 ii = jpinf + 1 - nimpp 836 IF( ii >= 2 .AND. ii < jpim1 ) THEN 837 DO jk = 1, jpkm1 838 u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk) 839 END DO 840 END IF 841 842 ! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd 843 ! ------------------------------------------------------------------ 844 ! 845 ! ji-row ji-row 846 ! | 847 ! /////|///////////////// 848 ! nib -----f----v----f---- jpjnob 849 ! | | 850 ! nib - u -- T -- u ---- jpjnob 851 ! | | 852 ! nibm -----f----v----f---- jpjnob-1 853 ! | | 854 ! nibm -- u -- T -- u --- jpjnob-1 855 ! | | 856 ! nibm2 -----f----v----f---- jpjnob-2 857 ! | | 858 ! ... Free surface formulation: 859 ! ... radiative conditions on the total part + relaxation toward climatology 860 ! ... jpjnob,(jpindp1, jpinfm1) 861 DO jj = fs_njn0, fs_njn1 ! Vector opt. 862 DO jk = 1, jpkm1 863 DO ji = 2, jpim1 864 ! ... 2* gradj(v) (T-point i=nibm, time mean) 865 ii = ji -1 + nimpp 866 z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) & 867 - 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1) 868 ! ... 2* gradi(v) (v-point i=nibm, time nitm) 869 z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1) 870 ! ... square of the norm of grad(u) 871 z4nor2 = z2dx * z2dx + z2dy * z2dy 872 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 873 zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit) 874 ! ... j-phase speed ratio (bounded by 1) 875 IF( z4nor2 == 0. ) THEN 876 z4nor2=.00001 877 END IF 878 z05cx = zdt * z2dx / z4nor2 879 v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk) 880 END DO 881 END DO 882 END DO 883 884 END IF 885 886 END SUBROUTINE obc_rad_north 887 888 889 SUBROUTINE obc_rad_south ( kt ) 890 !!------------------------------------------------------------------------------ 891 !! *** SUBROUTINE obc_rad_south *** 892 !! 893 !! ** Purpose : 894 !! Perform swap of arrays to calculate radiative phase speeds at the open 895 !! south boundary and calculate those phase speeds if this OBC is not fixed. 896 !! In case of fixed OBC, this subrountine is not called. 897 !! 898 !! History : 899 !! ! 95-03 (J.-M. Molines) Original from SPEM 900 !! ! 97-07 (G. Madec, J.-M. Molines) additions 901 !! ! 97-12 (M. Imbard) Mpp adaptation 902 !! ! 00-06 (J.-M. Molines) 903 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 904 !!------------------------------------------------------------------------------ 905 !! * Arguments 906 INTEGER, INTENT( in ) :: kt 907 908 !! * Local declarations 909 INTEGER :: ii 910 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 911 REAL(wp) :: zvcb, zvcbm, zvcbm2 912 !!------------------------------------------------------------------------------ 913 914 ! 1. Swap arrays before calculating radiative velocities 915 ! ------------------------------------------------------ 916 917 ! 1.1 zonal velocity 918 ! -------------------- 919 920 IF( kt > nit000 .OR. ln_rstart ) THEN 921 922 ! ... advance in time (time filter, array swap) 923 DO jk = 1, jpkm1 924 DO ji = 1, jpi 925 ! ... fields nitm2 <== nitm 926 usbnd(ji,jk,nib ,nitm2) = usbnd(ji,jk,nib ,nitm)*usmsk(ji,jk) 927 usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk) 928 usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk) 929 END DO 930 END DO 931 932 DO jj = fs_njs0, fs_njs1 ! Vector opt. 933 DO jk = 1, jpkm1 934 DO ji = 1, jpi 935 usbnd(ji,jk,nib ,nitm) = usbnd(ji,jk,nib, nit)*usmsk(ji,jk) 936 usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk) 937 usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk) 938 ! ... fields nit <== now (kt+1) 939 usbnd(ji,jk,nib ,nit) = un(ji,jj ,jk)*usmsk(ji,jk) 940 usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk) 941 usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk) 942 END DO 943 END DO 944 END DO 945 IF( lk_mpp ) CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 946 947 ! ... extremeties njs0,njs1 948 ii = jpisd + 1 - nimpp 949 IF( ii >= 2 .AND. ii < jpim1 ) THEN 950 DO jk = 1, jpkm1 951 usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm) 952 END DO 953 END IF 954 ii = jpisf + 1 - nimpp 955 IF( ii >= 2 .AND. ii < jpim1 ) THEN 956 DO jk = 1, jpkm1 957 usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm) 958 END DO 959 END IF 960 961 ! 1.2 normal velocity 962 ! ------------------- 963 964 !.. advance in time (time filter, array swap) 965 DO jk = 1, jpkm1 966 DO ji = 1, jpi 967 ! ... fields nitm2 <== nitm 968 vsbnd(ji,jk,nib ,nitm2) = vsbnd(ji,jk,nib ,nitm)*vsmsk(ji,jk) 969 vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk) 970 END DO 971 END DO 972 973 DO jj = fs_njs0, fs_njs1 ! Vector opt. 974 DO jk = 1, jpkm1 975 DO ji = 1, jpi 976 vsbnd(ji,jk,nib ,nitm) = vsbnd(ji,jk,nib, nit)*vsmsk(ji,jk) 977 vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk) 978 vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk) 979 ! ... total or baroclinic velocity at b, bm and bm2 980 zvcb = vn (ji,jj,jk) 981 zvcbm = vn (ji,jj+1,jk) 982 zvcbm2 = vn (ji,jj+2,jk) 983 ! ... fields nit <== now (kt+1) 984 vsbnd(ji,jk,nib ,nit) = zvcb *vsmsk(ji,jk) 985 vsbnd(ji,jk,nibm ,nit) = zvcbm *vsmsk(ji,jk) 986 vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk) 987 END DO 988 END DO 989 END DO 990 IF( lk_mpp ) CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 991 992 ! ... extremeties njs0,njs1 993 ii = jpisd + 1 - nimpp 994 IF( ii >= 2 .AND. ii < jpim1 ) THEN 995 DO jk = 1, jpkm1 996 vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm) 997 END DO 998 END IF 999 ii = jpisf + 1 - nimpp 1000 IF( ii >= 2 .AND. ii < jpim1 ) THEN 1001 DO jk = 1, jpkm1 1002 vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm) 1003 END DO 1004 END IF 1005 1006 ! 1.3 Temperature and salinity 1007 ! ---------------------------- 1008 1009 ! ... advance in time (time filter, array swap) 1010 DO jk = 1, jpkm1 1011 DO ji = 1, jpi 1012 ! ... fields nitm <== nit plus time filter at the boundary 1013 tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 1014 ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 1015 END DO 1016 END DO 1017 1018 DO jj = fs_njs0, fs_njs1 ! Vector opt. 1019 DO jk = 1, jpkm1 1020 DO ji = 1, jpi 1021 tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 1022 ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 1023 ! ... fields nit <== now (kt+1) 1024 tsbnd(ji,jk,nib ,nit) = tn(ji,jj ,jk)*tsmsk(ji,jk) 1025 tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk) 1026 ssbnd(ji,jk,nib ,nit) = sn(ji,jj ,jk)*tsmsk(ji,jk) 1027 ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk) 1028 END DO 1029 END DO 1030 END DO 1031 IF( lk_mpp ) CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 1032 IF( lk_mpp ) CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 1033 1034 ! ... extremeties njs0,njs1 1035 ii = jpisd + 1 - nimpp 1036 IF( ii >= 2 .AND. ii < jpim1 ) THEN 1037 DO jk = 1, jpkm1 1038 tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm) 1039 ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm) 1040 END DO 1041 END IF 1042 ii = jpisf + 1 - nimpp 1043 IF( ii >= 2 .AND. ii < jpim1 ) THEN 1044 DO jk = 1, jpkm1 1045 tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm) 1046 ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm) 1047 END DO 1048 END IF 1049 1050 END IF ! End of array swap 1051 1052 ! 2 - Calculation of radiation velocities 1053 ! --------------------------------------- 1054 1055 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 1056 1057 ! 2.1 Calculate the normal velocity based on phase velocity u_cysbnd 1058 ! ------------------------------------------------------------------- 1059 ! 1060 ! ji-row 1061 ! | 1062 ! nibm2 -----f----- jpjsob +2 1063 ! | 1064 ! nibm2 -- u ----- jpjsob +2 1065 ! | 1066 ! nibm -----f----- jpjsob +1 1067 ! | 1068 ! nibm -- u ----- jpjsob +1 1069 ! | 1070 ! nib -----f----- jpjsob 1071 ! /////|////// 1072 ! nib ////u///// jpjsob 1073 ! 1074 ! ... radiative condition plus Raymond-Kuo 1075 ! ... jpjsob,(jpisdp1, jpisfm1) 1076 DO jj = fs_njs0, fs_njs1 ! Vector opt. 1077 DO jk = 1, jpkm1 1078 DO ji = 2, jpim1 1079 ! ... 2* j-gradient of u (f-point i=nibm, time mean) 1080 z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) & 1081 + 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1) 1082 ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 1083 z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1) 1084 ! ... square of the norm of grad(v) 1085 z4nor2 = z2dx * z2dx + z2dy * z2dy 1086 IF( z4nor2 == 0.) THEN 1087 z4nor2 = 0.000001 1088 END IF 1089 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 1090 zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit) 1091 ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 1092 ! velocity ratio no divided by e1f for the tracer radiation 1093 z05cx = zdt * z2dx / z4nor2 1094 u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk) 1095 END DO 1096 END DO 1097 END DO 1098 IF( lk_mpp ) CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout ) 1099 1100 ! ... extremeties njs0,njs1 1101 ii = jpisd + 1 - nimpp 1102 IF( ii >= 2 .AND. ii < jpim1 ) THEN 1103 DO jk = 1, jpkm1 1104 u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk) 1105 END DO 1106 END IF 1107 ii = jpisf + 1 - nimpp 1108 IF( ii >= 2 .AND. ii < jpim1 ) THEN 1109 DO jk = 1, jpkm1 1110 u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk) 1111 END DO 1112 END IF 1113 1114 ! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd 1115 ! ------------------------------------------------------------------- 1116 ! 1117 ! ji-row ji-row 1118 ! | | 1119 ! nibm2 -----f----v----f---- jpjsob+2 1120 ! | | 1121 ! nibm - u -- T -- u ---- jpjsob+2 1122 ! | | 1123 ! nibm -----f----v----f---- jpjsob+1 1124 ! | | 1125 ! nib -- u -- T -- u --- jpjsob+1 1126 ! | | 1127 ! nib -----f----v----f---- jpjsob 1128 ! ///////////////////// 1129 ! 1130 ! ... Free surface formulation: 1131 ! ... radiative conditions on the total part + relaxation toward climatology 1132 ! ... jpjsob,(jpisdp1,jpisfm1) 1133 DO jj = fs_njs0, fs_njs1 ! Vector opt. 1134 DO jk = 1, jpkm1 1135 DO ji = 2, jpim1 1136 ! ... 2* gradj(v) (T-point i=nibm, time mean) 1137 z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) & 1138 + 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1) 1139 ! ... 2* gradi(v) (v-point i=nibm, time nitm) 1140 z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1) 1141 ! ... square of the norm of grad(u) 1142 z4nor2 = z2dx * z2dx + z2dy * z2dy 1143 IF( z4nor2 == 0.) THEN 1144 z4nor2 = 0.000001 1145 END IF 1146 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 1147 zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit) 1148 ! ... j-phase speed ratio (bounded by -1) 1149 z05cx = zdt * z2dx / z4nor2 1150 v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk) 1151 END DO 1152 END DO 1153 END DO 1154 1155 ENDIF 1156 1157 END SUBROUTINE obc_rad_south 1158 1159 #else 1160 1160 !!================================================================================= 1161 1161 !! *** MODULE obcrad *** -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90
r2865 r2888 1 1 MODULE obctra 2 !!====================================================================== 2 !!================================================================================= 3 3 !! *** MODULE obctra *** 4 !! Ocean tracers: Flow Relaxation Scheme of tracers on each open boundary 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 8 !!---------------------------------------------------------------------- 4 !! Ocean tracers: Radiation of tracers on each open boundary 5 !!================================================================================= 9 6 #if defined key_obc 10 !!---------------------------------------------------------------------- 11 !! 'key_obc' Unstructured Open Boundary Conditions 12 !!---------------------------------------------------------------------- 13 !! obc_tra : Apply open boundary conditions to T and S 14 !! obc_tra_frs : Apply Flow Relaxation Scheme 15 !!---------------------------------------------------------------------- 7 !!--------------------------------------------------------------------------------- 8 !! 'key_obc' : Open Boundary Conditions 9 !!--------------------------------------------------------------------------------- 10 !! obc_tra : call the subroutine for each open boundary 11 !! obc_tra_east : radiation of the east open boundary tracers 12 !! obc_tra_west : radiation of the west open boundary tracers 13 !! obc_tra_north : radiation of the north open boundary tracers 14 !! obc_tra_south : radiation of the south open boundary tracers 15 !!---------------------------------------------------------------------------------- 16 !! * Modules used 16 17 USE oce ! ocean dynamics and tracers variables 17 18 USE dom_oce ! ocean space and time domain variables 19 USE phycst ! physical constants 18 20 USE obc_oce ! ocean open boundary conditions 19 USE obcdta, ONLY: bf20 USE lbclnk ! ocean lateral boundary conditions (or mpp link)21 USE lib_mpp ! ??? 22 USE lbclnk ! ??? 21 23 USE in_out_manager ! I/O manager 22 24 … … 24 26 PRIVATE 25 27 26 PUBLIC obc_tra ! routine called in tranxt.F90 27 28 !!---------------------------------------------------------------------- 28 !! * Accessibility 29 PUBLIC obc_tra ! routine called in tranxt.F90 30 31 !! * Module variables 32 INTEGER :: & ! ... boundary space indices 33 nib = 1, & ! nib = boundary point 34 nibm = 2, & ! nibm = 1st interior point 35 nibm2 = 3, & ! nibm2 = 2nd interior point 36 ! ... boundary time indices 37 nit = 1, & ! nit = now 38 nitm = 2, & ! nitm = before 39 nitm2 = 3 ! nitm2 = before-before 40 41 REAL(wp) :: & 42 rtaue , rtauw , rtaun , rtaus , & ! Boundary restoring coefficient 43 rtauein, rtauwin, rtaunin, rtausin ! Boundary restoring coefficient for inflow 44 45 !! * Substitutions 46 # include "obc_vectopt_loop_substitute.h90" 47 !!--------------------------------------------------------------------------------- 29 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 30 49 !! $Id$ 31 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 32 !!---------------------------------------------------------------------- 51 !!--------------------------------------------------------------------------------- 52 33 53 CONTAINS 34 54 35 55 SUBROUTINE obc_tra( kt ) 56 !!------------------------------------------------------------------------------- 57 !! *** SUBROUTINE obc_tra *** 58 !! 59 !! ** Purpose : Compute tracer fields (t,s) along the open boundaries. 60 !! This routine is called by the tranxt.F routine and updates ta,sa 61 !! which are the actual temperature and salinity fields. 62 !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 63 !! and/or lp_obc_south allow the user to determine which boundary is an 64 !! open one (must be done in the param_obc.h90 file). 65 !! 66 !! Reference : 67 !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 68 !! 69 !! History : 70 !! ! 95-03 (J.-M. Molines) Original, SPEM 71 !! ! 97-07 (G. Madec, J.-M. Molines) addition 72 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 36 73 !!---------------------------------------------------------------------- 37 !! *** SUBROUTINE obc_dyn3d *** 38 !! 39 !! ** Purpose : - Apply open boundary conditions for baroclinic velocities 40 !! 74 !! * Arguments 75 INTEGER, INTENT( in ) :: kt 41 76 !!---------------------------------------------------------------------- 42 INTEGER, INTENT( in ) :: kt ! Main time step counter 43 !! 44 INTEGER :: ib_obc ! Loop index 45 46 DO ib_obc=1, nb_obc 47 48 SELECT CASE( nn_tra(ib_obc) ) 49 CASE(jp_none) 50 CYCLE 51 CASE(jp_frs) 52 CALL obc_tra_frs( idx_obc(ib_obc), dta_obc(ib_obc), kt ) 53 CASE DEFAULT 54 CALL ctl_stop( 'obc_tra : unrecognised option for open boundaries for T and S' ) 55 END SELECT 56 ENDDO 77 78 ! 0. Local constant initialization 79 80 IF( kt == nit000 .OR. ln_rstart) THEN 81 ! ... Boundary restoring coefficient 82 rtaue = 2. * rdt / rdpeob 83 rtauw = 2. * rdt / rdpwob 84 rtaun = 2. * rdt / rdpnob 85 rtaus = 2. * rdt / rdpsob 86 ! ... Boundary restoring coefficient for inflow ( all boundaries) 87 rtauein = 2. * rdt / rdpein 88 rtauwin = 2. * rdt / rdpwin 89 rtaunin = 2. * rdt / rdpnin 90 rtausin = 2. * rdt / rdpsin 91 END IF 92 93 IF( lp_obc_east ) CALL obc_tra_east ( kt ) ! East open boundary 94 95 IF( lp_obc_west ) CALL obc_tra_west ( kt ) ! West open boundary 96 97 IF( lp_obc_north ) CALL obc_tra_north( kt ) ! North open boundary 98 99 IF( lp_obc_south ) CALL obc_tra_south( kt ) ! South open boundary 100 101 IF( lk_mpp ) THEN !!bug ??? 102 IF( kt >= nit000+3 .AND. ln_rstart ) THEN 103 CALL lbc_lnk( tb, 'T', 1. ) 104 CALL lbc_lnk( sb, 'T', 1. ) 105 END IF 106 CALL lbc_lnk( ta, 'T', 1. ) 107 CALL lbc_lnk( sa, 'T', 1. ) 108 ENDIF 57 109 58 110 END SUBROUTINE obc_tra 59 111 60 SUBROUTINE obc_tra_frs( idx, dta, kt ) 61 !!---------------------------------------------------------------------- 62 !! *** SUBROUTINE obc_tra_frs *** 63 !! 64 !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries. 65 !! 66 !! Reference : Engedahl H., 1995, Tellus, 365-382. 67 !!---------------------------------------------------------------------- 68 INTEGER, INTENT(in) :: kt 69 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 70 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 71 !! 72 REAL(wp) :: zwgt ! boundary weight 73 INTEGER :: ib, ik, igrd ! dummy loop indices 74 INTEGER :: ii, ij ! 2D addresses 75 !!---------------------------------------------------------------------- 76 ! 77 ! 78 igrd = 1 ! Everything is at T-points here 79 DO ib = 1, idx%nblen(igrd) 80 DO ik = 1, jpkm1 81 ii = idx%nbi(ib,igrd) 82 ij = idx%nbj(ib,igrd) 83 zwgt = idx%nbw(ib,igrd) 84 ta(ii,ij,ik) = ( ta(ii,ij,ik) + zwgt * ( dta%tem(ib,ik) - ta(ii,ij,ik) ) ) * tmask(ii,ij,ik) 85 sa(ii,ij,ik) = ( sa(ii,ij,ik) + zwgt * ( dta%sal(ib,ik) - sa(ii,ij,ik) ) ) * tmask(ii,ij,ik) 86 END DO 87 END DO 88 ! 89 CALL lbc_lnk( ta, 'T', 1. ) ; CALL lbc_lnk( sa, 'T', 1. ) ! Boundary points should be updated 90 ! 91 IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 92 ! 93 END SUBROUTINE obc_tra_frs 94 112 113 SUBROUTINE obc_tra_east ( kt ) 114 !!------------------------------------------------------------------------------ 115 !! *** SUBROUTINE obc_tra_east *** 116 !! 117 !! ** Purpose : 118 !! Apply the radiation algorithm on east OBC tracers ta, sa using the 119 !! phase velocities calculated in obc_rad_east subroutine in obcrad.F90 module 120 !! If the logical lfbceast is .TRUE., there is no radiation but only fixed OBC 121 !! 122 !! History : 123 !! ! 95-03 (J.-M. Molines) Original from SPEM 124 !! ! 97-07 (G. Madec, J.-M. Molines) additions 125 !! ! 97-12 (M. Imbard) Mpp adaptation 126 !! ! 00-06 (J.-M. Molines) 127 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 128 !!------------------------------------------------------------------------------ 129 !! * Arguments 130 INTEGER, INTENT( in ) :: kt 131 132 !! * Local declaration 133 INTEGER :: ji, jj, jk ! dummy loop indices 134 REAL(wp) :: z05cx, ztau, zin 135 !!------------------------------------------------------------------------------ 136 137 ! 1. First three time steps and more if lfbceast is .TRUE. 138 ! In that case open boundary conditions are FIXED. 139 ! -------------------------------------------------------- 140 141 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast ) THEN 142 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 143 DO jk = 1, jpkm1 144 DO jj = 1, jpj 145 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 146 tfoe(jj,jk)*temsk(jj,jk) 147 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) + & 148 sfoe(jj,jk)*temsk(jj,jk) 149 END DO 150 END DO 151 END DO 152 153 ELSE 154 155 ! 2. Beyond the fourth time step if lfbceast is .FALSE. 156 ! ----------------------------------------------------- 157 158 ! Temperature and salinity radiation 159 ! ---------------------------------- 160 ! 161 ! nibm2 nibm nib 162 ! | nibm | nib///|/// 163 ! | | | |////|/// 164 ! jj line --v----f----v----f----v--- 165 ! | | | |////|/// 166 ! | |/// // 167 ! jj line T u T u/// T // 168 ! | |/// // 169 ! | | | |////|/// 170 ! jj-1 line --v----f----v----f----v--- 171 ! | | | |////|/// 172 ! jpieob-1 jpieob / /// 173 ! | | | 174 ! jpieob-1 jpieob jpieob+1 175 ! 176 ! ... radiative conditions + relaxation toward a climatology 177 ! the phase velocity is taken as the phase velocity of the tangen- 178 ! tial velocity (here vn), which have been saved in (u_cxebnd,v_cxebnd) 179 ! ... (jpjedp1, jpjefm1), jpieob+1 180 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 181 DO jk = 1, jpkm1 182 DO jj = 2, jpjm1 183 ! ... i-phase speed ratio (from averaged of v_cxebnd) 184 z05cx = ( 0.5 * ( v_cxebnd(jj,jk) + v_cxebnd(jj-1,jk) ) ) / e1t(ji-1,jj) 185 z05cx = min( z05cx, 1. ) 186 ! ... z05cx=< 0, inflow zin=0, ztau=1 187 ! > 0, outflow zin=1, ztau=rtaue 188 zin = sign( 1., z05cx ) 189 zin = 0.5*( zin + abs(zin) ) 190 ! ... for inflow rtauein is used for relaxation coefficient else rtaue 191 ztau = (1.-zin ) * rtauein + zin * rtaue 192 z05cx = z05cx * zin 193 ! ... update ( ta, sa ) with radiative or climatological (t, s) 194 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 195 temsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 196 * tebnd(jj,jk,nib ,nitm) + 2.*z05cx & 197 * tebnd(jj,jk,nibm,nit ) + ztau * tfoe (jj,jk) ) & 198 / (1. + z05cx) 199 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) + & 200 temsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 201 * sebnd(jj,jk,nib ,nitm) + 2.*z05cx & 202 * sebnd(jj,jk,nibm,nit ) + ztau * sfoe (jj,jk) ) & 203 / (1. + z05cx) 204 END DO 205 END DO 206 END DO 207 208 END IF 209 210 END SUBROUTINE obc_tra_east 211 212 213 SUBROUTINE obc_tra_west ( kt ) 214 !!------------------------------------------------------------------------------ 215 !! *** SUBROUTINE obc_tra_west *** 216 !! 217 !! ** Purpose : 218 !! Apply the radiation algorithm on west OBC tracers ta, sa using the 219 !! phase velocities calculated in obc_rad_west subroutine in obcrad.F90 module 220 !! If the logical lfbcwest is .TRUE., there is no radiation but only fixed OBC 221 !! 222 !! History : 223 !! ! 95-03 (J.-M. Molines) Original from SPEM 224 !! ! 97-07 (G. Madec, J.-M. Molines) additions 225 !! ! 97-12 (M. Imbard) Mpp adaptation 226 !! ! 00-06 (J.-M. Molines) 227 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 228 !!------------------------------------------------------------------------------ 229 !! * Arguments 230 INTEGER, INTENT( in ) :: kt 231 232 !! * Local declaration 233 INTEGER :: ji, jj, jk ! dummy loop indices 234 REAL(wp) :: z05cx, ztau, zin 235 !!------------------------------------------------------------------------------ 236 237 ! 1. First three time steps and more if lfbcwest is .TRUE. 238 ! In that case open boundary conditions are FIXED. 239 ! -------------------------------------------------------- 240 241 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest ) THEN 242 243 DO ji = fs_niw0, fs_niw1 ! Vector opt. 244 DO jk = 1, jpkm1 245 DO jj = 1, jpj 246 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 247 tfow(jj,jk)*twmsk(jj,jk) 248 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 249 sfow(jj,jk)*twmsk(jj,jk) 250 END DO 251 END DO 252 END DO 253 254 ELSE 255 256 ! 2. Beyond the fourth time step if lfbcwest is .FALSE. 257 ! ----------------------------------------------------- 258 259 ! Temperature and salinity radiation 260 ! ---------------------------------- 261 ! 262 ! nib nibm nibm2 263 ! nib///| nibm | nibm2 | 264 ! ///|////| | | | | 265 ! ---v----f----v----f----v----f-- jj line 266 ! ///|////| | | | | 267 ! // ///| | | 268 ! // T ///u T u T u jj line 269 ! // ///| | | 270 ! ///|////| | | | | 271 ! ---v----f----v----f----v----f-- jj-1 line 272 ! ///|////| | | | | 273 ! jpiwob jpiwob+1 jpiwob+2 274 ! | | | 275 ! jpiwob jpiwob+1 jpiwob+2 276 ! 277 ! ... radiative conditions + relaxation toward a climatology 278 ! ... the phase velocity is taken as the phase velocity of the tangen- 279 ! ... tial velocity (here vn), which have been saved in (v_cxwbnd) 280 DO ji = fs_niw0, fs_niw1 ! Vector opt. 281 DO jk = 1, jpkm1 282 DO jj = 2, jpjm1 283 ! ... i-phase speed ratio (from averaged of v_cxwbnd) 284 z05cx = ( 0.5 * ( v_cxwbnd(jj,jk) + v_cxwbnd(jj-1,jk) ) ) / e1t(ji+1,jj) 285 z05cx = max( z05cx, -1. ) 286 ! ... z05cx > 0, inflow zin=0, ztau=1 287 ! < 0, outflow zin=1, ztau=rtauw 288 zin = sign( 1., -1.* z05cx ) 289 zin = 0.5*( zin + abs(zin) ) 290 ztau = (1.-zin )*rtauwin + zin * rtauw 291 z05cx = z05cx * zin 292 ! ... update (ta,sa) with radiative or climatological (t, s) 293 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 294 twmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 295 * twbnd(jj,jk,nib ,nitm) - 2.*z05cx & 296 * twbnd(jj,jk,nibm,nit ) + ztau * tfow (jj,jk) ) & 297 / (1. - z05cx) 298 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 299 twmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 300 * swbnd(jj,jk,nib ,nitm) - 2.*z05cx & 301 * swbnd(jj,jk,nibm,nit ) + ztau * sfow (jj,jk) ) & 302 / (1. - z05cx) 303 END DO 304 END DO 305 END DO 306 307 END IF 308 309 END SUBROUTINE obc_tra_west 310 311 312 SUBROUTINE obc_tra_north ( kt ) 313 !!------------------------------------------------------------------------------ 314 !! *** SUBROUTINE obc_tra_north *** 315 !! 316 !! ** Purpose : 317 !! Apply the radiation algorithm on north OBC tracers ta, sa using the 318 !! phase velocities calculated in obc_rad_north subroutine in obcrad.F90 module 319 !! If the logical lfbcnorth is .TRUE., there is no radiation but only fixed OBC 320 !! 321 !! History : 322 !! ! 95-03 (J.-M. Molines) Original from SPEM 323 !! ! 97-07 (G. Madec, J.-M. Molines) additions 324 !! ! 97-12 (M. Imbard) Mpp adaptation 325 !! ! 00-06 (J.-M. Molines) 326 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 327 !!------------------------------------------------------------------------------ 328 !! * Arguments 329 INTEGER, INTENT( in ) :: kt 330 331 !! * Local declaration 332 INTEGER :: ji, jj, jk ! dummy loop indices 333 REAL(wp) :: z05cx, ztau, zin 334 !!------------------------------------------------------------------------------ 335 336 ! 1. First three time steps and more if lfbcnorth is .TRUE. 337 ! In that case open boundary conditions are FIXED. 338 ! -------------------------------------------------------- 339 340 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcnorth ) THEN 341 342 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 343 DO jk = 1, jpkm1 344 DO ji = 1, jpi 345 ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 346 tnmsk(ji,jk) * tfon(ji,jk) 347 sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 348 tnmsk(ji,jk) * sfon(ji,jk) 349 END DO 350 END DO 351 END DO 352 353 ELSE 354 355 ! 2. Beyond the fourth time step if lfbcnorth is .FALSE. 356 ! ------------------------------------------------------- 357 358 ! Temperature and salinity radiation 359 ! ---------------------------------- 360 ! 361 ! ji-1 ji ji ji +1 362 ! | 363 ! nib //// u // T // u // T // jpjnob + 1 364 ! /////|////////////////// 365 ! nib ----f----v----f----v--- jpjnob 366 ! | | 367 ! nibm-- u -- T -- u -- T -- jpjnob 368 ! | | 369 ! nibm ----f----v----f----v--- jpjnob-1 370 ! | | 371 ! nibm2-- u -- T -- T -- T -- jpjnob-1 372 ! | | 373 ! nibm2 ----f----v----f----v--- jpjnob-2 374 ! | | 375 ! 376 ! ... radiative conditions + relaxation toward a climatology 377 ! ... the phase velocity is taken as the normal phase velocity of the tangen- 378 ! ... tial velocity (here un), which has been saved in (u_cynbnd) 379 ! ... jpjnob+1,(jpindp1, jpinfm1) 380 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 381 DO jk = 1, jpkm1 382 DO ji = 2, jpim1 383 ! ... j-phase speed ratio (from averaged of vtnbnd) 384 ! (bounded by 1) 385 z05cx = ( 0.5 * ( u_cynbnd(ji,jk) + u_cynbnd(ji-1,jk) ) ) / e2t(ji,jj-1) 386 z05cx = min( z05cx, 1. ) 387 ! ... z05cx=< 0, inflow zin=0, ztau=1 388 ! > 0, outflow zin=1, ztau=rtaun 389 zin = sign( 1., z05cx ) 390 zin = 0.5*( zin + abs(zin) ) 391 ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 392 ztau = (1.-zin ) * rtaunin + zin * rtaun 393 z05cx = z05cx * zin 394 ! ... update (ta,sa) with radiative or climatological (t, s) 395 ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 396 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 397 * tnbnd(ji,jk,nib ,nitm) + 2.*z05cx & 398 * tnbnd(ji,jk,nibm,nit ) + ztau * tfon (ji,jk) ) & 399 / (1. + z05cx) 400 sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 401 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 402 * snbnd(ji,jk,nib ,nitm) + 2.*z05cx & 403 * snbnd(ji,jk,nibm,nit ) + ztau * sfon (ji,jk) ) & 404 / (1. + z05cx) 405 END DO 406 END DO 407 END DO 408 409 END IF 410 411 END SUBROUTINE obc_tra_north 412 413 414 SUBROUTINE obc_tra_south ( kt ) 415 !!------------------------------------------------------------------------------ 416 !! *** SUBROUTINE obc_tra_south *** 417 !! 418 !! ** Purpose : 419 !! Apply the radiation algorithm on south OBC tracers ta, sa using the 420 !! phase velocities calculated in obc_rad_south subroutine in obcrad.F90 module 421 !! If the logical lfbcsouth is .TRUE., there is no radiation but only fixed OBC 422 !! 423 !! History : 424 !! ! 95-03 (J.-M. Molines) Original from SPEM 425 !! ! 97-07 (G. Madec, J.-M. Molines) additions 426 !! ! 97-12 (M. Imbard) Mpp adaptation 427 !! ! 00-06 (J.-M. Molines) 428 !! 8.5 ! 02-10 (C. Talandier, A-M Treguier) F90 429 !!------------------------------------------------------------------------------ 430 !! * Arguments 431 INTEGER, INTENT( in ) :: kt 432 433 !! * Local declaration 434 INTEGER :: ji, jj, jk ! dummy loop indices 435 REAL(wp) :: z05cx, ztau, zin 436 !!------------------------------------------------------------------------------ 437 438 ! 1. First three time steps and more if lfbcsouth is .TRUE. 439 ! In that case open boundary conditions are FIXED. 440 ! -------------------------------------------------------- 441 442 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcsouth ) THEN 443 444 DO jj = fs_njs0, fs_njs1 ! Vector opt. 445 DO jk = 1, jpkm1 446 DO ji = 1, jpi 447 ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 448 tsmsk(ji,jk) * tfos(ji,jk) 449 sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 450 tsmsk(ji,jk) * sfos(ji,jk) 451 END DO 452 END DO 453 END DO 454 455 ELSE 456 457 ! 2. Beyond the fourth time step if lfbcsouth is .FALSE. 458 ! ------------------------------------------------------- 459 460 ! Temperature and salinity radiation 461 ! ---------------------------------- 462 ! 463 ! ji-1 ji ji ji +1 464 ! | | 465 ! nibm2 ----f----v----f----v--- jpjsob+2 466 ! | | 467 ! nibm2 -- u -- T -- u -- T -- jpjsob+2 468 ! | | 469 ! nibm ----f----v----f----v--- jpjsob+1 470 ! | | 471 ! nibm -- u -- T -- T -- T -- jpjsob+1 472 ! | | 473 ! nib -----f----v----f----v--- jpjsob 474 ! //////|/////////|//////// 475 ! nib //// u // T // u // T // jpjsob 476 ! 477 !... radiative conditions + relaxation toward a climatology 478 !... the phase velocity is taken as the phase velocity of the tangen- 479 !... tial velocity (here un), which has been saved in (u_cysbnd) 480 !... jpjsob,(jpisdp1, jpisfm1) 481 DO jj = fs_njs0, fs_njs1 ! Vector opt. 482 DO jk = 1, jpkm1 483 DO ji = 2, jpim1 484 !... j-phase speed ratio (from averaged of u_cysbnd) 485 ! (bounded by 1) 486 z05cx = ( 0.5 * ( u_cysbnd(ji,jk) + u_cysbnd(ji-1,jk) ) ) / e2t(ji,jj+1) 487 z05cx = max( z05cx, -1. ) 488 !... z05cx > 0, inflow zin=0, ztau=1 489 ! < 0, outflow zin=1, ztau=rtaus 490 zin = sign( 1., -1.* z05cx ) 491 zin = 0.5*( zin + abs(zin) ) 492 ztau = (1.-zin ) * rtausin + zin * rtaus 493 z05cx = z05cx * zin 494 495 !... update (ta,sa) with radiative or climatological (t, s) 496 ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 497 tsmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 498 * tsbnd(ji,jk,nib ,nitm) - 2.*z05cx & 499 * tsbnd(ji,jk,nibm,nit ) + ztau * tfos (ji,jk) ) & 500 / (1. - z05cx) 501 sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 502 tsmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 503 * ssbnd(ji,jk,nib ,nitm) - 2.*z05cx & 504 * ssbnd(ji,jk,nibm,nit ) + ztau * sfos (ji,jk) ) & 505 / (1. - z05cx) 506 END DO 507 END DO 508 END DO 509 510 END IF 511 512 END SUBROUTINE obc_tra_south 513 95 514 #else 96 !!---------------------------------------------------------------------- 97 !! D ummy module NO Unstruct Open Boundary Conditions98 !!---------------------------------------------------------------------- 515 !!--------------------------------------------------------------------------------- 516 !! Default option Empty module 517 !!--------------------------------------------------------------------------------- 99 518 CONTAINS 100 SUBROUTINE obc_tra(kt) ! Empty routine 101 WRITE(*,*) 'obc_tra: You should not have seen this print! error?', kt 519 SUBROUTINE obc_tra ! Empty routine 102 520 END SUBROUTINE obc_tra 103 521 #endif 104 522 105 !!====================================================================== 523 !!================================================================================= 106 524 END MODULE obctra -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcvol.F90
r2865 r2888 1 1 MODULE obcvol 2 !!====================================================================== 2 !!================================================================================= 3 3 !! *** MODULE obcvol *** 4 !! Ocean dynamic : Volume constraint when unstructured boundary 5 !! and Free surface are used 6 !!====================================================================== 7 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 8 !! - ! 2006-01 (J. Chanut) Bug correction 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !!---------------------------------------------------------------------- 11 #if defined key_obc && defined key_dynspg_flt 12 !!---------------------------------------------------------------------- 13 !! 'key_obc' AND unstructured open boundary conditions 14 !! 'key_dynspg_flt' filtered free surface 15 !!---------------------------------------------------------------------- 4 !! Ocean dynamic : Volume constraint when OBC and Free surface are used 5 !!================================================================================= 6 #if defined key_obc && ! defined key_vvl 7 !!--------------------------------------------------------------------------------- 8 !! 'key_obc' and NOT open boundary conditions 9 !! 'key_vvl' constant volume free surface 10 !!--------------------------------------------------------------------------------- 11 !! * Modules used 16 12 USE oce ! ocean dynamics and tracers 17 13 USE dom_oce ! ocean space and time domain 14 USE sbc_oce ! ocean surface boundary conditions 18 15 USE phycst ! physical constants 19 16 USE obc_oce ! ocean open boundary conditions 20 17 USE lib_mpp ! for mppsum 21 18 USE in_out_manager ! I/O manager 22 USE sbc_oce ! ocean surface boundary conditions23 19 24 20 IMPLICIT NONE 25 21 PRIVATE 26 22 27 PUBLIC obc_vol ! routine called by dynspg_flt.h90 23 !! * Accessibility 24 PUBLIC obc_vol ! routine called by dynspg_flt 28 25 29 26 !! * Substitutions 30 27 # include "domzgr_substitute.h90" 31 !!---------------------------------------------------------------------- 28 # include "obc_vectopt_loop_substitute.h90" 29 !!--------------------------------------------------------------------------------- 32 30 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 33 31 !! $Id$ 34 32 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 35 !!---------------------------------------------------------------------- 33 !!--------------------------------------------------------------------------------- 34 36 35 CONTAINS 37 36 38 SUBROUTINE obc_vol ( kt )39 !!---------------------------------------------------------------------- 37 SUBROUTINE obc_vol ( kt ) 38 !!------------------------------------------------------------------------------ 40 39 !! *** ROUTINE obcvol *** 41 40 !! 42 !! ** Purpose : This routine is called in dynspg_flt to control 41 !! ** Purpose : 42 !! This routine is called in dynspg_flt to control 43 43 !! the volume of the system. A correction velocity is calculated 44 !! to correct the total transport through the unstructuredOBC.44 !! to correct the total transport through the OBC. 45 45 !! The total depth used is constant (H0) to be consistent with the 46 46 !! linear free surface coded in OPA 8.2 47 47 !! 48 !! ** Method : The correction velocity (zubtpecor here) is defined calculating 48 !! ** Method : 49 !! The correction velocity (zubtpecor here) is defined calculating 49 50 !! the total transport through all open boundaries (trans_obc) minus 50 !! the cumulate E-P flux (z_cflxemp) divided by the total lateral 51 !! surface (obcsurftot) of the unstructured boundary. 52 !! zubtpecor = [trans_obc - z_cflxemp ]*(1./obcsurftot) 53 !! with z_cflxemp => sum of (Evaporation minus Precipitation) 51 !! the cumulate E-P flux (zCflxemp) divided by the total lateral 52 !! surface (obcsurftot) of these OBC. 53 !! 54 !! zubtpecor = [trans_obc - zCflxemp ]*(1./obcsurftot) 55 !! 56 !! with zCflxemp => sum of (Evaporation minus Precipitation) 54 57 !! over all the domain in m3/s at each time step. 55 !! z_cflxemp < 0 when precipitation dominate 56 !! z_cflxemp > 0 when evaporation dominate 58 !! 59 !! zCflxemp < 0 when precipitation dominate 60 !! zCflxemp > 0 when evaporation dominate 57 61 !! 58 62 !! There are 2 options (user's desiderata): 63 !! 59 64 !! 1/ The volume changes according to E-P, this is the default 60 65 !! option. In this case the cumulate E-P flux are setting to 61 !! zero (z _cflxemp=0) to calculate the correction velocity. So66 !! zero (zCflxemp=0) to calculate the correction velocity. So 62 67 !! it will only balance the flux through open boundaries. 63 !! (set nn_volctl to 0 in tne namelist for this option) 68 !! (set volemp to 0 in tne namelist for this option) 69 !! 64 70 !! 2/ The volume is constant even with E-P flux. In this case 65 71 !! the correction velocity must balance both the flux 66 72 !! through open boundaries and the ones through the free 67 73 !! surface. 68 !! (set nn_volctl to 1 in tne namelist for this option) 69 !!---------------------------------------------------------------------- 74 !! (set volemp to 1 in tne namelist for this option) 75 !! 76 !! History : 77 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Original code 78 !!---------------------------------------------------------------------------- 79 !! * Arguments 70 80 INTEGER, INTENT( in ) :: kt ! ocean time-step index 71 !! 72 INTEGER :: ji, jj, jk, jb, jgrd 73 INTEGER :: ib_obc, ii, ij 74 REAL(wp) :: zubtpecor, z_cflxemp, ztranst 75 TYPE(OBC_INDEX), POINTER :: idx 81 82 !! * Local declarations 83 INTEGER :: ji, jj, jk 84 REAL(wp) :: zubtpecor 85 REAL(wp) :: zCflxemp 86 REAL(wp) :: ztransw, ztranse, ztransn, ztranss, ztranst 76 87 !!----------------------------------------------------------------------------- 77 88 78 IF( ln_vol ) THEN79 80 89 IF( kt == nit000 ) THEN 81 IF(lwp) WRITE(numout,*) 82 IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along unstructuredOBC'90 IF(lwp) WRITE(numout,*)' ' 91 IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along OBC' 83 92 IF(lwp) WRITE(numout,*)'~~~~~~~' 84 END IF 85 86 ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 87 ! ----------------------------------------------------------------------- 88 z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:) ) * obctmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 89 IF( lk_mpp ) CALL mpp_sum( z_cflxemp ) ! sum over the global domain 90 91 ! Transport through the unstructured open boundary 92 ! ------------------------------------------------ 93 IF(lwp) WRITE(numout,*)' ' 94 END IF 95 96 ! 1. Calculate the cumulate surface Flux zCflxemp (m3/s) over all the domain. 97 ! --------------------------------------------------------------------------- 98 99 zCflxemp = SUM ( ( emp(:,:)-rnf(:,:) )*obctmsk(:,:)* e1t(:,:) * e2t(:,:) / rau0 ) 100 101 IF( lk_mpp ) CALL mpp_sum( zCflxemp ) ! sum over the global domain 102 103 ! 2. Barotropic velocity for each open boundary 104 ! --------------------------------------------- 105 93 106 zubtpecor = 0.e0 94 DO ib_obc = 1, nb_obc 95 idx => idx_obc(ib_obc) 96 97 jgrd = 2 ! cumulate u component contribution first 98 DO jb = 1, idx%nblenrim(jgrd) 99 DO jk = 1, jpkm1 100 ii = idx%nbi(jb,jgrd) 101 ij = idx%nbj(jb,jgrd) 102 zubtpecor = zubtpecor + idx%flagu(jb) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 103 END DO 104 END DO 105 jgrd = 3 ! then add v component contribution 106 DO jb = 1, idx%nblenrim(jgrd) 107 DO jk = 1, jpkm1 108 ii = idx%nbi(jb,jgrd) 109 ij = idx%nbj(jb,jgrd) 110 zubtpecor = zubtpecor + idx%flagv(jb) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 111 END DO 112 END DO 113 114 END DO 107 108 ! ... East open boundary 109 IF( lp_obc_east ) THEN ! ... Total transport through the East OBC 110 DO ji = fs_nie0, fs_nie1 ! Vector opt. 111 DO jk = 1, jpkm1 112 DO jj = 1, jpj 113 zubtpecor = zubtpecor - ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 114 & uemsk(jj,jk)*MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 115 END DO 116 END DO 117 END DO 118 END IF 119 120 ! ... West open boundary 121 IF( lp_obc_west ) THEN ! ... Total transport through the West OBC 122 DO ji = fs_niw0, fs_niw1 ! Vector opt. 123 DO jk = 1, jpkm1 124 DO jj = 1, jpj 125 zubtpecor = zubtpecor + ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 126 & uwmsk(jj,jk) *MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 127 END DO 128 END DO 129 END DO 130 ENDIF 131 132 ! ... North open boundary 133 IF( lp_obc_north ) THEN ! ... Total transport through the North OBC 134 DO jj = fs_njn0, fs_njn1 ! Vector opt. 135 DO jk = 1, jpkm1 136 DO ji = 1, jpi 137 zubtpecor = zubtpecor - va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 138 & vnmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 139 END DO 140 END DO 141 END DO 142 ENDIF 143 144 ! ... South open boundary 145 IF( lp_obc_south ) THEN ! ... Total transport through the South OBC 146 DO jj = fs_njs0, fs_njs1 ! Vector opt. 147 DO jk = 1, jpkm1 148 DO ji = 1, jpi 149 zubtpecor = zubtpecor + va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 150 & vsmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 151 END DO 152 END DO 153 END DO 154 ENDIF 155 115 156 IF( lk_mpp ) CALL mpp_sum( zubtpecor ) ! sum over the global domain 116 157 117 ! The normal velocity correction 118 ! ------------------------------ 119 IF( nn_volctl==1 ) THEN ; zubtpecor = ( zubtpecor - z_cflxemp) / obcsurftot 120 ELSE ; zubtpecor = zubtpecor / obcsurftot 121 END IF 122 123 ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation 124 ! ------------------------------------------------------------- 125 ztranst = 0.e0 126 DO ib_obc = 1, nb_obc 127 idx => idx_obc(ib_obc) 128 129 jgrd = 2 ! correct u component 130 DO jb = 1, idx%nblenrim(jgrd) 131 DO jk = 1, jpkm1 132 ii = idx%nbi(jb,jgrd) 133 ij = idx%nbj(jb,jgrd) 134 ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb) * zubtpecor * umask(ii,ij,jk) 135 ztranst = ztranst + idx%flagu(jb) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 136 END DO 137 END DO 138 jgrd = 3 ! correct v component 139 DO jb = 1, idx%nblenrim(jgrd) 140 DO jk = 1, jpkm1 141 ii = idx%nbi(jb,jgrd) 142 ij = idx%nbj(jb,jgrd) 143 va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb) * zubtpecor * vmask(ii,ij,jk) 144 ztranst = ztranst + idx%flagv(jb) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 145 END DO 146 END DO 147 148 END DO 149 IF( lk_mpp ) CALL mpp_sum( ztranst ) ! sum over the global domain 150 151 ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 152 ! ------------------------------------------------------ 158 159 ! 3. The normal velocity correction 160 ! --------------------------------- 153 161 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 154 IF(lwp) WRITE(numout,*) 162 IF(lwp) WRITE(numout,*)' ' 155 163 IF(lwp) WRITE(numout,*)'obc_vol : time step :', kt 156 164 IF(lwp) WRITE(numout,*)'~~~~~~~ ' 157 IF(lwp) WRITE(numout,*)' cumulate flux EMP =', z_cflxemp , ' (m3/s)' 158 IF(lwp) WRITE(numout,*)' total lateral surface of OBC =', obcsurftot, '(m2)' 159 IF(lwp) WRITE(numout,*)' correction velocity zubtpecor =', zubtpecor , '(m/s)' 160 IF(lwp) WRITE(numout,*)' cumulated transport ztranst =', ztranst , '(m3/s)' 161 END IF 162 ! 163 END IF ! ln_vol 165 IF(lwp) WRITE(numout,*)' cumulate flux EMP :', zCflxemp,' (m3/s)' 166 IF(lwp) WRITE(numout,*)' lateral transport :',zubtpecor,'(m3/s)' 167 IF(lwp) WRITE(numout,*)' net inflow :',zubtpecor-zCflxemp,'(m3/s)' 168 ENDIF 169 170 zubtpecor = (zubtpecor - zCflxemp*volemp)*(1./obcsurftot) 171 172 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 173 IF(lwp) WRITE(numout,*)' total lateral surface of OBC :',obcsurftot,'(m2)' 174 IF(lwp) WRITE(numout,*)' correction velocity zubtpecor :',zubtpecor,'(m/s)' 175 IF(lwp) WRITE(numout,*)' ' 176 END IF 177 178 ! 4. Correction of the total velocity on each open 179 ! boundary to respect the mass flux conservation 180 ! ------------------------------------------------- 181 182 ztranse = 0.e0 ; ztransw = 0.e0 ; ztransn = 0.e0 ; ztranss = 0.e0 183 ztranst = 0.e0 ! total 184 185 IF( lp_obc_west ) THEN 186 ! ... correction of the west velocity 187 DO ji = fs_niw0, fs_niw1 ! Vector opt. 188 DO jk = 1, jpkm1 189 DO jj = 1, jpj 190 ua(ji,jj,jk) = ua(ji,jj,jk) - zubtpecor*uwmsk(jj,jk) 191 ztransw= ztransw + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uwmsk(jj,jk) * & 192 & MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 193 END DO 194 END DO 195 END DO 196 197 IF( lk_mpp ) CALL mpp_sum( ztransw ) ! sum over the global domain 198 199 IF( lwp .AND. MOD( kt, nwrite ) == 0) WRITE(numout,*)' West OB transport ztransw :', ztransw,'(m3/s)' 200 END IF 201 202 IF( lp_obc_east ) THEN 203 204 ! ... correction of the east velocity 205 DO ji = fs_nie0, fs_nie1 ! Vector opt. 206 DO jk = 1, jpkm1 207 DO jj = 1, jpj 208 ua(ji,jj,jk) = ua(ji,jj,jk) + zubtpecor*uemsk(jj,jk) 209 ztranse= ztranse + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uemsk(jj,jk) * & 210 & MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 211 END DO 212 END DO 213 END DO 214 215 IF( lk_mpp ) CALL mpp_sum( ztranse ) ! sum over the global domain 216 217 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 218 IF(lwp) WRITE(numout,*)' East OB transport ztranse :', ztranse,'(m3/s)' 219 END IF 220 221 END IF 222 223 IF( lp_obc_north ) THEN 224 225 ! ... correction of the north velocity 226 DO jj = fs_njn0, fs_njn1 ! Vector opt. 227 DO jk = 1, jpkm1 228 DO ji = 1, jpi 229 va(ji,jj,jk) = va(ji,jj,jk) + zubtpecor*vnmsk(ji,jk) 230 ztransn= ztransn + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vnmsk(ji,jk) * & 231 & MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 232 END DO 233 END DO 234 END DO 235 IF( lk_mpp ) CALL mpp_sum( ztransn ) ! sum over the global domain 236 237 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 238 IF(lwp) WRITE(numout,*)' North OB transport ztransn :', ztransn,'(m3/s)' 239 END IF 240 241 END IF 242 243 IF( lp_obc_south ) THEN 244 245 ! ... correction of the south velocity 246 DO jj = fs_njs0, fs_njs1 ! Vector opt. 247 DO jk = 1, jpkm1 248 DO ji = 1, jpi 249 va(ji,jj,jk) = va(ji,jj,jk) - zubtpecor*vsmsk(ji,jk) 250 ztranss= ztranss + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vsmsk(ji,jk) * & 251 & MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 252 END DO 253 END DO 254 END DO 255 IF( lk_mpp ) CALL mpp_sum( ztranss ) ! sum over the global domain 256 257 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 258 IF(lwp) WRITE(numout,*)' South OB transport ztranss :', ztranss,'(m3/s)' 259 END IF 260 261 END IF 262 263 ! 5. Check the cumulate transport through OBC 264 ! once barotropic velocities corrected 265 ! ------------------------------------------- 266 267 268 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 269 ztranst = ztransw - ztranse + ztranss - ztransn 270 IF(lwp) WRITE(numout,*)' ' 271 IF(lwp) WRITE(numout,*)' Cumulate transport ztranst =', ztranst,'(m3/s)' 272 IF(lwp) WRITE(numout,*)' Balance =', ztranst - zCflxemp ,'(m3/s)' 273 IF(lwp) WRITE(numout,*)' ' 274 END IF 164 275 165 276 END SUBROUTINE obc_vol 166 277 167 278 #else 168 !!---------------------------------------------------------------------- 169 !! Dummy module NO Unstruct Open Boundary Conditions170 !!---------------------------------------------------------------------- 279 !!--------------------------------------------------------------------------------- 280 !! Default option : Empty module 281 !!--------------------------------------------------------------------------------- 171 282 CONTAINS 172 SUBROUTINE obc_vol( kt ) ! Empty routine 173 WRITE(*,*) 'obc_vol: You should not have seen this print! error?', kt 283 SUBROUTINE obc_vol ! Empty routine 174 284 END SUBROUTINE obc_vol 175 285 #endif 176 286 177 !!====================================================================== 287 !!================================================================================= 178 288 END MODULE obcvol -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2865 r2888 649 649 !! using a general mapping (for open boundaries) 650 650 !!---------------------------------------------------------------------- 651 #if defined key_ obc652 USE obc_oce, ONLY: dta_global ! workspace to read in global data arrays651 #if defined key_bdy 652 USE bdy_oce, ONLY: dta_global ! workspace to read in global data arrays 653 653 #endif 654 654 … … 669 669 !!--------------------------------------------------------------------- 670 670 671 #if defined key_ obc671 #if defined key_bdy 672 672 dta_read => dta_global 673 673 #endif -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r2797 r2888 38 38 USE sbcfwb ! surface boundary condition: freshwater budget 39 39 USE closea ! closed sea 40 USE obc_par ! for lk_obc41 USE obcice_lim2 ! unstructured open boundary data (obc_ice_lim_2 routine)40 USE bdy_par ! for lk_bdy 41 USE bdyice_lim2 ! unstructured open boundary data (bdy_ice_lim_2 routine) 42 42 43 43 USE prtctl ! Print control (prt_ctl routine) … … 253 253 ! 254 254 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 255 IF( lk_ obc ) CALL obc_ice_lim_2( kt ) ! OBCboundary condition255 IF( lk_bdy ) CALL bdy_ice_lim_2( kt ) ! BDY boundary condition 256 256 ! 257 257 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SOL/solmat.F90
r2797 r2888 27 27 USE phycst ! physical constants 28 28 USE obc_oce ! ocean open boundary conditions 29 USE bdy_oce ! unstructured open boundary conditions 29 30 USE lbclnk ! lateral boudary conditions 30 31 USE lib_mpp ! distributed memory computing … … 80 81 ENDIF 81 82 82 #if defined key_dynspg_flt 83 #if defined key_dynspg_flt && ! defined key_bdy 83 84 # if ! defined key_obc 84 85 … … 98 99 END DO 99 100 END DO 100 101 101 # else 102 103 ! defined gcdmat in the case of open boundaries 102 IF ( Agrif_Root() ) THEN 103 DO jj = 2, jpjm1 ! matrix of free surface elliptic system with open boundaries 104 DO ji = 2, jpim1 105 zcoef = z2dt * z2dt * grav * bmask(ji,jj) 106 ! ! south coefficient 107 IF( lp_obc_south .AND. ( jj == njs0p1 ) ) THEN 108 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1)*(1.-vsmsk(ji,1)) 109 ELSE 110 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 111 END IF 112 gcp(ji,jj,1) = zcoefs 113 ! 114 ! ! west coefficient 115 IF( lp_obc_west .AND. ( ji == niw0p1 ) ) THEN 116 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj)*(1.-uwmsk(jj,1)) 117 ELSE 118 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 119 END IF 120 gcp(ji,jj,2) = zcoefw 121 ! 122 ! ! east coefficient 123 IF( lp_obc_east .AND. ( ji == nie0 ) ) THEN 124 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj)*(1.-uemsk(jj,1)) 125 ELSE 126 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 127 END IF 128 gcp(ji,jj,3) = zcoefe 129 ! 130 ! ! north coefficient 131 IF( lp_obc_north .AND. ( jj == njn0 ) ) THEN 132 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj)*(1.-vnmsk(ji,1)) 133 ELSE 134 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 135 END IF 136 gcp(ji,jj,4) = zcoefn 137 ! 138 ! ! diagonal coefficient 139 gcdmat(ji,jj) = e1t(ji,jj)*e2t(ji,jj)*bmask(ji,jj) & 140 & - zcoefs -zcoefw -zcoefe -zcoefn 141 END DO 142 END DO 143 ELSE 144 DO jj = 2, jpjm1 ! matrix of free surface elliptic system 145 DO ji = 2, jpim1 146 zcoef = z2dt * z2dt * grav * bmask(ji,jj) 147 zcoefs = -zcoef * hv(ji ,jj-1) * e1v(ji ,jj-1) / e2v(ji ,jj-1) ! south coefficient 148 zcoefw = -zcoef * hu(ji-1,jj ) * e2u(ji-1,jj ) / e1u(ji-1,jj ) ! west coefficient 149 zcoefe = -zcoef * hu(ji ,jj ) * e2u(ji ,jj ) / e1u(ji ,jj ) ! east coefficient 150 zcoefn = -zcoef * hv(ji ,jj ) * e1v(ji ,jj ) / e2v(ji ,jj ) ! north coefficient 151 gcp(ji,jj,1) = zcoefs 152 gcp(ji,jj,2) = zcoefw 153 gcp(ji,jj,3) = zcoefe 154 gcp(ji,jj,4) = zcoefn 155 gcdmat(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * bmask(ji,jj) & ! diagonal coefficient 156 & - zcoefs -zcoefw -zcoefe -zcoefn 157 END DO 158 END DO 159 ENDIF 160 # endif 161 162 # elif defined key_dynspg_flt && defined key_bdy 163 164 ! defined gcdmat in the case of unstructured open boundaries 104 165 DO jj = 2, jpjm1 105 166 DO ji = 2, jpim1 … … 108 169 ! south coefficient 109 170 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 110 zcoefs = zcoefs * obcvmask(ji,jj-1)171 zcoefs = zcoefs * bdyvmask(ji,jj-1) 111 172 gcp(ji,jj,1) = zcoefs 112 173 113 174 ! west coefficient 114 175 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 115 zcoefw = zcoefw * obcumask(ji-1,jj)176 zcoefw = zcoefw * bdyumask(ji-1,jj) 116 177 gcp(ji,jj,2) = zcoefw 117 178 118 179 ! east coefficient 119 180 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 120 zcoefe = zcoefe * obcumask(ji,jj)181 zcoefe = zcoefe * bdyumask(ji,jj) 121 182 gcp(ji,jj,3) = zcoefe 122 183 123 184 ! north coefficient 124 185 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 125 zcoefn = zcoefn * obcvmask(ji,jj)186 zcoefn = zcoefn * bdyvmask(ji,jj) 126 187 gcp(ji,jj,4) = zcoefn 127 188 … … 132 193 END DO 133 194 134 #endif135 195 #endif 136 196 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r2797 r2888 36 36 USE obc_oce 37 37 USE obctra ! open boundary condition (obc_tra routine) 38 USE bdy_oce 39 USE bdytra ! open boundary condition (bdy_tra routine) 38 40 USE in_out_manager ! I/O manager 39 41 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 107 109 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 108 110 ! 109 #if defined key_obc || defined key_ agrif111 #if defined key_obc || defined key_bdy || defined key_agrif 110 112 CALL tra_unswap 111 113 #endif … … 114 116 IF( lk_obc ) CALL obc_tra( kt ) ! OBC open boundaries 115 117 #endif 118 #if defined key_bdy 119 IF( lk_bdy ) CALL bdy_tra( kt ) ! BDY open boundaries 120 #endif 116 121 #if defined key_agrif 117 122 CALL Agrif_tra ! AGRIF zoom boundaries 118 123 #endif 119 124 120 #if defined key_obc || defined key_ agrif125 #if defined key_obc || defined key_bdy || defined key_agrif 121 126 CALL tra_swap 122 127 #endif -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2814 r2888 45 45 USE mppini ! shared/distributed memory setting (mpp_init routine) 46 46 USE domain ! domain initialization (dom_init routine) 47 USE obcini ! open boundary cond. initialization (obc_init routine) 48 USE obcdta ! open boundary cond. initialization (obc_dta_init routine) 49 USE obctides ! open boundary cond. initialization (tide_init routine) 47 USE obcini ! open boundary cond. initialization (obc_ini routine) 48 USE bdyini ! open boundary cond. initialization (bdy_init routine) 49 USE bdydta ! open boundary cond. initialization (bdy_dta_init routine) 50 USE bdytides ! open boundary cond. initialization (tide_init routine) 50 51 USE istate ! initial state setting (istate_init routine) 51 52 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) … … 295 296 IF( ln_ctl ) CALL prt_ctl_init ! Print control 296 297 297 IF( lk_obc ) CALL obc_init ! Open boundaries initialisation 298 IF( lk_obc ) CALL obc_dta_init ! Open boundaries initialisation of external data arrays 299 IF( lk_obc ) CALL tide_init ! Open boundaries initialisation of tidal harmonic forcing 298 IF( lk_obc ) CALL obc_init ! Open boundaries 299 IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation 300 IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays 301 IF( lk_bdy ) CALL tide_init ! Open boundaries initialisation of tidal harmonic forcing 300 302 301 303 CALL istate_init ! ocean initial state (Dynamics and tracers) -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step.F90
r2865 r2888 97 97 IF( lk_dtasal ) CALL dta_sal( kstp ) ! update 3D salinity data 98 98 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) 99 IF( lk_obc ) CALL obc_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 99 IF( lk_obc ) CALL obc_dta( kstp ) ! update dynamic and tracer data at open boundaries 100 IF( lk_obc ) CALL obc_rad( kstp ) ! compute phase velocities at open boundaries 101 IF( lk_bdy ) CALL bdy_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 100 102 101 103 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 245 247 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 246 248 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file 249 IF( lk_obc ) CALL obc_rst_write( kstp ) ! write open boundary restart file 247 250 248 251 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r2797 r2888 48 48 USE dynnxt ! time-stepping (dyn_nxt routine) 49 49 50 USE obc_par ! for lk_obc50 USE obc_par ! open boundary condition variables 51 51 USE obcdta ! open boundary condition data (obc_dta routine) 52 USE obcrst ! open boundary cond. restart (obc_rst routine) 53 USE obcrad ! open boundary cond. radiation (obc_rad routine) 54 55 USE bdy_par ! for lk_bdy 56 USE bdydta ! open boundary condition data (bdy_dta routine) 52 57 53 58 USE sshwzv ! vertical velocity and ssh (ssh_wzv routine)
Note: See TracChangeset
for help on using the changeset viewer.