Changeset 12143 for NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE
- Timestamp:
- 2019-12-10T12:57:49+01:00 (4 years ago)
- Location:
- NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE
- Files:
-
- 3 deleted
- 108 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ASM/asminc.F90
r10425 r12143 147 147 REWIND( numnam_ref ) ! Namelist nam_asminc in reference namelist : Assimilation increment 148 148 READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) 149 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' , lwp)149 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) 150 150 REWIND( numnam_cfg ) ! Namelist nam_asminc in configuration namelist : Assimilation increment 151 151 READ ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) 152 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' , lwp)152 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) 153 153 IF(lwm) WRITE ( numond, nam_asminc ) 154 154 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdy_oce.F90
r10934 r12143 22 22 INTEGER , DIMENSION(jpbgrd) :: nblen 23 23 INTEGER , DIMENSION(jpbgrd) :: nblenrim 24 INTEGER , DIMENSION(jpbgrd) :: nblenrim0 24 25 INTEGER , POINTER, DIMENSION(:,:) :: nbi 25 26 INTEGER , POINTER, DIMENSION(:,:) :: nbj 26 27 INTEGER , POINTER, DIMENSION(:,:) :: nbr 27 28 INTEGER , POINTER, DIMENSION(:,:) :: nbmap 29 INTEGER , POINTER, DIMENSION(:,:) :: ntreat 28 30 REAL(wp), POINTER, DIMENSION(:,:) :: nbw 29 31 REAL(wp), POINTER, DIMENSION(:,:) :: nbd … … 40 42 TYPE, PUBLIC :: OBC_DATA !: Storage for external data 41 43 INTEGER , DIMENSION(2) :: nread 42 LOGICAL :: ll_ssh 43 LOGICAL :: ll_u2d 44 LOGICAL :: ll_v2d 45 LOGICAL :: ll_u3d 46 LOGICAL :: ll_v3d 47 LOGICAL :: ll_tem 48 LOGICAL :: ll_sal 49 LOGICAL :: ll_fvl 44 LOGICAL :: lneed_ssh 45 LOGICAL :: lneed_dyn2d 46 LOGICAL :: lneed_dyn3d 47 LOGICAL :: lneed_tra 48 LOGICAL :: lneed_ice 50 49 REAL(wp), POINTER, DIMENSION(:) :: ssh 51 50 REAL(wp), POINTER, DIMENSION(:) :: u2d … … 55 54 REAL(wp), POINTER, DIMENSION(:,:) :: tem 56 55 REAL(wp), POINTER, DIMENSION(:,:) :: sal 57 #if defined key_si3 58 LOGICAL :: ll_a_i 59 LOGICAL :: ll_h_i 60 LOGICAL :: ll_h_s 61 REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 62 REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology 63 REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness 64 #endif 56 REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 57 REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology 58 REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness 59 REAL(wp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature 60 REAL(wp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature 61 REAL(wp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature 62 REAL(wp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity 63 REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration 64 REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth 65 65 #if defined key_top 66 66 CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply … … 74 74 !! Namelist variables 75 75 !!---------------------------------------------------------------------- 76 ! !!** nambdy ** 76 77 LOGICAL, PUBLIC :: ln_bdy !: Unstructured Ocean Boundary Condition 77 78 … … 85 86 ! 86 87 INTEGER :: nb_bdy !: number of open boundary sets 87 INTEGER, DIMENSION(jp_bdy) :: nb_jpk_bdy !: number of levels in the bdy data (set < 0 if consistent with planned run)88 88 INTEGER, DIMENSION(jp_bdy) :: nn_rimwidth !: boundary rim width for Flow Relaxation Scheme 89 89 INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P … … 108 108 INTEGER , DIMENSION(jp_bdy) :: nn_ice_dta !: = 0 use the initial state as bdy dta ; 109 109 !: = 1 read it in a NetCDF file 110 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_tem !: choice of the temperature of incoming sea ice 111 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_sal !: choice of the salinity of incoming sea ice 112 REAL(wp), DIMENSION(jp_bdy) :: rn_ice_age !: choice of the age of incoming sea ice 110 ! 111 ! !!** nambdy_dta ** 112 REAL(wp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice 113 REAL(wp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice 114 REAL(wp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice 115 REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice 116 REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice 113 117 ! 114 115 118 !!---------------------------------------------------------------------- 116 119 !! Global variables … … 128 131 INTEGER, DIMENSION(jp_bdy) :: nn_dta !: =0 => *all* data is set to initial conditions 129 132 !: =1 => some data to be read in from data files 130 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global !: workspace for reading in global data arrays (unstr. bdy)131 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_z !: workspace for reading in global depth arrays (unstr. bdy)132 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_dz !: workspace for reading in global depth arrays (unstr. bdy)133 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2 !: workspace for reading in global data arrays (struct. bdy)134 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_z !: workspace for reading in global depth arrays (struct. bdy)135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_dz !: workspace for reading in global depth arrays (struct. bdy)136 133 !$AGRIF_DO_NOT_TREAT 137 134 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) 138 135 TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) 139 136 !$AGRIF_END_DO_NOT_TREAT 137 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdy !: mark needed communication for given boundary, grid and neighbour 138 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdy !: when searching in any direction 139 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyint !: mark needed communication for given boundary, grid and neighbour 140 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyint !: when searching towards the interior of the computational domain 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyext !: mark needed communication for given boundary, grid and neighbour 142 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyext !: when searching towards the exterior of the computational domain 140 143 !!---------------------------------------------------------------------- 141 144 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdydta.F90
r11229 r12143 43 43 PUBLIC bdy_dta_init ! routine called by nemogcm.F90 44 44 45 INTEGER, ALLOCATABLE, DIMENSION(:) :: nb_bdy_fld ! Number of fields to update for each boundary set. 46 INTEGER :: nb_bdy_fld_sum ! Total number of fields to update for all boundary sets. 47 LOGICAL, DIMENSION(jp_bdy) :: ln_full_vel_array ! =T => full velocities in 3D boundary conditions 48 ! =F => baroclinic velocities in 3D boundary conditions 45 INTEGER , PARAMETER :: jpbdyfld = 16 ! maximum number of files to read 46 INTEGER , PARAMETER :: jp_bdyssh = 1 ! 47 INTEGER , PARAMETER :: jp_bdyu2d = 2 ! 48 INTEGER , PARAMETER :: jp_bdyv2d = 3 ! 49 INTEGER , PARAMETER :: jp_bdyu3d = 4 ! 50 INTEGER , PARAMETER :: jp_bdyv3d = 5 ! 51 INTEGER , PARAMETER :: jp_bdytem = 6 ! 52 INTEGER , PARAMETER :: jp_bdysal = 7 ! 53 INTEGER , PARAMETER :: jp_bdya_i = 8 ! 54 INTEGER , PARAMETER :: jp_bdyh_i = 9 ! 55 INTEGER , PARAMETER :: jp_bdyh_s = 10 ! 56 INTEGER , PARAMETER :: jp_bdyt_i = 11 ! 57 INTEGER , PARAMETER :: jp_bdyt_s = 12 ! 58 INTEGER , PARAMETER :: jp_bdytsu = 13 ! 59 INTEGER , PARAMETER :: jp_bdys_i = 14 ! 60 INTEGER , PARAMETER :: jp_bdyaip = 15 ! 61 INTEGER , PARAMETER :: jp_bdyhip = 16 ! 62 #if ! defined key_si3 63 INTEGER , PARAMETER :: jpl = 1 64 #endif 65 49 66 !$AGRIF_DO_NOT_TREAT 50 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(: ), TARGET :: bf! structure of input fields (file informations, fields read)67 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: bf ! structure of input fields (file informations, fields read) 51 68 !$AGRIF_END_DO_NOT_TREAT 52 TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr ! array of pointers to nbmap53 54 #if defined key_si355 INTEGER :: nice_cat ! number of categories in the input file56 INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure57 INTEGER, DIMENSION(jp_bdy) :: jfld_htit, jfld_htst, jfld_ait58 #endif59 69 60 70 !!---------------------------------------------------------------------- … … 65 75 CONTAINS 66 76 67 SUBROUTINE bdy_dta( kt, jit, time_offset )77 SUBROUTINE bdy_dta( kt, kit, kt_offset ) 68 78 !!---------------------------------------------------------------------- 69 79 !! *** SUBROUTINE bdy_dta *** … … 75 85 !!---------------------------------------------------------------------- 76 86 INTEGER, INTENT(in) :: kt ! ocean time-step index 77 INTEGER, INTENT(in), OPTIONAL :: jit ! subcycle time-step index (for timesplitting option)78 INTEGER, INTENT(in), OPTIONAL :: time_offset ! time offset in units of timesteps. NB. if jit87 INTEGER, INTENT(in), OPTIONAL :: kit ! subcycle time-step index (for timesplitting option) 88 INTEGER, INTENT(in), OPTIONAL :: kt_offset ! time offset in units of timesteps. NB. if kit 79 89 ! ! is present then units = subcycle timesteps. 80 ! ! time_offset = 0 => get data at "now" time level81 ! ! time_offset = -1 => get data at "before" time level82 ! ! time_offset = +1 => get data at "after" time level90 ! ! kt_offset = 0 => get data at "now" time level 91 ! ! kt_offset = -1 => get data at "before" time level 92 ! ! kt_offset = +1 => get data at "after" time level 83 93 ! ! etc. 84 94 ! 85 INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices 86 INTEGER :: ii, ij, ik, igrd ! local integers 87 INTEGER, DIMENSION(jpbgrd) :: ilen1 88 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 89 TYPE(OBC_DATA), POINTER :: dta ! short cut 95 INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices 96 INTEGER :: ii, ij, ik, igrd, ipl ! local integers 97 INTEGER, DIMENSION(jpbgrd) :: ilen1 98 INTEGER, DIMENSION(:), POINTER :: nblen, nblenrim ! short cuts 99 TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut 100 TYPE(FLD), DIMENSION(:), POINTER :: bf_alias 90 101 !!--------------------------------------------------------------------------- 91 102 ! … … 94 105 ! Initialise data arrays once for all from initial conditions where required 95 106 !--------------------------------------------------------------------------- 96 IF( kt == nit000 .AND. .NOT.PRESENT( jit) ) THEN107 IF( kt == nit000 .AND. .NOT.PRESENT(kit) ) THEN 97 108 98 109 ! Calculate depth-mean currents 99 110 !----------------------------- 100 111 101 112 DO jbdy = 1, nb_bdy 102 113 ! 103 114 nblen => idx_bdy(jbdy)%nblen 104 115 nblenrim => idx_bdy(jbdy)%nblenrim 105 dta => dta_bdy(jbdy)106 116 ! 107 117 IF( nn_dyn2d_dta(jbdy) == 0 ) THEN 108 118 ilen1(:) = nblen(:) 109 IF( dta %ll_ssh ) THEN119 IF( dta_bdy(jbdy)%lneed_ssh ) THEN 110 120 igrd = 1 111 121 DO ib = 1, ilen1(igrd) … … 113 123 ij = idx_bdy(jbdy)%nbj(ib,igrd) 114 124 dta_bdy(jbdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1) 115 END DO 116 ENDIF 117 IF( dta %ll_u2d) THEN125 END DO 126 ENDIF 127 IF( dta_bdy(jbdy)%lneed_dyn2d) THEN 118 128 igrd = 2 119 129 DO ib = 1, ilen1(igrd) … … 121 131 ij = idx_bdy(jbdy)%nbj(ib,igrd) 122 132 dta_bdy(jbdy)%u2d(ib) = un_b(ii,ij) * umask(ii,ij,1) 123 END DO 124 ENDIF 125 IF( dta%ll_v2d ) THEN 133 END DO 126 134 igrd = 3 127 135 DO ib = 1, ilen1(igrd) … … 129 137 ij = idx_bdy(jbdy)%nbj(ib,igrd) 130 138 dta_bdy(jbdy)%v2d(ib) = vn_b(ii,ij) * vmask(ii,ij,1) 131 END DO 139 END DO 132 140 ENDIF 133 141 ENDIF … … 135 143 IF( nn_dyn3d_dta(jbdy) == 0 ) THEN 136 144 ilen1(:) = nblen(:) 137 IF( dta %ll_u3d ) THEN145 IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN 138 146 igrd = 2 139 147 DO ib = 1, ilen1(igrd) … … 143 151 dta_bdy(jbdy)%u3d(ib,ik) = ( un(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik) 144 152 END DO 145 END DO 146 ENDIF 147 IF( dta%ll_v3d ) THEN 153 END DO 148 154 igrd = 3 149 155 DO ib = 1, ilen1(igrd) … … 152 158 ij = idx_bdy(jbdy)%nbj(ib,igrd) 153 159 dta_bdy(jbdy)%v3d(ib,ik) = ( vn(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik) 154 155 END DO 160 END DO 161 END DO 156 162 ENDIF 157 163 ENDIF … … 159 165 IF( nn_tra_dta(jbdy) == 0 ) THEN 160 166 ilen1(:) = nblen(:) 161 IF( dta %ll_tem) THEN167 IF( dta_bdy(jbdy)%lneed_tra ) THEN 162 168 igrd = 1 163 169 DO ib = 1, ilen1(igrd) … … 166 172 ij = idx_bdy(jbdy)%nbj(ib,igrd) 167 173 dta_bdy(jbdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik) 168 END DO169 END DO170 ENDIF171 IF( dta%ll_sal ) THEN172 igrd = 1173 DO ib = 1, ilen1(igrd)174 DO ik = 1, jpkm1175 ii = idx_bdy(jbdy)%nbi(ib,igrd)176 ij = idx_bdy(jbdy)%nbj(ib,igrd)177 174 dta_bdy(jbdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik) 178 175 END DO 179 END DO 176 END DO 180 177 ENDIF 181 178 ENDIF … … 184 181 IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values 185 182 ilen1(:) = nblen(:) 186 IF( dta %ll_a_i) THEN183 IF( dta_bdy(jbdy)%lneed_ice ) THEN 187 184 igrd = 1 188 185 DO jl = 1, jpl … … 190 187 ii = idx_bdy(jbdy)%nbi(ib,igrd) 191 188 ij = idx_bdy(jbdy)%nbj(ib,igrd) 192 dta_bdy(jbdy)%a_i (ib,jl) = a_i(ii,ij,jl) * tmask(ii,ij,1) 193 END DO 194 END DO 195 ENDIF 196 IF( dta%ll_h_i ) THEN 197 igrd = 1 198 DO jl = 1, jpl 199 DO ib = 1, ilen1(igrd) 200 ii = idx_bdy(jbdy)%nbi(ib,igrd) 201 ij = idx_bdy(jbdy)%nbj(ib,igrd) 202 dta_bdy(jbdy)%h_i (ib,jl) = h_i(ii,ij,jl) * tmask(ii,ij,1) 203 END DO 204 END DO 205 ENDIF 206 IF( dta%ll_h_s ) THEN 207 igrd = 1 208 DO jl = 1, jpl 209 DO ib = 1, ilen1(igrd) 210 ii = idx_bdy(jbdy)%nbi(ib,igrd) 211 ij = idx_bdy(jbdy)%nbj(ib,igrd) 212 dta_bdy(jbdy)%h_s (ib,jl) = h_s(ii,ij,jl) * tmask(ii,ij,1) 189 dta_bdy(jbdy)%a_i(ib,jl) = a_i (ii,ij,jl) * tmask(ii,ij,1) 190 dta_bdy(jbdy)%h_i(ib,jl) = h_i (ii,ij,jl) * tmask(ii,ij,1) 191 dta_bdy(jbdy)%h_s(ib,jl) = h_s (ii,ij,jl) * tmask(ii,ij,1) 192 dta_bdy(jbdy)%t_i(ib,jl) = SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1) 193 dta_bdy(jbdy)%t_s(ib,jl) = SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) 194 dta_bdy(jbdy)%tsu(ib,jl) = t_su(ii,ij,jl) * tmask(ii,ij,1) 195 dta_bdy(jbdy)%s_i(ib,jl) = s_i (ii,ij,jl) * tmask(ii,ij,1) 196 ! melt ponds 197 dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) 198 dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) 213 199 END DO 214 200 END DO … … 222 208 ! update external data from files 223 209 !-------------------------------- 224 225 jstart = 1 226 DO jbdy = 1, nb_bdy 227 dta => dta_bdy(jbdy) 228 IF( nn_dta(jbdy) == 1 ) THEN ! skip this bit if no external data required 229 230 IF( PRESENT(jit) ) THEN 231 ! Update barotropic boundary conditions only 232 ! jit is optional argument for fld_read and bdytide_update 233 IF( cn_dyn2d(jbdy) /= 'none' ) THEN 234 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 235 IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 236 IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 237 IF( dta%ll_u3d ) dta%v2d(:) = 0._wp 238 ENDIF 239 IF (cn_tra(jbdy) /= 'runoff') THEN 240 IF( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) THEN 241 242 jend = jstart + dta%nread(2) - 1 243 IF( ln_full_vel_array(jbdy) ) THEN 244 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 245 & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy(jbdy), & 246 & fvl=ln_full_vel_array(jbdy) ) 247 ELSE 248 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 249 & kit=jit, kt_offset=time_offset ) 250 ENDIF 251 252 ! If full velocities in boundary data then extract barotropic velocities from 3D fields 253 IF( ln_full_vel_array(jbdy) .AND. & 254 & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 255 & nn_dyn3d_dta(jbdy) == 1 ) )THEN 256 257 igrd = 2 ! zonal velocity 258 dta%u2d(:) = 0._wp 259 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 260 ii = idx_bdy(jbdy)%nbi(ib,igrd) 261 ij = idx_bdy(jbdy)%nbj(ib,igrd) 262 DO ik = 1, jpkm1 263 dta%u2d(ib) = dta%u2d(ib) & 264 & + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 265 END DO 266 dta%u2d(ib) = dta%u2d(ib) * r1_hu_n(ii,ij) 267 END DO 268 igrd = 3 ! meridional velocity 269 dta%v2d(:) = 0._wp 270 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 271 ii = idx_bdy(jbdy)%nbi(ib,igrd) 272 ij = idx_bdy(jbdy)%nbj(ib,igrd) 273 DO ik = 1, jpkm1 274 dta%v2d(ib) = dta%v2d(ib) & 275 & + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 276 END DO 277 dta%v2d(ib) = dta%v2d(ib) * r1_hv_n(ii,ij) 278 END DO 279 ENDIF 280 ENDIF 281 IF( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN ! update tidal harmonic forcing 282 CALL bdytide_update( kt=kt, idx=idx_bdy(jbdy), dta=dta, td=tides(jbdy), & 283 & jit=jit, time_offset=time_offset ) 284 ENDIF 285 ENDIF 286 ENDIF 287 ELSE 288 IF (cn_tra(jbdy) == 'runoff') then ! runoff condition 289 jend = nb_bdy_fld(jbdy) 290 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 291 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) 292 ! 293 igrd = 2 ! zonal velocity 294 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 295 ii = idx_bdy(jbdy)%nbi(ib,igrd) 296 ij = idx_bdy(jbdy)%nbj(ib,igrd) 297 dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 298 END DO 299 ! 300 igrd = 3 ! meridional velocity 301 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 302 ii = idx_bdy(jbdy)%nbi(ib,igrd) 303 ij = idx_bdy(jbdy)%nbj(ib,igrd) 304 dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 305 END DO 306 ELSE 307 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 308 IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 309 IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 310 IF( dta%ll_v2d ) dta%v2d(:) = 0._wp 311 ENDIF 312 IF( dta%nread(1) .gt. 0 ) THEN ! update external data 313 jend = jstart + dta%nread(1) - 1 314 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 315 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy(jbdy), & 316 & fvl=ln_full_vel_array(jbdy) ) 317 ENDIF 318 ! If full velocities in boundary data then split into barotropic and baroclinic data 319 IF( ln_full_vel_array(jbdy) .and. & 320 & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 321 & nn_dyn3d_dta(jbdy) == 1 ) ) THEN 322 igrd = 2 ! zonal velocity 323 dta%u2d(:) = 0._wp 324 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 325 ii = idx_bdy(jbdy)%nbi(ib,igrd) 326 ij = idx_bdy(jbdy)%nbj(ib,igrd) 327 DO ik = 1, jpkm1 328 dta%u2d(ib) = dta%u2d(ib) & 329 & + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 330 END DO 331 dta%u2d(ib) = dta%u2d(ib) * r1_hu_n(ii,ij) 332 DO ik = 1, jpkm1 333 dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 334 END DO 335 END DO 336 igrd = 3 ! meridional velocity 337 dta%v2d(:) = 0._wp 338 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 339 ii = idx_bdy(jbdy)%nbi(ib,igrd) 340 ij = idx_bdy(jbdy)%nbj(ib,igrd) 341 DO ik = 1, jpkm1 342 dta%v2d(ib) = dta%v2d(ib) & 343 & + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 344 END DO 345 dta%v2d(ib) = dta%v2d(ib) * r1_hv_n(ii,ij) 346 DO ik = 1, jpkm1 347 dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 348 END DO 349 END DO 350 ENDIF 351 352 ENDIF 210 211 DO jbdy = 1, nb_bdy 212 213 dta_alias => dta_bdy(jbdy) 214 bf_alias => bf(:,jbdy) 215 216 ! read/update all bdy data 217 ! ------------------------ 218 CALL fld_read( kt, 1, bf_alias, kit = kit, kt_offset = kt_offset ) 219 220 ! apply some corrections in some specific cases... 221 ! -------------------------------------------------- 222 ! 223 ! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s) 224 IF( cn_tra(jbdy) == 'runoff' .AND. TRIM(bf_alias(jp_bdyu2d)%clrootname) /= 'NOT USED' ) THEN ! runoff and we read u/v2d 225 ! 226 igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s) 227 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 228 ii = idx_bdy(jbdy)%nbi(ib,igrd) 229 ij = idx_bdy(jbdy)%nbj(ib,igrd) 230 dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 231 END DO 232 igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s) 233 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 234 ii = idx_bdy(jbdy)%nbi(ib,igrd) 235 ij = idx_bdy(jbdy)%nbj(ib,igrd) 236 dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 237 END DO 238 ENDIF 239 240 ! tidal harmonic forcing ONLY: initialise arrays 241 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d 242 IF( dta_alias%lneed_ssh ) dta_alias%ssh(:) = 0._wp 243 IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp 244 IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp 245 ENDIF 246 247 ! If full velocities in boundary data, then split it into barotropic and baroclinic component 248 IF( bf_alias(jp_bdyu3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if u3d was read) 249 ! 250 igrd = 2 ! zonal velocity 251 dta_alias%u2d(:) = 0._wp ! compute barotrope zonal velocity and put it in u2d 252 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 253 ii = idx_bdy(jbdy)%nbi(ib,igrd) 254 ij = idx_bdy(jbdy)%nbj(ib,igrd) 255 DO ik = 1, jpkm1 256 dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 257 END DO 258 dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu_n(ii,ij) 259 DO ik = 1, jpkm1 ! compute barocline zonal velocity and put it in u3d 260 dta_alias%u3d(ib,ik) = dta_alias%u3d(ib,ik) - dta_alias%u2d(ib) 261 END DO 262 END DO 263 igrd = 3 ! meridional velocity 264 dta_alias%v2d(:) = 0._wp ! compute barotrope meridional velocity and put it in v2d 265 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 266 ii = idx_bdy(jbdy)%nbi(ib,igrd) 267 ij = idx_bdy(jbdy)%nbj(ib,igrd) 268 DO ik = 1, jpkm1 269 dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 270 END DO 271 dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv_n(ii,ij) 272 DO ik = 1, jpkm1 ! compute barocline meridional velocity and put it in v3d 273 dta_alias%v3d(ib,ik) = dta_alias%v3d(ib,ik) - dta_alias%v2d(ib) 274 END DO 275 END DO 276 ENDIF ! ltotvel 277 278 ! update tidal harmonic forcing 279 IF( PRESENT(kit) .AND. nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 280 CALL bdytide_update( kt = kt, idx = idx_bdy(jbdy), dta = dta_alias, td = tides(jbdy), & 281 & kit = kit, kt_offset = kt_offset ) 282 ENDIF 283 284 ! atm surface pressure : add inverted barometer effect to ssh if it was read 285 IF ( ln_apr_obc .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN 286 igrd = 1 287 DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is used only on the rim 288 ii = idx_bdy(jbdy)%nbi(ib,igrd) 289 ij = idx_bdy(jbdy)%nbj(ib,igrd) 290 dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) 291 END DO 292 ENDIF 293 353 294 #if defined key_si3 354 ! convert N-cat fields (input) into jpl-cat (output) 355 IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 356 jfld_hti = jfld_htit(jbdy) 357 jfld_hts = jfld_htst(jbdy) 358 jfld_ai = jfld_ait(jbdy) 359 CALL ice_var_itd( bf(jfld_hti)%fnow(:,1,:), bf(jfld_hts)%fnow(:,1,:), bf(jfld_ai)%fnow(:,1,:), & 360 & dta_bdy(jbdy)%h_i , dta_bdy(jbdy)%h_s , dta_bdy(jbdy)%a_i ) 361 ENDIF 295 IF( dta_alias%lneed_ice ) THEN 296 ! fill temperature and salinity arrays 297 IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) 298 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_s)%fnow(:,1,:) = rice_tem (jbdy) 299 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 300 IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 301 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction 302 & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd * a_i ) 303 IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 304 ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 305 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 306 & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdytsu)%fnow(:,1,:) + 271.15 ) 307 ! if T_su is read and not T_s, set T_s = T_su 308 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & 309 & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdytsu)%fnow(:,1,:) 310 ! if T_s is read and not T_su, set T_su = T_s 311 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & 312 & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_s)%fnow(:,1,:) 313 ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 314 IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 315 & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdyt_s)%fnow(:,1,:) + 271.15 ) 316 317 ! make sure ponds = 0 if no ponds scheme 318 IF ( .NOT.ln_pnd ) THEN 319 bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 320 bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 321 ENDIF 322 323 ! convert N-cat fields (input) into jpl-cat (output) 324 ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) 325 IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) 326 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 327 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & 328 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 329 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 330 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), & 331 & dta_alias%t_i , dta_alias%t_s , & 332 & dta_alias%tsu , dta_alias%s_i , & 333 & dta_alias%aip , dta_alias%hip ) 334 ENDIF 335 ENDIF 362 336 #endif 363 ENDIF364 jstart = jstart + dta%nread(1)365 ENDIF ! nn_dta(jbdy) = 1366 337 END DO ! jbdy 367 368 IF ( ln_apr_obc ) THEN369 DO jbdy = 1, nb_bdy370 IF (cn_tra(jbdy) /= 'runoff')THEN371 igrd = 1 ! meridional velocity372 DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd)373 ii = idx_bdy(jbdy)%nbi(ib,igrd)374 ij = idx_bdy(jbdy)%nbj(ib,igrd)375 dta_bdy(jbdy)%ssh(ib) = dta_bdy(jbdy)%ssh(ib) + ssh_ib(ii,ij)376 END DO377 ENDIF378 END DO379 ENDIF380 338 381 339 IF ( ln_tide ) THEN 382 340 IF (ln_dynspg_ts) THEN ! Fill temporary arrays with slow-varying bdy data 383 DO jbdy = 1, nb_bdy ! Tidal component added in ts loop384 IF ( nn_dyn2d_dta(jbdy) . ge. 2 ) THEN341 DO jbdy = 1, nb_bdy ! Tidal component added in ts loop 342 IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 385 343 nblen => idx_bdy(jbdy)%nblen 386 344 nblenrim => idx_bdy(jbdy)%nblenrim 387 IF( cn_dyn2d(jbdy) == 'frs' ) THEN; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF 388 IF ( dta_bdy(jbdy)%ll_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 389 IF ( dta_bdy(jbdy)%ll_u2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 390 IF ( dta_bdy(jbdy)%ll_v2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 391 ENDIF 392 END DO 393 ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 394 ! 395 CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 396 ENDIF 397 ENDIF 398 399 ! 400 IF( ln_timing ) CALL timing_stop('bdy_dta') 401 ! 402 END SUBROUTINE bdy_dta 345 IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF 346 IF ( dta_bdy(jbdy)%lneed_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 347 IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 348 IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 349 ENDIF 350 END DO 351 ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 352 ! 353 CALL bdy_dta_tides( kt=kt, kt_offset=kt_offset ) 354 ENDIF 355 ENDIF 356 ! 357 IF( ln_timing ) CALL timing_stop('bdy_dta') 358 ! 359 END SUBROUTINE bdy_dta 403 360 404 361 … … 413 370 !! 414 371 !!---------------------------------------------------------------------- 415 INTEGER :: jbdy, jfld, jstart, jend, ierror, ios ! Local integers 372 INTEGER :: jbdy, jfld ! Local integers 373 INTEGER :: ierror, ios ! 416 374 ! 375 CHARACTER(len=3) :: cl3 ! 417 376 CHARACTER(len=100) :: cn_dir ! Root directory for location of data files 418 CHARACTER(len=100), DIMENSION(nb_bdy) :: cn_dir_array ! Root directory for location of data files419 CHARACTER(len = 256):: clname ! temporary file name420 377 LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data 421 378 ! ! =F => baroclinic velocities in 3D boundary data 422 INTEGER :: ilen_global ! Max length required for global bdy dta arrays423 INTEGER, ALLOCATABLE, DIMENSION(:) :: ilen1, ilen3 ! size of 1st and 3rd dimensions of local arrays424 INTEGER , ALLOCATABLE, DIMENSION(:) :: ibdy ! bdy set for a particular jfld425 INTEGER , ALLOCATABLE, DIMENSION(:) :: igrid ! index for grid type (1,2,3 = T,U,V)426 INTEGER , POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts427 TYPE(OBC_DATA), POINTER :: dta ! short cut428 #if defined key_si3 429 INTEGER :: kndims ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat)430 INTEGER, DIMENSION(4) :: kdimsz ! size of dimensions431 INTEGER :: inum,id1 ! local integer432 #endif 433 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: blf_i ! array of namelist information structures434 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d !435 TYPE(FLD_N) :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read436 #if defined key_si3 437 TYPE(FLD _N) :: bn_a_i, bn_h_i, bn_h_s438 #endif 379 LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta 380 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 381 INTEGER :: ipk,ipl ! 382 INTEGER :: idvar ! variable ID 383 INTEGER :: indims ! number of dimensions of the variable 384 INTEGER :: iszdim ! number of dimensions of the variable 385 INTEGER, DIMENSION(4) :: i4dimsz ! size of variable dimensions 386 INTEGER :: igrd ! index for grid type (1,2,3 = T,U,V) 387 LOGICAL :: lluld ! is the variable using the unlimited dimension 388 LOGICAL :: llneed ! 389 LOGICAL :: llread ! 390 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill 391 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 392 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 393 TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill 394 TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias 395 ! 439 396 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 440 #if defined key_si3 441 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 442 #endif 443 NAMELIST/nambdy_dta/ ln_full_vel 397 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 398 NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 399 NAMELIST/nambdy_dta/ ln_full_vel, ln_zinterp 444 400 !!--------------------------------------------------------------------------- 445 401 ! … … 449 405 IF(lwp) WRITE(numout,*) '' 450 406 451 ! Set nn_dta 452 DO jbdy = 1, nb_bdy 453 nn_dta(jbdy) = MAX( nn_dyn2d_dta (jbdy) & 454 & , nn_dyn3d_dta (jbdy) & 455 & , nn_tra_dta (jbdy) & 456 #if defined key_si3 457 & , nn_ice_dta (jbdy) & 458 #endif 459 ) 460 IF(nn_dta(jbdy) > 1) nn_dta(jbdy) = 1 461 END DO 462 463 ! Work out upper bound of how many fields there are to read in and allocate arrays 464 ! --------------------------------------------------------------------------- 465 ALLOCATE( nb_bdy_fld(nb_bdy) ) 466 nb_bdy_fld(:) = 0 467 DO jbdy = 1, nb_bdy 468 IF( cn_dyn2d(jbdy) /= 'none' .AND. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) THEN 469 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 470 ENDIF 471 IF( cn_dyn3d(jbdy) /= 'none' .AND. nn_dyn3d_dta(jbdy) == 1 ) THEN 472 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 473 ENDIF 474 IF( cn_tra(jbdy) /= 'none' .AND. nn_tra_dta(jbdy) == 1 ) THEN 475 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 476 ENDIF 477 #if defined key_si3 478 IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 479 nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 480 ENDIF 481 #endif 482 IF(lwp) WRITE(numout,*) 'Maximum number of files to open =', nb_bdy_fld(jbdy) 483 END DO 484 485 nb_bdy_fld_sum = SUM( nb_bdy_fld ) 486 487 ALLOCATE( bf(nb_bdy_fld_sum), STAT=ierror ) 407 ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) 488 408 IF( ierror > 0 ) THEN 489 409 CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' ) ; RETURN 490 410 ENDIF 491 ALLOCATE( blf_i(nb_bdy_fld_sum), STAT=ierror ) 492 IF( ierror > 0 ) THEN 493 CALL ctl_stop( 'bdy_dta: unable to allocate blf_i structure' ) ; RETURN 494 ENDIF 495 ALLOCATE( nbmap_ptr(nb_bdy_fld_sum), STAT=ierror ) 496 IF( ierror > 0 ) THEN 497 CALL ctl_stop( 'bdy_dta: unable to allocate nbmap_ptr structure' ) ; RETURN 498 ENDIF 499 ALLOCATE( ilen1(nb_bdy_fld_sum), ilen3(nb_bdy_fld_sum) ) 500 ALLOCATE( ibdy(nb_bdy_fld_sum) ) 501 ALLOCATE( igrid(nb_bdy_fld_sum) ) 502 411 bf(:,:)%clrootname = 'NOT USED' ! default definition used as a flag in fld_read to do nothing. 412 bf(:,:)%lzint = .FALSE. ! default definition 413 bf(:,:)%ltotvel = .FALSE. ! default definition 414 503 415 ! Read namelists 504 416 ! -------------- 505 417 REWIND(numnam_cfg) 506 jfld = 0 507 DO jbdy = 1, nb_bdy 508 IF( nn_dta(jbdy) == 1 ) THEN 509 REWIND(numnam_ref) 510 READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 511 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist', lwp ) 418 DO jbdy = 1, nb_bdy 419 420 WRITE(ctmp1, '(a,i2)') 'BDY number ', jbdy 421 WRITE(ctmp2, '(a,i2)') 'block nambdy_dta number ', jbdy 422 423 ! There is only one nambdy_dta block in namelist_ref -> use it for each bdy so we do a rewind 424 REWIND(numnam_ref) 425 READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist' ) 427 428 ! by-pass nambdy_dta reading if no input data used in this bdy 429 IF( ( dta_bdy(jbdy)%lneed_dyn2d .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ) & 430 & .OR. ( dta_bdy(jbdy)%lneed_dyn3d .AND. nn_dyn3d_dta(jbdy) == 1 ) & 431 & .OR. ( dta_bdy(jbdy)%lneed_tra .AND. nn_tra_dta(jbdy) == 1 ) & 432 & .OR. ( dta_bdy(jbdy)%lneed_ice .AND. nn_ice_dta(jbdy) == 1 ) ) THEN 433 ! WARNING: we don't do a rewind here, each bdy reads its own nambdy_dta block one after another 512 434 READ ( numnam_cfg, nambdy_dta, IOSTAT = ios, ERR = 902 ) 513 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist', lwp ) 514 IF(lwm) WRITE( numond, nambdy_dta ) 515 516 cn_dir_array(jbdy) = cn_dir 517 ln_full_vel_array(jbdy) = ln_full_vel 518 519 nblen => idx_bdy(jbdy)%nblen 520 nblenrim => idx_bdy(jbdy)%nblenrim 521 dta => dta_bdy(jbdy) 522 dta%nread(2) = 0 523 524 ! Only read in necessary fields for this set. 525 ! Important that barotropic variables come first. 526 IF( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 527 528 IF( dta%ll_ssh ) THEN 529 if(lwp) write(numout,*) '++++++ reading in ssh field' 530 jfld = jfld + 1 531 blf_i(jfld) = bn_ssh 532 ibdy(jfld) = jbdy 533 igrid(jfld) = 1 534 ilen1(jfld) = nblen(igrid(jfld)) 535 ilen3(jfld) = 1 536 dta%nread(2) = dta%nread(2) + 1 537 ENDIF 538 539 IF( dta%ll_u2d .and. .not. ln_full_vel_array(jbdy) ) THEN 540 if(lwp) write(numout,*) '++++++ reading in u2d field' 541 jfld = jfld + 1 542 blf_i(jfld) = bn_u2d 543 ibdy(jfld) = jbdy 544 igrid(jfld) = 2 545 ilen1(jfld) = nblen(igrid(jfld)) 546 ilen3(jfld) = 1 547 dta%nread(2) = dta%nread(2) + 1 548 ENDIF 549 550 IF( dta%ll_v2d .and. .not. ln_full_vel_array(jbdy) ) THEN 551 if(lwp) write(numout,*) '++++++ reading in v2d field' 552 jfld = jfld + 1 553 blf_i(jfld) = bn_v2d 554 ibdy(jfld) = jbdy 555 igrid(jfld) = 3 556 ilen1(jfld) = nblen(igrid(jfld)) 557 ilen3(jfld) = 1 558 dta%nread(2) = dta%nread(2) + 1 559 ENDIF 560 561 ENDIF 562 563 ! read 3D velocities if baroclinic velocities require OR if 564 ! barotropic velocities required and ln_full_vel set to .true. 565 IF( nn_dyn3d_dta(jbdy) == 1 .OR. & 566 & ( ln_full_vel_array(jbdy) .AND. ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 567 568 IF( dta%ll_u3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 569 if(lwp) write(numout,*) '++++++ reading in u3d field' 570 jfld = jfld + 1 571 blf_i(jfld) = bn_u3d 572 ibdy(jfld) = jbdy 573 igrid(jfld) = 2 574 ilen1(jfld) = nblen(igrid(jfld)) 575 ilen3(jfld) = jpk 576 IF( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 577 ENDIF 578 579 IF( dta%ll_v3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 580 if(lwp) write(numout,*) '++++++ reading in v3d field' 581 jfld = jfld + 1 582 blf_i(jfld) = bn_v3d 583 ibdy(jfld) = jbdy 584 igrid(jfld) = 3 585 ilen1(jfld) = nblen(igrid(jfld)) 586 ilen3(jfld) = jpk 587 IF( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 588 ENDIF 589 590 ENDIF 591 592 ! temperature and salinity 593 IF( nn_tra_dta(jbdy) == 1 ) THEN 594 595 IF( dta%ll_tem ) THEN 596 if(lwp) write(numout,*) '++++++ reading in tem field' 597 jfld = jfld + 1 598 blf_i(jfld) = bn_tem 599 ibdy(jfld) = jbdy 600 igrid(jfld) = 1 601 ilen1(jfld) = nblen(igrid(jfld)) 602 ilen3(jfld) = jpk 603 ENDIF 604 605 IF( dta%ll_sal ) THEN 606 if(lwp) write(numout,*) '++++++ reading in sal field' 607 jfld = jfld + 1 608 blf_i(jfld) = bn_sal 609 ibdy(jfld) = jbdy 610 igrid(jfld) = 1 611 ilen1(jfld) = nblen(igrid(jfld)) 612 ilen3(jfld) = jpk 613 ENDIF 614 615 ENDIF 435 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist' ) 436 IF(lwm) WRITE( numond, nambdy_dta ) 437 ENDIF 438 439 ! get the number of ice categories in bdy data file (use a_i information to do this) 440 ipl = jpl ! default definition 441 IF( dta_bdy(jbdy)%lneed_ice ) THEN ! if we need ice bdy data 442 IF( nn_ice_dta(jbdy) == 1 ) THEN ! if we get ice bdy data from netcdf file 443 CALL fld_fill( bf(jp_bdya_i,jbdy:jbdy), bn_a_i, cn_dir, 'bdy_dta', 'a_i'//' '//ctmp1, ctmp2 ) ! use namelist info 444 CALL fld_clopn( bf(jp_bdya_i,jbdy), nyear, nmonth, nday ) ! not a problem when we call it again after 445 idvar = iom_varid( bf(jp_bdya_i,jbdy)%num, bf(jp_bdya_i,jbdy)%clvar, kndims=indims, kdimsz=i4dimsz, lduld=lluld ) 446 IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipl = i4dimsz(3) ! xylt or xyl 447 ELSE ; ipl = 1 ! xy or xyt 448 ENDIF 449 bf(jp_bdya_i,jbdy)%clrootname = 'NOT USED' ! reset to default value as this subdomain may not need to read this bdy 450 ENDIF 451 ENDIF 616 452 617 453 #if defined key_si3 618 ! sea ice 619 IF( nn_ice_dta(jbdy) == 1 ) THEN 620 ! Test for types of ice input (1cat or Xcat) 621 ! Build file name to find dimensions 622 clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) 623 IF( .NOT. bn_a_i%ln_clim ) THEN 624 WRITE(clname, '(a,"_y",i4.4)' ) TRIM( clname ), nyear ! add year 625 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth ! add month 626 ELSE 627 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( clname ), nmonth ! add month 628 ENDIF 629 IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 630 & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), nday ! add day 454 IF( .NOT.ln_pnd ) THEN 455 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 456 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 457 ENDIF 458 #endif 459 460 ! temp, salt, age and ponds of incoming ice 461 rice_tem (jbdy) = rn_ice_tem 462 rice_sal (jbdy) = rn_ice_sal 463 rice_age (jbdy) = rn_ice_age 464 rice_apnd(jbdy) = rn_ice_apnd 465 rice_hpnd(jbdy) = rn_ice_hpnd 466 467 468 DO jfld = 1, jpbdyfld 469 470 ! ===================== 471 ! ssh 472 ! ===================== 473 IF( jfld == jp_bdyssh ) THEN 474 cl3 = 'ssh' 475 igrd = 1 ! T point 476 ipk = 1 ! surface data 477 llneed = dta_bdy(jbdy)%lneed_ssh ! dta_bdy(jbdy)%ssh will be needed 478 llread = MOD(nn_dyn2d_dta(jbdy),2) == 1 ! get data from NetCDF file 479 bf_alias => bf(jp_bdyssh,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 480 bn_alias => bn_ssh ! alias for ssh structure of nambdy_dta 481 iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! length of this bdy on this MPI processus : used only on the rim 482 ENDIF 483 ! ===================== 484 ! dyn2d 485 ! ===================== 486 IF( jfld == jp_bdyu2d ) THEN 487 cl3 = 'u2d' 488 igrd = 2 ! U point 489 ipk = 1 ! surface data 490 llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed 491 llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get u2d from u3d and read NetCDF file 492 bf_alias => bf(jp_bdyu2d,jbdy:jbdy) ! alias for u2d structure of bdy number jbdy 493 bn_alias => bn_u2d ! alias for u2d structure of nambdy_dta 494 IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from u3d -> need on the full bdy 495 ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim 496 ENDIF 497 ENDIF 498 IF( jfld == jp_bdyv2d ) THEN 499 cl3 = 'v2d' 500 igrd = 3 ! V point 501 ipk = 1 ! surface data 502 llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%ssh will be needed 503 llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get v2d from v3d and read NetCDF file 504 bf_alias => bf(jp_bdyv2d,jbdy:jbdy) ! alias for v2d structure of bdy number jbdy 505 bn_alias => bn_v2d ! alias for v2d structure of nambdy_dta 506 IF( ln_full_vel ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) ! will be computed from v3d -> need on the full bdy 507 ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! used only on the rim 508 ENDIF 509 ENDIF 510 ! ===================== 511 ! dyn3d 512 ! ===================== 513 IF( jfld == jp_bdyu3d ) THEN 514 cl3 = 'u3d' 515 igrd = 2 ! U point 516 ipk = jpk ! 3d data 517 llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%u3d will be needed 518 & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! u3d needed to compute u2d 519 llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file 520 bf_alias => bf(jp_bdyu3d,jbdy:jbdy) ! alias for u3d structure of bdy number jbdy 521 bn_alias => bn_u3d ! alias for u3d structure of nambdy_dta 522 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 523 ENDIF 524 IF( jfld == jp_bdyv3d ) THEN 525 cl3 = 'v3d' 526 igrd = 3 ! V point 527 ipk = jpk ! 3d data 528 llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%v3d will be needed 529 & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! v3d needed to compute v2d 530 llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file 531 bf_alias => bf(jp_bdyv3d,jbdy:jbdy) ! alias for v3d structure of bdy number jbdy 532 bn_alias => bn_v3d ! alias for v3d structure of nambdy_dta 533 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 534 ENDIF 535 536 ! ===================== 537 ! tra 538 ! ===================== 539 IF( jfld == jp_bdytem ) THEN 540 cl3 = 'tem' 541 igrd = 1 ! T point 542 ipk = jpk ! 3d data 543 llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%tem will be needed 544 llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file 545 bf_alias => bf(jp_bdytem,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 546 bn_alias => bn_tem ! alias for ssh structure of nambdy_dta 547 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 548 ENDIF 549 IF( jfld == jp_bdysal ) THEN 550 cl3 = 'sal' 551 igrd = 1 ! T point 552 ipk = jpk ! 3d data 553 llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%sal will be needed 554 llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file 555 bf_alias => bf(jp_bdysal,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy 556 bn_alias => bn_sal ! alias for ssh structure of nambdy_dta 557 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 558 ENDIF 559 560 ! ===================== 561 ! ice 562 ! ===================== 563 IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 564 & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 565 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip ) THEN 566 igrd = 1 ! T point 567 ipk = ipl ! jpl-cat data 568 llneed = dta_bdy(jbdy)%lneed_ice ! ice will be needed 569 llread = nn_ice_dta(jbdy) == 1 ! get data from NetCDF file 570 iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus 571 ENDIF 572 IF( jfld == jp_bdya_i ) THEN 573 cl3 = 'a_i' 574 bf_alias => bf(jp_bdya_i,jbdy:jbdy) ! alias for a_i structure of bdy number jbdy 575 bn_alias => bn_a_i ! alias for a_i structure of nambdy_dta 576 ENDIF 577 IF( jfld == jp_bdyh_i ) THEN 578 cl3 = 'h_i' 579 bf_alias => bf(jp_bdyh_i,jbdy:jbdy) ! alias for h_i structure of bdy number jbdy 580 bn_alias => bn_h_i ! alias for h_i structure of nambdy_dta 581 ENDIF 582 IF( jfld == jp_bdyh_s ) THEN 583 cl3 = 'h_s' 584 bf_alias => bf(jp_bdyh_s,jbdy:jbdy) ! alias for h_s structure of bdy number jbdy 585 bn_alias => bn_h_s ! alias for h_s structure of nambdy_dta 586 ENDIF 587 IF( jfld == jp_bdyt_i ) THEN 588 cl3 = 't_i' 589 bf_alias => bf(jp_bdyt_i,jbdy:jbdy) ! alias for t_i structure of bdy number jbdy 590 bn_alias => bn_t_i ! alias for t_i structure of nambdy_dta 591 ENDIF 592 IF( jfld == jp_bdyt_s ) THEN 593 cl3 = 't_s' 594 bf_alias => bf(jp_bdyt_s,jbdy:jbdy) ! alias for t_s structure of bdy number jbdy 595 bn_alias => bn_t_s ! alias for t_s structure of nambdy_dta 596 ENDIF 597 IF( jfld == jp_bdytsu ) THEN 598 cl3 = 'tsu' 599 bf_alias => bf(jp_bdytsu,jbdy:jbdy) ! alias for tsu structure of bdy number jbdy 600 bn_alias => bn_tsu ! alias for tsu structure of nambdy_dta 601 ENDIF 602 IF( jfld == jp_bdys_i ) THEN 603 cl3 = 's_i' 604 bf_alias => bf(jp_bdys_i,jbdy:jbdy) ! alias for s_i structure of bdy number jbdy 605 bn_alias => bn_s_i ! alias for s_i structure of nambdy_dta 606 ENDIF 607 IF( jfld == jp_bdyaip ) THEN 608 cl3 = 'aip' 609 bf_alias => bf(jp_bdyaip,jbdy:jbdy) ! alias for aip structure of bdy number jbdy 610 bn_alias => bn_aip ! alias for aip structure of nambdy_dta 611 ENDIF 612 IF( jfld == jp_bdyhip ) THEN 613 cl3 = 'hip' 614 bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy 615 bn_alias => bn_hip ! alias for hip structure of nambdy_dta 616 ENDIF 617 618 IF( llneed .AND. iszdim > 0 ) THEN ! dta_bdy(jbdy)%xxx will be needed 619 ! ! -> must be associated with an allocated target 620 ALLOCATE( bf_alias(1)%fnow( iszdim, 1, ipk ) ) ! allocate the target 631 621 ! 632 CALL iom_open ( clname, inum ) 633 id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=kdimsz, kndims=kndims, ldstop = .FALSE. ) 634 CALL iom_close ( inum ) 635 636 IF ( kndims == 4 ) THEN 637 nice_cat = kdimsz(4) ! Xcat input 638 ELSE 639 nice_cat = 1 ! 1cat input 640 ENDIF 641 ! End test 642 643 IF( dta%ll_a_i ) THEN 644 jfld = jfld + 1 645 blf_i(jfld) = bn_a_i 646 ibdy(jfld) = jbdy 647 igrid(jfld) = 1 648 ilen1(jfld) = nblen(igrid(jfld)) 649 ilen3(jfld) = nice_cat 650 ENDIF 651 652 IF( dta%ll_h_i ) THEN 653 jfld = jfld + 1 654 blf_i(jfld) = bn_h_i 655 ibdy(jfld) = jbdy 656 igrid(jfld) = 1 657 ilen1(jfld) = nblen(igrid(jfld)) 658 ilen3(jfld) = nice_cat 659 ENDIF 660 661 IF( dta%ll_h_s ) THEN 662 jfld = jfld + 1 663 blf_i(jfld) = bn_h_s 664 ibdy(jfld) = jbdy 665 igrid(jfld) = 1 666 ilen1(jfld) = nblen(igrid(jfld)) 667 ilen3(jfld) = nice_cat 668 ENDIF 669 670 ENDIF 671 #endif 672 ! Recalculate field counts 673 !------------------------- 674 IF( jbdy == 1 ) THEN 675 nb_bdy_fld_sum = 0 676 nb_bdy_fld(jbdy) = jfld 677 nb_bdy_fld_sum = jfld 678 ELSE 679 nb_bdy_fld(jbdy) = jfld - nb_bdy_fld_sum 680 nb_bdy_fld_sum = nb_bdy_fld_sum + nb_bdy_fld(jbdy) 681 ENDIF 682 683 dta%nread(1) = nb_bdy_fld(jbdy) 684 685 ENDIF ! nn_dta == 1 686 ENDDO ! jbdy 687 688 DO jfld = 1, nb_bdy_fld_sum 689 ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 690 IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 691 nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 692 nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 693 ENDDO 694 695 ! fill bf with blf_i and control print 696 !------------------------------------- 697 jstart = 1 698 DO jbdy = 1, nb_bdy 699 jend = jstart - 1 + nb_bdy_fld(jbdy) 700 CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(jbdy), 'bdy_dta', & 701 & 'open boundary conditions', 'nambdy_dta' ) 702 jstart = jend + 1 703 ENDDO 704 705 DO jfld = 1, nb_bdy_fld_sum 706 bf(jfld)%igrd = igrid(jfld) 707 bf(jfld)%ibdy = ibdy(jfld) 708 ENDDO 709 710 ! Initialise local boundary data arrays 711 ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later 712 ! nn_xxx_dta=1 : point to "fnow" arrays 713 !------------------------------------- 714 715 jfld = 0 716 DO jbdy=1, nb_bdy 717 718 nblen => idx_bdy(jbdy)%nblen 719 dta => dta_bdy(jbdy) 720 721 if(lwp) then 722 write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 723 write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 724 write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 725 write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 726 write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 727 write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 728 write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 729 endif 730 731 IF ( nn_dyn2d_dta(jbdy) == 0 .or. nn_dyn2d_dta(jbdy) == 2 ) THEN 732 if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 733 IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 734 IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 735 IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 736 ENDIF 737 IF ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 738 IF( dta%ll_ssh ) THEN 739 if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 740 jfld = jfld + 1 741 dta%ssh => bf(jfld)%fnow(:,1,1) 742 ENDIF 743 IF ( dta%ll_u2d ) THEN 744 IF ( ln_full_vel_array(jbdy) ) THEN 745 if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 746 ALLOCATE( dta%u2d(nblen(2)) ) 747 ELSE 748 if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 749 jfld = jfld + 1 750 dta%u2d => bf(jfld)%fnow(:,1,1) 751 ENDIF 752 ENDIF 753 IF ( dta%ll_v2d ) THEN 754 IF ( ln_full_vel_array(jbdy) ) THEN 755 if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 756 ALLOCATE( dta%v2d(nblen(3)) ) 757 ELSE 758 if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 759 jfld = jfld + 1 760 dta%v2d => bf(jfld)%fnow(:,1,1) 761 ENDIF 762 ENDIF 763 ENDIF 764 765 IF ( nn_dyn3d_dta(jbdy) == 0 ) THEN 766 if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 767 IF( dta%ll_u3d ) ALLOCATE( dta_bdy(jbdy)%u3d(nblen(2),jpk) ) 768 IF( dta%ll_v3d ) ALLOCATE( dta_bdy(jbdy)%v3d(nblen(3),jpk) ) 769 ENDIF 770 IF ( nn_dyn3d_dta(jbdy) == 1 .or. & 771 & ( ln_full_vel_array(jbdy) .and. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 772 IF ( dta%ll_u3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 773 if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 774 jfld = jfld + 1 775 dta_bdy(jbdy)%u3d => bf(jfld)%fnow(:,1,:) 776 ENDIF 777 IF ( dta%ll_v3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 778 if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 779 jfld = jfld + 1 780 dta_bdy(jbdy)%v3d => bf(jfld)%fnow(:,1,:) 781 ENDIF 782 ENDIF 783 784 IF( nn_tra_dta(jbdy) == 0 ) THEN 785 if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 786 IF( dta%ll_tem ) ALLOCATE( dta_bdy(jbdy)%tem(nblen(1),jpk) ) 787 IF( dta%ll_sal ) ALLOCATE( dta_bdy(jbdy)%sal(nblen(1),jpk) ) 788 ELSE 789 IF( dta%ll_tem ) THEN 790 if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 791 jfld = jfld + 1 792 dta_bdy(jbdy)%tem => bf(jfld)%fnow(:,1,:) 793 ENDIF 794 IF( dta%ll_sal ) THEN 795 if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 796 jfld = jfld + 1 797 dta_bdy(jbdy)%sal => bf(jfld)%fnow(:,1,:) 798 ENDIF 799 ENDIF 800 801 #if defined key_si3 802 IF (cn_ice(jbdy) /= 'none') THEN 803 IF( nn_ice_dta(jbdy) == 0 ) THEN 804 ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 805 ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 806 ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 807 ELSE 808 IF ( nice_cat == jpl ) THEN ! case input cat = jpl 809 jfld = jfld + 1 810 dta_bdy(jbdy)%a_i => bf(jfld)%fnow(:,1,:) 811 jfld = jfld + 1 812 dta_bdy(jbdy)%h_i => bf(jfld)%fnow(:,1,:) 813 jfld = jfld + 1 814 dta_bdy(jbdy)%h_s => bf(jfld)%fnow(:,1,:) 815 ELSE ! case input cat = 1 OR (/=1 and /=jpl) 816 jfld_ait(jbdy) = jfld + 1 817 jfld_htit(jbdy) = jfld + 2 818 jfld_htst(jbdy) = jfld + 3 819 jfld = jfld + 3 820 ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 821 ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 822 ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 823 dta_bdy(jbdy)%a_i(:,:) = 0._wp 824 dta_bdy(jbdy)%h_i(:,:) = 0._wp 825 dta_bdy(jbdy)%h_s(:,:) = 0._wp 826 ENDIF 827 828 ENDIF 829 ENDIF 830 #endif 622 IF( llread ) THEN ! get data from NetCDF file 623 CALL fld_fill( bf_alias, bn_alias, cn_dir, 'bdy_dta', cl3//' '//ctmp1, ctmp2 ) ! use namelist info 624 IF( bf_alias(1)%ln_tint ) ALLOCATE( bf_alias(1)%fdta( iszdim, 1, ipk, 2 ) ) 625 bf_alias(1)%imap => idx_bdy(jbdy)%nbmap(1:iszdim,igrd) ! associate the mapping used for this bdy 626 bf_alias(1)%igrd = igrd ! used only for vertical integration of 3D arrays 627 bf_alias(1)%ibdy = jbdy ! " " " " " " " " 628 bf_alias(1)%ltotvel = ln_full_vel ! T if u3d is full velocity 629 bf_alias(1)%lzint = ln_zinterp ! T if it requires a vertical interpolation 630 ENDIF 631 632 ! associate the pointer and get rid of the dimensions with a size equal to 1 633 IF( jfld == jp_bdyssh ) dta_bdy(jbdy)%ssh => bf_alias(1)%fnow(:,1,1) 634 IF( jfld == jp_bdyu2d ) dta_bdy(jbdy)%u2d => bf_alias(1)%fnow(:,1,1) 635 IF( jfld == jp_bdyv2d ) dta_bdy(jbdy)%v2d => bf_alias(1)%fnow(:,1,1) 636 IF( jfld == jp_bdyu3d ) dta_bdy(jbdy)%u3d => bf_alias(1)%fnow(:,1,:) 637 IF( jfld == jp_bdyv3d ) dta_bdy(jbdy)%v3d => bf_alias(1)%fnow(:,1,:) 638 IF( jfld == jp_bdytem ) dta_bdy(jbdy)%tem => bf_alias(1)%fnow(:,1,:) 639 IF( jfld == jp_bdysal ) dta_bdy(jbdy)%sal => bf_alias(1)%fnow(:,1,:) 640 IF( jfld == jp_bdya_i ) THEN 641 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%a_i => bf_alias(1)%fnow(:,1,:) 642 ELSE ; ALLOCATE( dta_bdy(jbdy)%a_i(iszdim,jpl) ) 643 ENDIF 644 ENDIF 645 IF( jfld == jp_bdyh_i ) THEN 646 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_i => bf_alias(1)%fnow(:,1,:) 647 ELSE ; ALLOCATE( dta_bdy(jbdy)%h_i(iszdim,jpl) ) 648 ENDIF 649 ENDIF 650 IF( jfld == jp_bdyh_s ) THEN 651 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_s => bf_alias(1)%fnow(:,1,:) 652 ELSE ; ALLOCATE( dta_bdy(jbdy)%h_s(iszdim,jpl) ) 653 ENDIF 654 ENDIF 655 IF( jfld == jp_bdyt_i ) THEN 656 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_i => bf_alias(1)%fnow(:,1,:) 657 ELSE ; ALLOCATE( dta_bdy(jbdy)%t_i(iszdim,jpl) ) 658 ENDIF 659 ENDIF 660 IF( jfld == jp_bdyt_s ) THEN 661 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_s => bf_alias(1)%fnow(:,1,:) 662 ELSE ; ALLOCATE( dta_bdy(jbdy)%t_s(iszdim,jpl) ) 663 ENDIF 664 ENDIF 665 IF( jfld == jp_bdytsu ) THEN 666 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%tsu => bf_alias(1)%fnow(:,1,:) 667 ELSE ; ALLOCATE( dta_bdy(jbdy)%tsu(iszdim,jpl) ) 668 ENDIF 669 ENDIF 670 IF( jfld == jp_bdys_i ) THEN 671 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%s_i => bf_alias(1)%fnow(:,1,:) 672 ELSE ; ALLOCATE( dta_bdy(jbdy)%s_i(iszdim,jpl) ) 673 ENDIF 674 ENDIF 675 IF( jfld == jp_bdyaip ) THEN 676 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%aip => bf_alias(1)%fnow(:,1,:) 677 ELSE ; ALLOCATE( dta_bdy(jbdy)%aip(iszdim,jpl) ) 678 ENDIF 679 ENDIF 680 IF( jfld == jp_bdyhip ) THEN 681 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hip => bf_alias(1)%fnow(:,1,:) 682 ELSE ; ALLOCATE( dta_bdy(jbdy)%hip(iszdim,jpl) ) 683 ENDIF 684 ENDIF 685 ENDIF 686 687 END DO ! jpbdyfld 831 688 ! 832 689 END DO ! jbdy 833 690 ! 834 691 END SUBROUTINE bdy_dta_init 835 692 836 693 !!============================================================================== 837 694 END MODULE bdydta -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdydyn2d.F90
r11072 r12143 14 14 !! bdy_ssh : Duplicate sea level across open boundaries 15 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers17 16 USE dom_oce ! ocean space and time domain 18 17 USE bdy_oce ! ocean open boundary conditions … … 50 49 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh 51 50 !! 52 INTEGER :: ib_bdy ! Loop counter 53 54 DO ib_bdy=1, nb_bdy 55 56 SELECT CASE( cn_dyn2d(ib_bdy) ) 57 CASE('none') 58 CYCLE 59 CASE('frs') 60 CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 61 CASE('flather') 62 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr ) 63 CASE('orlanski') 64 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 65 & pua2d, pva2d, pub2d, pvb2d, ll_npo=.false.) 66 CASE('orlanski_npo') 67 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 68 & pua2d, pva2d, pub2d, pvb2d, ll_npo=.true. ) 69 CASE DEFAULT 70 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 71 END SELECT 72 ENDDO 73 51 INTEGER :: ib_bdy, ir ! BDY set index, rim index 52 LOGICAL :: llrim0 ! indicate if rim 0 is treated 53 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 54 55 llsend2(:) = .false. ; llrecv2(:) = .false. 56 llsend3(:) = .false. ; llrecv3(:) = .false. 57 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 58 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 59 ELSE ; llrim0 = .FALSE. 60 END IF 61 DO ib_bdy=1, nb_bdy 62 SELECT CASE( cn_dyn2d(ib_bdy) ) 63 CASE('none') 64 CYCLE 65 CASE('frs') ! treat the whole boundary at once 66 IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 67 CASE('flather') 68 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 69 CASE('orlanski') 70 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 71 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false. ) 72 CASE('orlanski_npo') 73 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 74 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true. ) 75 CASE DEFAULT 76 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 77 END SELECT 78 ENDDO 79 ! 80 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 81 IF( nn_hls == 1 ) THEN 82 llsend2(:) = .false. ; llrecv2(:) = .false. 83 llsend3(:) = .false. ; llrecv3(:) = .false. 84 END IF 85 DO ib_bdy=1, nb_bdy 86 SELECT CASE( cn_dyn2d(ib_bdy) ) 87 CASE('flather') 88 llsend2(1:2) = llsend2(1:2) .OR. lsend_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points 89 llsend2(1) = llsend2(1) .OR. lsend_bdyext(ib_bdy,2,1,ir) ! neighbour might search point towards its east bdy 90 llrecv2(1:2) = llrecv2(1:2) .OR. lrecv_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points 91 llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(ib_bdy,2,2,ir) ! might search point towards bdy on the east 92 llsend3(3:4) = llsend3(3:4) .OR. lsend_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points 93 llsend3(3) = llsend3(3) .OR. lsend_bdyext(ib_bdy,3,3,ir) ! neighbour might search point towards its north bdy 94 llrecv3(3:4) = llrecv3(3:4) .OR. lrecv_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points 95 llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(ib_bdy,3,4,ir) ! might search point towards bdy on the north 96 CASE('orlanski', 'orlanski_npo') 97 llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 98 llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 99 llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 100 llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 101 END SELECT 102 END DO 103 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 104 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 105 END IF 106 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 107 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 108 END IF 109 ! 110 END DO ! ir 111 ! 74 112 END SUBROUTINE bdy_dyn2d 75 113 … … 90 128 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 91 129 !! 92 INTEGER :: jb , jk! dummy loop indices130 INTEGER :: jb ! dummy loop indices 93 131 INTEGER :: ii, ij, igrd ! local integers 94 132 REAL(wp) :: zwgt ! boundary weight … … 110 148 pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 111 149 END DO 112 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )113 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy) ! Boundary points should be updated114 150 ! 115 151 END SUBROUTINE bdy_dyn2d_frs 116 152 117 153 118 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr )154 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 119 155 !!---------------------------------------------------------------------- 120 156 !! *** SUBROUTINE bdy_dyn2d_fla *** … … 139 175 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 140 176 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 141 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr 142 177 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr 178 LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated 179 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 143 180 INTEGER :: jb, igrd ! dummy loop indices 144 INTEGER :: ii, ij, iim1, iip1, ijm1, ijp1 ! 2D addresses 145 REAL(wp), POINTER :: flagu, flagv ! short cuts 146 REAL(wp) :: zcorr ! Flather correction 147 REAL(wp) :: zforc ! temporary scalar 148 REAL(wp) :: zflag, z1_2 ! " " 181 INTEGER :: ii, ij ! 2D addresses 182 INTEGER :: iiTrim, ijTrim ! T pts i/j-indice on the rim 183 INTEGER :: iiToce, ijToce, iiUoce, ijVoce ! T, U and V pts i/j-indice of the ocean next to the rim 184 REAL(wp) :: flagu, flagv ! short cuts 185 REAL(wp) :: zfla ! Flather correction 186 REAL(wp) :: z1_2 ! 187 REAL(wp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh 149 188 !!---------------------------------------------------------------------- 150 189 … … 153 192 ! ---------------------------------! 154 193 ! Flather boundary conditions :! 155 ! ---------------------------------! 156 157 !!! REPLACE spgu with nemo_wrk work space 158 159 ! Fill temporary array with ssh data (here spgu): 194 ! ---------------------------------! 195 196 ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): 160 197 igrd = 1 161 spgu(:,:) = 0.0 162 DO jb = 1, idx%nblenrim(igrd) 198 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 199 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 200 END IF 201 ! 202 DO jb = ibeg, iend 163 203 ii = idx%nbi(jb,igrd) 164 204 ij = idx%nbj(jb,igrd) 165 IF( ll_wd ) THEN 166 spgu(ii, ij) = dta%ssh(jb) - ssh_ref 167 ELSE 168 spgu(ii, ij) = dta%ssh(jb) 205 IF( ll_wd ) THEN ; sshdta(ii, ij) = dta%ssh(jb) - ssh_ref 206 ELSE ; sshdta(ii, ij) = dta%ssh(jb) 169 207 ENDIF 170 208 END DO 171 172 CALL lbc_bdy_lnk( 'bdydyn2d', spgu(:,:), 'T', 1., ib_bdy ) 173 ! 174 igrd = 2 ! Flather bc on u-velocity; 209 ! 210 igrd = 2 ! Flather bc on u-velocity 175 211 ! ! remember that flagu=-1 if normal velocity direction is outward 176 212 ! ! I think we should rather use after ssh ? 177 DO jb = 1, idx%nblenrim(igrd) 178 ii = idx%nbi(jb,igrd) 179 ij = idx%nbj(jb,igrd) 180 flagu => idx%flagu(jb,igrd) 181 iim1 = ii + MAX( 0, INT( flagu ) ) ! T pts i-indice inside the boundary 182 iip1 = ii - MIN( 0, INT( flagu ) ) ! T pts i-indice outside the boundary 183 ! 184 zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 185 186 ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme 187 ! Use characteristics method instead 188 zflag = ABS(flagu) 189 zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(ii+NINT(flagu),ij) 190 pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1) 213 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 214 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 215 END IF 216 DO jb = ibeg, iend 217 ii = idx%nbi(jb,igrd) 218 ij = idx%nbj(jb,igrd) 219 flagu = idx%flagu(jb,igrd) 220 IF( flagu == 0. ) THEN 221 pua2d(ii,ij) = dta%u2d(jb) 222 ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and U points 223 IF( flagu == 1. ) THEN ; iiTrim = ii ; iiToce = ii+1 ; iiUoce = ii+1 ; ENDIF 224 IF( flagu == -1. ) THEN ; iiTrim = ii+1 ; iiToce = ii ; iiUoce = ii-1 ; ENDIF 225 ! 226 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 227 IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1 ) CYCLE 228 ! 229 zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) 230 ! 231 ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 232 ! mix Flather scheme with velocity of the ocean next to the rim 233 pua2d(ii,ij) = z1_2 * ( pua2d(iiUoce,ij) + zfla ) 234 END IF 191 235 END DO 192 236 ! 193 237 igrd = 3 ! Flather bc on v-velocity 194 238 ! ! remember that flagv=-1 if normal velocity direction is outward 195 DO jb = 1, idx%nblenrim(igrd) 196 ii = idx%nbi(jb,igrd) 197 ij = idx%nbj(jb,igrd) 198 flagv => idx%flagv(jb,igrd) 199 ijm1 = ij + MAX( 0, INT( flagv ) ) ! T pts j-indice inside the boundary 200 ijp1 = ij - MIN( 0, INT( flagv ) ) ! T pts j-indice outside the boundary 201 ! 202 zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 203 204 ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme 205 ! Use characteristics method instead 206 zflag = ABS(flagv) 207 zforc = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ij+NINT(flagv)) 208 pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 209 END DO 210 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 211 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy ) ! 239 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 240 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 241 END IF 242 DO jb = ibeg, iend 243 ii = idx%nbi(jb,igrd) 244 ij = idx%nbj(jb,igrd) 245 flagv = idx%flagv(jb,igrd) 246 IF( flagv == 0. ) THEN 247 pva2d(ii,ij) = dta%v2d(jb) 248 ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and V points 249 IF( flagv == 1. ) THEN ; ijTrim = ij ; ijToce = ij+1 ; ijVoce = ij+1 ; ENDIF 250 IF( flagv == -1. ) THEN ; ijTrim = ij+1 ; ijToce = ij ; ijVoce = ij-1 ; ENDIF 251 ! 252 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 253 IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1 ) CYCLE 254 ! 255 zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) 256 ! 257 ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 258 ! mix Flather scheme with velocity of the ocean next to the rim 259 pva2d(ii,ij) = z1_2 * ( pva2d(ii,ijVoce) + zfla ) 260 END IF 261 END DO 212 262 ! 213 263 END SUBROUTINE bdy_dyn2d_fla 214 264 215 265 216 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, ll _npo )266 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo ) 217 267 !!---------------------------------------------------------------------- 218 268 !! *** SUBROUTINE bdy_dyn2d_orlanski *** … … 231 281 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d 232 282 LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version 233 283 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 234 284 INTEGER :: ib, igrd ! dummy loop indices 235 285 INTEGER :: ii, ij, iibm1, ijbm1 ! indices … … 238 288 igrd = 2 ! Orlanski bc on u-velocity; 239 289 ! 240 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll _npo )290 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, llrim0, ll_npo ) 241 291 242 292 igrd = 3 ! Orlanski bc on v-velocity 243 293 ! 244 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 245 ! 246 CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 247 CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy ) ! 294 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, llrim0, ll_npo ) 248 295 ! 249 296 END SUBROUTINE bdy_dyn2d_orlanski … … 257 304 !! 258 305 !!---------------------------------------------------------------------- 259 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zssh ! Sea level 260 !! 261 INTEGER :: ib_bdy, ib, igrd ! local integers 262 INTEGER :: ii, ij, zcoef, zcoef1, zcoef2, ip, jp ! " " 263 264 igrd = 1 ! Everything is at T-points here 265 266 DO ib_bdy = 1, nb_bdy 267 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 268 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 269 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 270 ! Set gradient direction: 271 zcoef1 = bdytmask(ii-1,ij ) + bdytmask(ii+1,ij ) 272 zcoef2 = bdytmask(ii ,ij-1) + bdytmask(ii ,ij+1) 273 IF ( zcoef1+zcoef2 == 0 ) THEN ! corner 274 zcoef = bdytmask(ii-1,ij-1) + bdytmask(ii+1,ij+1) + bdytmask(ii+1,ij-1) + bdytmask(ii-1,ij+1) 275 zssh(ii,ij) = zssh( ii-1, ij-1 ) * bdytmask( ii-1, ij-1) + & 276 & zssh( ii+1, ij+1 ) * bdytmask( ii+1, ij+1) + & 277 & zssh( ii+1, ij-1 ) * bdytmask( ii+1, ij-1) + & 278 & zssh( ii-1, ij+1 ) * bdytmask( ii-1, ij+1) 279 zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 280 ELSE 281 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij ) 282 jp = bdytmask(ii ,ij+1) - bdytmask(ii ,ij-1) 283 zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1) 284 ENDIF 306 REAL(wp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn 307 !! 308 INTEGER :: ib_bdy, ir ! bdy index, rim index 309 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 310 LOGICAL :: llrim0 ! indicate if rim 0 is treated 311 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 312 !!---------------------------------------------------------------------- 313 llsend1(:) = .false. ; llrecv1(:) = .false. 314 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 315 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 316 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 317 ELSE ; llrim0 = .FALSE. 318 END IF 319 DO ib_bdy = 1, nb_bdy 320 CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0 ) ! zssh is masked 321 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 322 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 285 323 END DO 286 287 ! Boundary points should be updated 288 CALL lbc_bdy_lnk( 'bdydyn2d', zssh(:,:), 'T', 1., ib_bdy ) 289 END DO 290 324 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 325 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 326 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 327 END IF 328 END DO 329 ! 291 330 END SUBROUTINE bdy_ssh 292 331 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdydyn3d.F90
r10529 r12143 42 42 INTEGER, INTENT(in) :: kt ! Main time step counter 43 43 ! 44 INTEGER :: ib_bdy ! loop index 45 !!---------------------------------------------------------------------- 46 ! 47 DO ib_bdy=1, nb_bdy 44 INTEGER :: ib_bdy, ir ! BDY set index, rim index 45 LOGICAL :: llrim0 ! indicate if rim 0 is treated 46 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 47 48 !!---------------------------------------------------------------------- 49 llsend2(:) = .false. ; llrecv2(:) = .false. 50 llsend3(:) = .false. ; llrecv3(:) = .false. 51 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 52 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 53 ELSE ; llrim0 = .FALSE. 54 END IF 55 DO ib_bdy=1, nb_bdy 56 ! 57 SELECT CASE( cn_dyn3d(ib_bdy) ) 58 CASE('none') ; CYCLE 59 CASE('frs' ) ! treat the whole boundary at once 60 IF( ir == 0) CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 61 CASE('specified') ! treat the whole rim at once 62 IF( ir == 0) CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 63 CASE('zero') ! treat the whole rim at once 64 IF( ir == 0) CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 65 CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) 66 CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true. ) 67 CASE('zerograd') ; CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) 68 CASE('neumann') ; CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy, llrim0 ) 69 CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 70 END SELECT 71 END DO 48 72 ! 49 SELECT CASE( cn_dyn3d(ib_bdy) ) 50 CASE('none') ; CYCLE 51 CASE('frs' ) ; CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 52 CASE('specified') ; CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 53 CASE('zero') ; CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 54 CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 55 CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 56 CASE('zerograd') ; CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 57 CASE('neumann') ; CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy ) 58 CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 59 END SELECT 60 END DO 73 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 74 IF( nn_hls == 1 ) THEN 75 llsend2(:) = .false. ; llrecv2(:) = .false. 76 llsend3(:) = .false. ; llrecv3(:) = .false. 77 END IF 78 DO ib_bdy=1, nb_bdy 79 SELECT CASE( cn_dyn3d(ib_bdy) ) 80 CASE('orlanski', 'orlanski_npo') 81 llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 82 llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points 83 llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 84 llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points 85 CASE('zerograd') 86 llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points 87 llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points 88 llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir) ! west/east, V points 89 llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,ir) ! west/east, V points 90 CASE('neumann') 91 llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points 92 llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points 93 llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points 94 llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points 95 END SELECT 96 END DO 97 ! 98 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 99 CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 100 END IF 101 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 102 CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 103 END IF 104 END DO ! ir 61 105 ! 62 106 END SUBROUTINE bdy_dyn3d … … 78 122 INTEGER :: jb, jk ! dummy loop indices 79 123 INTEGER :: ii, ij, igrd ! local integers 80 REAL(wp) :: zwgt ! boundary weight81 124 !!---------------------------------------------------------------------- 82 125 ! … … 98 141 END DO 99 142 END DO 100 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated101 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )102 !103 IF( kt == nit000 ) CLOSE( unit = 102 )104 143 ! 105 144 END SUBROUTINE bdy_dyn3d_spe 106 145 107 146 108 SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt , ib_bdy)147 SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt, ib_bdy, llrim0 ) 109 148 !!---------------------------------------------------------------------- 110 149 !! *** SUBROUTINE bdy_dyn3d_zgrad *** … … 114 153 !!---------------------------------------------------------------------- 115 154 INTEGER :: kt 116 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 117 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 118 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 155 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 156 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 157 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 158 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 119 159 !! 120 160 INTEGER :: jb, jk ! dummy loop indices 121 161 INTEGER :: ii, ij, igrd ! local integers 122 REAL(wp) :: zwgt ! boundary weight123 INTEGER :: fu, fv162 INTEGER :: flagu, flagv ! short cuts 163 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 124 164 !!---------------------------------------------------------------------- 125 165 ! 126 166 igrd = 2 ! Copying tangential velocity into bdy points 127 DO jb = 1, idx%nblenrim(igrd) 128 DO jk = 1, jpkm1 129 ii = idx%nbi(jb,igrd) 130 ij = idx%nbj(jb,igrd) 131 fu = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 ) 132 ua(ii,ij,jk) = ua(ii,ij,jk) * REAL( 1 - fu) + ( ua(ii,ij+fu,jk) * umask(ii,ij+fu,jk) & 133 &+ ua(ii,ij-fu,jk) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu ) 134 END DO 167 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 168 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 169 ENDIF 170 DO jb = ibeg, iend 171 ii = idx%nbi(jb,igrd) 172 ij = idx%nbj(jb,igrd) 173 flagu = NINT(idx%flagu(jb,igrd)) 174 flagv = NINT(idx%flagv(jb,igrd)) 175 ! 176 IF( flagu == 0 ) THEN ! north/south bdy 177 IF( ij+flagv > jpj .OR. ij+flagv < 1 ) CYCLE 178 ! 179 DO jk = 1, jpkm1 180 ua(ii,ij,jk) = ua(ii,ij+flagv,jk) * umask(ii,ij+flagv,jk) 181 END DO 182 ! 183 END IF 135 184 END DO 136 185 ! 137 186 igrd = 3 ! Copying tangential velocity into bdy points 138 DO jb = 1, idx%nblenrim(igrd) 139 DO jk = 1, jpkm1 140 ii = idx%nbi(jb,igrd) 141 ij = idx%nbj(jb,igrd) 142 fv = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 ) 143 va(ii,ij,jk) = va(ii,ij,jk) * REAL( 1 - fv ) + ( va(ii+fv,ij,jk) * vmask(ii+fv,ij,jk) & 144 &+ va(ii-fv,ij,jk) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv ) 145 END DO 146 END DO 147 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 148 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 149 ! 150 IF( kt == nit000 ) CLOSE( unit = 102 ) 187 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 188 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 189 ENDIF 190 DO jb = ibeg, iend 191 ii = idx%nbi(jb,igrd) 192 ij = idx%nbj(jb,igrd) 193 flagu = NINT(idx%flagu(jb,igrd)) 194 flagv = NINT(idx%flagv(jb,igrd)) 195 ! 196 IF( flagv == 0 ) THEN ! west/east bdy 197 IF( ii+flagu > jpi .OR. ii+flagu < 1 ) CYCLE 198 ! 199 DO jk = 1, jpkm1 200 va(ii,ij,jk) = va(ii+flagu,ij,jk) * vmask(ii+flagu,ij,jk) 201 END DO 202 ! 203 END IF 204 END DO 151 205 ! 152 206 END SUBROUTINE bdy_dyn3d_zgrad … … 167 221 INTEGER :: ib, ik ! dummy loop indices 168 222 INTEGER :: ii, ij, igrd ! local integers 169 REAL(wp) :: zwgt ! boundary weight170 223 !!---------------------------------------------------------------------- 171 224 ! … … 178 231 END DO 179 232 END DO 180 233 ! 181 234 igrd = 3 ! Everything is at T-points here 182 235 DO ib = 1, idx%nblenrim(igrd) … … 187 240 END DO 188 241 END DO 189 !190 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ; CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1.,ib_bdy ) ! Boundary points should be updated191 !192 IF( kt == nit000 ) CLOSE( unit = 102 )193 242 ! 194 243 END SUBROUTINE bdy_dyn3d_zro … … 234 283 va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) 235 284 END DO 236 END DO 237 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 238 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 239 ! 240 IF( kt == nit000 ) CLOSE( unit = 102 ) 285 END DO 241 286 ! 242 287 END SUBROUTINE bdy_dyn3d_frs 243 288 244 289 245 SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll _npo )290 SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, llrim0, ll_npo ) 246 291 !!---------------------------------------------------------------------- 247 292 !! *** SUBROUTINE bdy_dyn3d_orlanski *** … … 255 300 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 256 301 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 257 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 258 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 302 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 303 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 304 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 259 305 260 306 INTEGER :: jb, igrd ! dummy loop indices … … 265 311 igrd = 2 ! Orlanski bc on u-velocity; 266 312 ! 267 CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo )313 CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo, llrim0 ) 268 314 269 315 igrd = 3 ! Orlanski bc on v-velocity 270 316 ! 271 CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 272 ! 273 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 274 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 317 CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo, llrim0 ) 275 318 ! 276 319 END SUBROUTINE bdy_dyn3d_orlanski … … 320 363 END DO 321 364 ! 322 CALL lbc_lnk_multi( 'bdydyn3d', ua, 'U', -1., va, 'V', -1. ) ! Boundary points should be updated323 !324 365 IF( ln_timing ) CALL timing_stop('bdy_dyn3d_dmp') 325 366 ! … … 327 368 328 369 329 SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy )370 SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy, llrim0 ) 330 371 !!---------------------------------------------------------------------- 331 372 !! *** SUBROUTINE bdy_dyn3d_nmn *** … … 336 377 !! 337 378 !!---------------------------------------------------------------------- 338 TYPE(OBC_INDEX), INTENT(in) :: idx! OBC indices339 INTEGER, INTENT(in) :: ib_bdy! BDY set index340 341 INTEGER :: jb, igrd ! dummy loop indices379 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 380 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 381 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 382 INTEGER :: igrd ! dummy indice 342 383 !!---------------------------------------------------------------------- 343 384 ! … … 346 387 igrd = 2 ! Neumann bc on u-velocity; 347 388 ! 348 CALL bdy_nmn( idx, igrd, ua )389 CALL bdy_nmn( idx, igrd, ua, llrim0 ) ! ua is masked 349 390 350 391 igrd = 3 ! Neumann bc on v-velocity 351 392 ! 352 CALL bdy_nmn( idx, igrd, va ) 353 ! 354 CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 355 CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 393 CALL bdy_nmn( idx, igrd, va, llrim0 ) ! va is masked 356 394 ! 357 395 END SUBROUTINE bdy_dyn3d_nmn -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdyice.F90
r11041 r12143 55 55 INTEGER, INTENT(in) :: kt ! Main time step counter 56 56 ! 57 INTEGER :: jbdy ! BDY set index 57 INTEGER :: jbdy, ir ! BDY set index, rim index 58 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 59 LOGICAL :: llrim0 ! indicate if rim 0 is treated 60 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 58 61 !!---------------------------------------------------------------------- 59 62 ! controls 60 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 61 64 IF( ln_icediachk ) CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 65 IF( ln_icediachk ) CALL ice_cons2D (0,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 62 66 ! 63 67 CALL ice_var_glo2eqv 64 68 ! 65 DO jbdy = 1, nb_bdy 69 llsend1(:) = .false. ; llrecv1(:) = .false. 70 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 71 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 72 ELSE ; llrim0 = .FALSE. 73 END IF 74 DO jbdy = 1, nb_bdy 75 ! 76 SELECT CASE( cn_ice(jbdy) ) 77 CASE('none') ; CYCLE 78 CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy, llrim0 ) 79 CASE DEFAULT 80 CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 81 END SELECT 82 ! 83 END DO 66 84 ! 67 SELECT CASE( cn_ice(jbdy) ) 68 CASE('none') ; CYCLE 69 CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy ) 70 CASE DEFAULT 71 CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 72 END SELECT 73 ! 74 END DO 85 ! Update bdy points 86 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 87 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 88 DO jbdy = 1, nb_bdy 89 IF( cn_ice(jbdy) == 'frs' ) THEN 90 llsend1(:) = llsend1(:) .OR. lsend_bdyint(jbdy,1,:,ir) ! possibly every direction, T points 91 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(jbdy,1,:,ir) ! possibly every direction, T points 92 END IF 93 END DO ! jbdy 94 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 ! exchange 3d arrays 96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. & 97 & , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. & 98 & , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1. & 99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 END IF 104 END DO ! ir 75 105 ! 76 106 CALL ice_cor( kt , 0 ) ! -- In case categories are out of bounds, do a remapping … … 80 110 ! 81 111 ! controls 112 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 82 113 IF( ln_icediachk ) CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 83 IF( ln_ice ctl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints114 IF( ln_icediachk ) CALL ice_cons2D (1,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 84 115 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 85 116 ! … … 87 118 88 119 89 SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy )120 SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) 90 121 !!------------------------------------------------------------------------------ 91 122 !! *** SUBROUTINE bdy_ice_frs *** … … 96 127 !! dimensional baroclinic ocean model with realistic topography. Tellus, 365-382. 97 128 !!------------------------------------------------------------------------------ 98 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 99 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 100 INTEGER, INTENT(in) :: kt ! main time-step counter 101 INTEGER, INTENT(in) :: jbdy ! BDY set index 129 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 130 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 131 INTEGER, INTENT(in) :: kt ! main time-step counter 132 INTEGER, INTENT(in) :: jbdy ! BDY set index 133 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 102 134 ! 103 135 INTEGER :: jpbound ! 0 = incoming ice 104 136 ! ! 1 = outgoing ice 137 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 105 138 INTEGER :: i_bdy, jgrd ! dummy loop indices 106 139 INTEGER :: ji, jj, jk, jl, ib, jb 107 140 REAL(wp) :: zwgt, zwgt1 ! local scalar 108 141 REAL(wp) :: ztmelts, zdh 142 REAL(wp), POINTER :: flagu, flagv ! short cuts 109 143 !!------------------------------------------------------------------------------ 110 144 ! 111 145 jgrd = 1 ! Everything is at T-points here 146 IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(jgrd) 147 ELSE ; ibeg = idx%nblenrim0(jgrd)+1 ; iend = idx%nblenrim(jgrd) 148 END IF 112 149 ! 113 150 DO jl = 1, jpl 114 DO i_bdy = 1, idx%nblenrim(jgrd)151 DO i_bdy = ibeg, iend 115 152 ji = idx%nbi(i_bdy,jgrd) 116 153 jj = idx%nbj(i_bdy,jgrd) 117 154 zwgt = idx%nbw(i_bdy,jgrd) 118 155 zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) 119 a_i(ji,jj,jl) = ( a_i(ji,jj,jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Leads fraction 120 h_i(ji,jj,jl) = ( h_i(ji,jj,jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth 121 h_s(ji,jj,jl) = ( h_s(ji,jj,jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth 122 156 a_i (ji,jj, jl) = ( a_i (ji,jj, jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice concentration 157 h_i (ji,jj, jl) = ( h_i (ji,jj, jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth 158 h_s (ji,jj, jl) = ( h_s (ji,jj, jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth 159 t_i (ji,jj,:,jl) = ( t_i (ji,jj,:,jl) * zwgt1 + dta%t_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice temperature 160 t_s (ji,jj,:,jl) = ( t_s (ji,jj,:,jl) * zwgt1 + dta%t_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow temperature 161 t_su(ji,jj, jl) = ( t_su(ji,jj, jl) * zwgt1 + dta%tsu(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Surf temperature 162 s_i (ji,jj, jl) = ( s_i (ji,jj, jl) * zwgt1 + dta%s_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice salinity 163 a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration 164 h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth 165 ! 166 sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) 167 ! 168 ! make sure ponds = 0 if no ponds scheme 169 IF( .NOT.ln_pnd ) THEN 170 a_ip(ji,jj,jl) = 0._wp 171 h_ip(ji,jj,jl) = 0._wp 172 ENDIF 173 ! 123 174 ! ----------------- 124 175 ! Pathological case … … 135 186 h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) 136 187 h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos ) 137 188 ! 138 189 ENDDO 139 190 ENDDO 140 CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy )141 CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy )142 CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy )143 191 144 192 DO jl = 1, jpl 145 DO i_bdy = 1, idx%nblenrim(jgrd)193 DO i_bdy = ibeg, iend 146 194 ji = idx%nbi(i_bdy,jgrd) 147 195 jj = idx%nbj(i_bdy,jgrd) 148 196 flagu => idx%flagu(i_bdy,jgrd) 197 flagv => idx%flagv(i_bdy,jgrd) 149 198 ! condition on ice thickness depends on the ice velocity 150 199 ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values 151 200 jpbound = 0 ; ib = ji ; jb = jj 152 201 ! 153 IF( u_ice(ji ,jj ) < 0. .AND. umask(ji-1,jj ,1) == 0. ) jpbound = 1 ; ib = ji+1 154 IF( u_ice(ji-1,jj ) > 0. .AND. umask(ji ,jj ,1) == 0. ) jpbound = 1 ; ib = ji-1 155 IF( v_ice(ji ,jj ) < 0. .AND. vmask(ji ,jj-1,1) == 0. ) jpbound = 1 ; jb = jj+1 156 IF( v_ice(ji ,jj-1) > 0. .AND. vmask(ji ,jj ,1) == 0. ) jpbound = 1 ; jb = jj-1 202 IF( flagu == 1. ) THEN 203 IF( ji+1 > jpi ) CYCLE 204 IF( u_ice(ji ,jj ) < 0. ) jpbound = 1 ; ib = ji+1 205 END IF 206 IF( flagu == -1. ) THEN 207 IF( ji-1 < 1 ) CYCLE 208 IF( u_ice(ji-1,jj ) < 0. ) jpbound = 1 ; ib = ji-1 209 END IF 210 IF( flagv == 1. ) THEN 211 IF( jj+1 > jpj ) CYCLE 212 IF( v_ice(ji ,jj ) < 0. ) jpbound = 1 ; jb = jj+1 213 END IF 214 IF( flagv == -1. ) THEN 215 IF( jj-1 < 1 ) CYCLE 216 IF( v_ice(ji ,jj-1) < 0. ) jpbound = 1 ; jb = jj-1 217 END IF 157 218 ! 158 219 IF( nn_ice_dta(jbdy) == 0 ) jpbound = 0 ; ib = ji ; jb = jj ! case ice boundaries = initial conditions … … 161 222 IF( a_i(ib,jb,jl) > 0._wp ) THEN ! there is ice at the boundary 162 223 ! 163 a_i(ji,jj,jl) = a_i(ib,jb,jl) ! concentration 164 h_i(ji,jj,jl) = h_i(ib,jb,jl) ! thickness ice 165 h_s(ji,jj,jl) = h_s(ib,jb,jl) ! thickness snw 166 ! 167 SELECT CASE( jpbound ) 168 ! 169 CASE( 0 ) ! velocity is inward 170 ! 171 oa_i(ji,jj, jl) = rn_ice_age(jbdy) * a_i(ji,jj,jl) ! age 172 a_ip(ji,jj, jl) = 0._wp ! pond concentration 173 v_ip(ji,jj, jl) = 0._wp ! pond volume 174 t_su(ji,jj, jl) = rn_ice_tem(jbdy) ! temperature surface 175 t_s (ji,jj,:,jl) = rn_ice_tem(jbdy) ! temperature snw 176 t_i (ji,jj,:,jl) = rn_ice_tem(jbdy) ! temperature ice 177 s_i (ji,jj, jl) = rn_ice_sal(jbdy) ! salinity 178 sz_i(ji,jj,:,jl) = rn_ice_sal(jbdy) ! salinity profile 179 ! 180 CASE( 1 ) ! velocity is outward 181 ! 182 oa_i(ji,jj, jl) = oa_i(ib,jb, jl) ! age 183 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) ! pond concentration 184 v_ip(ji,jj, jl) = v_ip(ib,jb, jl) ! pond volume 185 t_su(ji,jj, jl) = t_su(ib,jb, jl) ! temperature surface 186 t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) ! temperature snw 187 t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) ! temperature ice 188 s_i (ji,jj, jl) = s_i (ib,jb, jl) ! salinity 189 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) ! salinity profile 190 ! 191 END SELECT 224 a_i (ji,jj, jl) = a_i (ib,jb, jl) 225 h_i (ji,jj, jl) = h_i (ib,jb, jl) 226 h_s (ji,jj, jl) = h_s (ib,jb, jl) 227 t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) 228 t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) 229 t_su(ji,jj, jl) = t_su(ib,jb, jl) 230 s_i (ji,jj, jl) = s_i (ib,jb, jl) 231 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) 232 h_ip(ji,jj, jl) = h_ip(ib,jb, jl) 233 ! 234 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) 235 ! 236 ! ice age 237 IF ( jpbound == 0 ) THEN ! velocity is inward 238 oa_i(ji,jj,jl) = rice_age(jbdy) * a_i(ji,jj,jl) 239 ELSEIF( jpbound == 1 ) THEN ! velocity is outward 240 oa_i(ji,jj,jl) = oa_i(ib,jb,jl) 241 ENDIF 192 242 ! 193 243 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 214 264 END DO 215 265 ! 266 ! melt ponds 267 IF( a_i(ji,jj,jl) > epsi10 ) THEN 268 a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl) 269 ELSE 270 a_ip_frac(ji,jj,jl) = 0._wp 271 ENDIF 272 v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 273 ! 216 274 ELSE ! no ice at the boundary 217 275 ! … … 225 283 t_s (ji,jj,:,jl) = rt0 226 284 t_i (ji,jj,:,jl) = rt0 285 286 a_ip_frac(ji,jj,jl) = 0._wp 287 h_ip (ji,jj,jl) = 0._wp 288 a_ip (ji,jj,jl) = 0._wp 289 v_ip (ji,jj,jl) = 0._wp 227 290 228 291 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 246 309 ! 247 310 END DO ! jl 248 249 CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:) , 'T', 1., jbdy )250 CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:) , 'T', 1., jbdy )251 CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:) , 'T', 1., jbdy )252 CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:) , 'T', 1., jbdy )253 CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:) , 'T', 1., jbdy )254 CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:) , 'T', 1., jbdy )255 CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:) , 'T', 1., jbdy )256 CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:) , 'T', 1., jbdy )257 CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:) , 'T', 1., jbdy )258 CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:) , 'T', 1., jbdy )259 CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:) , 'T', 1., jbdy )260 CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy )261 CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy )262 CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy )263 CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy )264 311 ! 265 312 END SUBROUTINE bdy_ice_frs … … 279 326 CHARACTER(len=1), INTENT(in) :: cd_type ! nature of velocity grid-points 280 327 ! 281 INTEGER :: i_bdy, jgrd ! dummy loop indices 282 INTEGER :: ji, jj ! local scalar 283 INTEGER :: jbdy ! BDY set index 328 INTEGER :: i_bdy, jgrd ! dummy loop indices 329 INTEGER :: ji, jj ! local scalar 330 INTEGER :: jbdy, ir ! BDY set index, rim index 331 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 284 332 REAL(wp) :: zmsk1, zmsk2, zflag 333 LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out 285 334 !!------------------------------------------------------------------------------ 286 335 IF( ln_timing ) CALL timing_start('bdy_ice_dyn') 287 336 ! 288 DO jbdy=1, nb_bdy 337 llsend2(:) = .false. ; llrecv2(:) = .false. 338 llsend3(:) = .false. ; llrecv3(:) = .false. 339 DO ir = 1, 0, -1 340 DO jbdy = 1, nb_bdy 341 ! 342 SELECT CASE( cn_ice(jbdy) ) 343 ! 344 CASE('none') 345 CYCLE 346 ! 347 CASE('frs') 348 ! 349 IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions 350 ! ! do not change ice velocity (it is only computed by rheology) 351 SELECT CASE ( cd_type ) 352 ! 353 CASE ( 'U' ) 354 jgrd = 2 ! u velocity 355 IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) 356 ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) 357 END IF 358 DO i_bdy = ibeg, iend 359 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 360 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 361 zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 362 ! i-1 i i | ! i i i+1 | ! i i i+1 | 363 ! > ice > | ! o > ice | ! o > o | 364 ! => set at u_ice(i-1) ! => set to O ! => unchanged 365 IF( zflag == -1. .AND. ji > 1 .AND. ji < jpi ) THEN 366 IF ( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji-1,jj) 367 ELSEIF( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp 368 END IF 369 END IF 370 ! | i i+1 i+1 ! | i i i+1 ! | i i i+1 371 ! | > ice > ! | ice > o ! | o > o 372 ! => set at u_ice(i+1) ! => set to O ! => unchanged 373 IF( zflag == 1. .AND. ji+1 < jpi+1 ) THEN 374 IF ( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji+1,jj) 375 ELSEIF( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp 376 END IF 377 END IF 378 ! 379 IF( zflag == 0. ) u_ice(ji,jj) = 0._wp ! u_ice = 0 if north/south bdy 380 ! 381 END DO 382 ! 383 CASE ( 'V' ) 384 jgrd = 3 ! v velocity 385 IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) 386 ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) 387 END IF 388 DO i_bdy = ibeg, iend 389 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 390 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 391 zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 392 ! ! ice (jj+1) ! o (jj+1) 393 ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) 394 ! ice (jj ) ! o (jj ) ! o (jj ) 395 ! ^ (jj-1) ! ! 396 ! => set to u_ice(jj-1) ! => set to 0 ! => unchanged 397 IF( zflag == -1. .AND. jj > 1 .AND. jj < jpj ) THEN 398 IF ( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj-1) 399 ELSEIF( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = 0._wp 400 END IF 401 END IF 402 ! ^ (jj+1) ! ! 403 ! ice (jj+1) ! o (jj+1) ! o (jj+1) 404 ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) 405 ! ________________ ! ____ice___(jj )_ ! _____o____(jj ) 406 ! => set to u_ice(jj+1) ! => set to 0 ! => unchanged 407 IF( zflag == 1. .AND. jj < jpj ) THEN 408 IF ( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj+1) 409 ELSEIF( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = 0._wp 410 END IF 411 END IF 412 ! 413 IF( zflag == 0. ) v_ice(ji,jj) = 0._wp ! v_ice = 0 if west/east bdy 414 ! 415 END DO 416 ! 417 END SELECT 418 ! 419 CASE DEFAULT 420 CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 421 END SELECT 422 ! 423 END DO ! jbdy 289 424 ! 290 SELECT CASE( cn_ice(jbdy) ) 291 ! 292 CASE('none') 293 CYCLE 294 ! 295 CASE('frs') 296 ! 297 IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions 298 ! ! do not change ice velocity (it is only computed by rheology) 299 SELECT CASE ( cd_type ) 300 ! 301 CASE ( 'U' ) 302 jgrd = 2 ! u velocity 303 DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 304 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 305 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 306 zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 307 ! 308 IF ( ABS( zflag ) == 1. ) THEN ! eastern and western boundaries 309 ! one of the two zmsk is always 0 (because of zflag) 310 zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji+1,jj) ) ) ! 0 if no ice 311 zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj) ) ) ! 0 if no ice 312 ! 313 ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then do not change u_ice) 314 u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 315 & u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 316 & u_ice(ji ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 317 ELSE ! everywhere else 318 u_ice(ji,jj) = 0._wp 319 ENDIF 320 ! 321 END DO 322 CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 323 ! 324 CASE ( 'V' ) 325 jgrd = 3 ! v velocity 326 DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 327 ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 328 jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 329 zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 330 ! 331 IF ( ABS( zflag ) == 1. ) THEN ! northern and southern boundaries 332 ! one of the two zmsk is always 0 (because of zflag) 333 zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj+1) ) ) ! 0 if no ice 334 zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj) ) ) ! 0 if no ice 335 ! 336 ! v_ice = v_ice of the adjacent grid point except if this grid point is ice-free (then do not change v_ice) 337 v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 338 & v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 339 & v_ice(ji,jj ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 340 ELSE ! everywhere else 341 v_ice(ji,jj) = 0._wp 342 ENDIF 343 ! 344 END DO 345 CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 346 ! 347 END SELECT 348 ! 349 CASE DEFAULT 350 CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 425 SELECT CASE ( cd_type ) 426 CASE ( 'U' ) 427 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 428 IF( nn_hls == 1 ) THEN ; llsend2(:) = .false. ; llrecv2(:) = .false. ; END IF 429 DO jbdy = 1, nb_bdy 430 IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 431 llsend2(:) = llsend2(:) .OR. lsend_bdyint(jbdy,2,:,ir) ! possibly every direction, U points 432 llsend2(1) = llsend2(1) .OR. lsend_bdyext(jbdy,2,1,ir) ! neighbour might search point towards its west bdy 433 llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(jbdy,2,:,ir) ! possibly every direction, U points 434 llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(jbdy,2,2,ir) ! might search point towards east bdy 435 END IF 436 END DO 437 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 438 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 439 END IF 440 CASE ( 'V' ) 441 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 442 IF( nn_hls == 1 ) THEN ; llsend3(:) = .false. ; llrecv3(:) = .false. ; END IF 443 DO jbdy = 1, nb_bdy 444 IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 445 llsend3(:) = llsend3(:) .OR. lsend_bdyint(jbdy,3,:,ir) ! possibly every direction, V points 446 llsend3(3) = llsend3(3) .OR. lsend_bdyext(jbdy,3,3,ir) ! neighbour might search point towards its south bdy 447 llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(jbdy,3,:,ir) ! possibly every direction, V points 448 llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(jbdy,3,4,ir) ! might search point towards north bdy 449 END IF 450 END DO 451 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 452 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 453 END IF 351 454 END SELECT 352 ! 353 END DO 455 END DO ! ir 354 456 ! 355 457 IF( ln_timing ) CALL timing_stop('bdy_ice_dyn') -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdyini.F90
r10983 r12143 33 33 PRIVATE 34 34 35 PUBLIC bdy_init ! routine called in nemo_init 35 PUBLIC bdy_init ! routine called in nemo_init 36 PUBLIC find_neib ! routine called in bdy_nmn 36 37 37 38 INTEGER, PARAMETER :: jp_nseg = 100 ! 38 INTEGER, PARAMETER :: nrimmax = 20 ! maximum rimwidth in structured39 ! open boundary data files40 39 ! Straight open boundary segment parameters: 41 40 INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs … … 68 67 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 69 68 & cn_ice, nn_ice_dta, & 70 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 71 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 69 & ln_vol, nn_volctl, nn_rimwidth 72 70 ! 73 71 INTEGER :: ios ! Local integer output status for namelist read … … 79 77 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries 80 78 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) 81 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) 79 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 80 ! make sur that all elements of the namelist variables have a default definition from namelist_ref 81 ln_coords_file (2:jp_bdy) = ln_coords_file (1) 82 cn_coords_file (2:jp_bdy) = cn_coords_file (1) 83 cn_dyn2d (2:jp_bdy) = cn_dyn2d (1) 84 nn_dyn2d_dta (2:jp_bdy) = nn_dyn2d_dta (1) 85 cn_dyn3d (2:jp_bdy) = cn_dyn3d (1) 86 nn_dyn3d_dta (2:jp_bdy) = nn_dyn3d_dta (1) 87 cn_tra (2:jp_bdy) = cn_tra (1) 88 nn_tra_dta (2:jp_bdy) = nn_tra_dta (1) 89 ln_tra_dmp (2:jp_bdy) = ln_tra_dmp (1) 90 ln_dyn3d_dmp (2:jp_bdy) = ln_dyn3d_dmp (1) 91 rn_time_dmp (2:jp_bdy) = rn_time_dmp (1) 92 rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) 93 cn_ice (2:jp_bdy) = cn_ice (1) 94 nn_ice_dta (2:jp_bdy) = nn_ice_dta (1) 82 95 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries 83 96 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) 84 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' , lwp)97 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 85 98 IF(lwm) WRITE ( numond, nambdy ) 86 99 87 100 IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE. ! forced for Agrif children 101 102 IF( nb_bdy == 0 ) ln_bdy = .FALSE. 88 103 89 104 ! ----------------------------------------- … … 96 111 ! 97 112 ! Open boundaries definition (arrays and masks) 98 CALL bdy_segs 113 CALL bdy_def 114 IF( ln_meshmask ) CALL bdy_meshwri() 99 115 ! 100 116 ! Open boundaries initialisation of external data arrays … … 114 130 115 131 116 SUBROUTINE bdy_ segs132 SUBROUTINE bdy_def 117 133 !!---------------------------------------------------------------------- 118 134 !! *** ROUTINE bdy_init *** … … 125 141 !! ** Input : bdy_init.nc, input file for unstructured open boundaries 126 142 !!---------------------------------------------------------------------- 127 INTEGER :: ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 128 INTEGER :: icount, icountr, ibr_max, ilen1, ibm1 ! local integers 143 INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices 144 INTEGER :: icount, icountr, icountr0, ibr_max ! local integers 145 INTEGER :: ilen1 ! - - 129 146 INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - 130 INTEGER :: igrd_start, igrd_end, jpbdta ! - - 131 INTEGER :: jpbdtau, jpbdtas ! - - 147 INTEGER :: jpbdta ! - - 132 148 INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - 133 INTEGER :: i_offset, j_offset ! - - 134 INTEGER , POINTER :: nbi, nbj, nbr ! short cuts 135 REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! pointer to 2D mask fields 136 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 137 INTEGER, DIMENSION (2) :: kdimsz 138 INTEGER, DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays 139 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta 140 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 141 CHARACTER(LEN=1),DIMENSION(jpbgrd) :: cgrid 142 INTEGER :: com_east, com_west, com_south, com_north, jpk_max ! Flags for boundaries sending 143 INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b ! Flags for boundaries receiving 144 INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4) ! Arrays for neighbours coordinates 145 REAL(wp), TARGET, DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 146 !! 147 CHARACTER(LEN=1) :: ctypebdy ! - - 148 INTEGER :: nbdyind, nbdybeg, nbdyend 149 !! 150 NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 151 INTEGER :: ios ! Local integer output status for namelist read 149 INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - 150 INTEGER :: iibe, ijbe, iibi, ijbi ! - - 151 INTEGER :: flagu, flagv ! short cuts 152 INTEGER :: nbdyind, nbdybeg, nbdyend 153 INTEGER , DIMENSION(4) :: kdimsz 154 INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays 155 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta 156 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 157 CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid 158 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data 159 REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 160 REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 161 REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array 152 162 !!---------------------------------------------------------------------- 153 163 ! … … 160 170 & ' and general open boundary condition are not compatible' ) 161 171 162 IF( nb_bdy == 0 ) THEN 163 IF(lwp) WRITE(numout,*) 'nb_bdy = 0, NO OPEN BOUNDARIES APPLIED.' 164 ELSE 165 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 172 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 173 174 DO ib_bdy = 1,nb_bdy 175 176 IF(lwp) THEN 177 WRITE(numout,*) ' ' 178 WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------' 179 IF( ln_coords_file(ib_bdy) ) THEN 180 WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) 181 ELSE 182 WRITE(numout,*) 'Boundary defined in namelist.' 183 ENDIF 184 WRITE(numout,*) 185 ENDIF 186 187 ! barotropic bdy 188 !---------------- 189 IF(lwp) THEN 190 WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 191 SELECT CASE( cn_dyn2d(ib_bdy) ) 192 CASE( 'none' ) ; WRITE(numout,*) ' no open boundary condition' 193 CASE( 'frs' ) ; WRITE(numout,*) ' Flow Relaxation Scheme' 194 CASE( 'flather' ) ; WRITE(numout,*) ' Flather radiation condition' 195 CASE( 'orlanski' ) ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 196 CASE( 'orlanski_npo' ) ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 197 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 198 END SELECT 199 ENDIF 200 201 dta_bdy(ib_bdy)%lneed_ssh = cn_dyn2d(ib_bdy) == 'flather' 202 dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' 203 204 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 205 SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! 206 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 207 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 208 CASE( 2 ) ; WRITE(numout,*) ' tidal harmonic forcing taken from file' 209 CASE( 3 ) ; WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' 210 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 211 END SELECT 212 ENDIF 213 IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2 .AND. .NOT.ln_tide ) THEN 214 CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) 215 ENDIF 216 IF(lwp) WRITE(numout,*) 217 218 ! baroclinic bdy 219 !---------------- 220 IF(lwp) THEN 221 WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' 222 SELECT CASE( cn_dyn3d(ib_bdy) ) 223 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 224 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 225 CASE('specified') ; WRITE(numout,*) ' Specified value' 226 CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' 227 CASE('zerograd') ; WRITE(numout,*) ' Zero gradient for baroclinic velocities' 228 CASE('zero') ; WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' 229 CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 230 CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 231 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 232 END SELECT 233 ENDIF 234 235 dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs' .OR. cn_dyn3d(ib_bdy) == 'specified' & 236 & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' 237 238 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN 239 SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! 240 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 241 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 242 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 243 END SELECT 244 END IF 245 246 IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 247 IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 248 IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 249 ln_dyn3d_dmp(ib_bdy) = .false. 250 ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 251 CALL ctl_stop( 'Use FRS OR relaxation' ) 252 ELSE 253 IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone' 254 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 255 IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 256 dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. 257 ENDIF 258 ELSE 259 IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' 260 ENDIF 261 IF(lwp) WRITE(numout,*) 262 263 ! tra bdy 264 !---------------- 265 IF(lwp) THEN 266 WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' 267 SELECT CASE( cn_tra(ib_bdy) ) 268 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 269 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 270 CASE('specified') ; WRITE(numout,*) ' Specified value' 271 CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' 272 CASE('runoff') ; WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' 273 CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 274 CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 275 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) 276 END SELECT 277 ENDIF 278 279 dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs' .OR. cn_tra(ib_bdy) == 'specified' & 280 & .OR. cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' 281 282 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN 283 SELECT CASE( nn_tra_dta(ib_bdy) ) ! 284 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 285 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 286 CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 287 END SELECT 288 ENDIF 289 290 IF ( ln_tra_dmp(ib_bdy) ) THEN 291 IF ( cn_tra(ib_bdy) == 'none' ) THEN 292 IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 293 ln_tra_dmp(ib_bdy) = .false. 294 ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 295 CALL ctl_stop( 'Use FRS OR relaxation' ) 296 ELSE 297 IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' 298 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 299 IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 300 IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 301 dta_bdy(ib_bdy)%lneed_tra = .TRUE. 302 ENDIF 303 ELSE 304 IF(lwp) WRITE(numout,*) ' NO T/S relaxation' 305 ENDIF 306 IF(lwp) WRITE(numout,*) 307 308 #if defined key_si3 309 IF(lwp) THEN 310 WRITE(numout,*) 'Boundary conditions for sea ice: ' 311 SELECT CASE( cn_ice(ib_bdy) ) 312 CASE('none') ; WRITE(numout,*) ' no open boundary condition' 313 CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' 314 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' ) 315 END SELECT 316 ENDIF 317 318 dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' 319 320 IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN 321 SELECT CASE( nn_ice_dta(ib_bdy) ) ! 322 CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' 323 CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' 324 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) 325 END SELECT 326 ENDIF 327 #else 328 dta_bdy(ib_bdy)%lneed_ice = .FALSE. 329 #endif 330 ! 331 IF(lwp) WRITE(numout,*) 332 IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) 333 IF(lwp) WRITE(numout,*) 334 ! 335 END DO ! nb_bdy 336 337 IF( lwp ) THEN 338 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) 339 WRITE(numout,*) 'Volume correction applied at open boundaries' 340 WRITE(numout,*) 341 SELECT CASE ( nn_volctl ) 342 CASE( 1 ) ; WRITE(numout,*) ' The total volume will be constant' 343 CASE( 0 ) ; WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' 344 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 345 END SELECT 346 WRITE(numout,*) 347 ! 348 ! sanity check if used with tides 349 IF( ln_tide ) THEN 350 WRITE(numout,*) ' The total volume correction is not working with tides. ' 351 WRITE(numout,*) ' Set ln_vol to .FALSE. ' 352 WRITE(numout,*) ' or ' 353 WRITE(numout,*) ' equilibriate your bdy input files ' 354 CALL ctl_stop( 'The total volume correction is not working with tides.' ) 355 END IF 356 ELSE 357 WRITE(numout,*) 'No volume correction applied at open boundaries' 358 WRITE(numout,*) 359 ENDIF 166 360 ENDIF 167 168 DO ib_bdy = 1,nb_bdy169 IF(lwp) WRITE(numout,*) ' '170 IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_bdy,'------'171 172 IF( ln_coords_file(ib_bdy) ) THEN173 IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy))174 ELSE175 IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.'176 ENDIF177 IF(lwp) WRITE(numout,*)178 179 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: '180 SELECT CASE( cn_dyn2d(ib_bdy) )181 CASE( 'none' )182 IF(lwp) WRITE(numout,*) ' no open boundary condition'183 dta_bdy(ib_bdy)%ll_ssh = .false.184 dta_bdy(ib_bdy)%ll_u2d = .false.185 dta_bdy(ib_bdy)%ll_v2d = .false.186 CASE( 'frs' )187 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'188 dta_bdy(ib_bdy)%ll_ssh = .false.189 dta_bdy(ib_bdy)%ll_u2d = .true.190 dta_bdy(ib_bdy)%ll_v2d = .true.191 CASE( 'flather' )192 IF(lwp) WRITE(numout,*) ' Flather radiation condition'193 dta_bdy(ib_bdy)%ll_ssh = .true.194 dta_bdy(ib_bdy)%ll_u2d = .true.195 dta_bdy(ib_bdy)%ll_v2d = .true.196 CASE( 'orlanski' )197 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'198 dta_bdy(ib_bdy)%ll_ssh = .false.199 dta_bdy(ib_bdy)%ll_u2d = .true.200 dta_bdy(ib_bdy)%ll_v2d = .true.201 CASE( 'orlanski_npo' )202 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'203 dta_bdy(ib_bdy)%ll_ssh = .false.204 dta_bdy(ib_bdy)%ll_u2d = .true.205 dta_bdy(ib_bdy)%ll_v2d = .true.206 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' )207 END SELECT208 IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN209 SELECT CASE( nn_dyn2d_dta(ib_bdy) ) !210 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'211 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'212 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' tidal harmonic forcing taken from file'213 CASE( 3 ) ; IF(lwp) WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files'214 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' )215 END SELECT216 IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(.NOT.ln_tide)) THEN217 CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' )218 ENDIF219 ENDIF220 IF(lwp) WRITE(numout,*)221 222 IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: '223 SELECT CASE( cn_dyn3d(ib_bdy) )224 CASE('none')225 IF(lwp) WRITE(numout,*) ' no open boundary condition'226 dta_bdy(ib_bdy)%ll_u3d = .false.227 dta_bdy(ib_bdy)%ll_v3d = .false.228 CASE('frs')229 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'230 dta_bdy(ib_bdy)%ll_u3d = .true.231 dta_bdy(ib_bdy)%ll_v3d = .true.232 CASE('specified')233 IF(lwp) WRITE(numout,*) ' Specified value'234 dta_bdy(ib_bdy)%ll_u3d = .true.235 dta_bdy(ib_bdy)%ll_v3d = .true.236 CASE('neumann')237 IF(lwp) WRITE(numout,*) ' Neumann conditions'238 dta_bdy(ib_bdy)%ll_u3d = .false.239 dta_bdy(ib_bdy)%ll_v3d = .false.240 CASE('zerograd')241 IF(lwp) WRITE(numout,*) ' Zero gradient for baroclinic velocities'242 dta_bdy(ib_bdy)%ll_u3d = .false.243 dta_bdy(ib_bdy)%ll_v3d = .false.244 CASE('zero')245 IF(lwp) WRITE(numout,*) ' Zero baroclinic velocities (runoff case)'246 dta_bdy(ib_bdy)%ll_u3d = .false.247 dta_bdy(ib_bdy)%ll_v3d = .false.248 CASE('orlanski')249 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'250 dta_bdy(ib_bdy)%ll_u3d = .true.251 dta_bdy(ib_bdy)%ll_v3d = .true.252 CASE('orlanski_npo')253 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'254 dta_bdy(ib_bdy)%ll_u3d = .true.255 dta_bdy(ib_bdy)%ll_v3d = .true.256 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' )257 END SELECT258 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN259 SELECT CASE( nn_dyn3d_dta(ib_bdy) ) !260 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'261 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'262 CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' )263 END SELECT264 ENDIF265 266 IF ( ln_dyn3d_dmp(ib_bdy) ) THEN267 IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN268 IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.'269 ln_dyn3d_dmp(ib_bdy)=.false.270 ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN271 CALL ctl_stop( 'Use FRS OR relaxation' )272 ELSE273 IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone'274 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days'275 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )276 dta_bdy(ib_bdy)%ll_u3d = .true.277 dta_bdy(ib_bdy)%ll_v3d = .true.278 ENDIF279 ELSE280 IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities'281 ENDIF282 IF(lwp) WRITE(numout,*)283 284 IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: '285 SELECT CASE( cn_tra(ib_bdy) )286 CASE('none')287 IF(lwp) WRITE(numout,*) ' no open boundary condition'288 dta_bdy(ib_bdy)%ll_tem = .false.289 dta_bdy(ib_bdy)%ll_sal = .false.290 CASE('frs')291 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'292 dta_bdy(ib_bdy)%ll_tem = .true.293 dta_bdy(ib_bdy)%ll_sal = .true.294 CASE('specified')295 IF(lwp) WRITE(numout,*) ' Specified value'296 dta_bdy(ib_bdy)%ll_tem = .true.297 dta_bdy(ib_bdy)%ll_sal = .true.298 CASE('neumann')299 IF(lwp) WRITE(numout,*) ' Neumann conditions'300 dta_bdy(ib_bdy)%ll_tem = .false.301 dta_bdy(ib_bdy)%ll_sal = .false.302 CASE('runoff')303 IF(lwp) WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity'304 dta_bdy(ib_bdy)%ll_tem = .false.305 dta_bdy(ib_bdy)%ll_sal = .false.306 CASE('orlanski')307 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging'308 dta_bdy(ib_bdy)%ll_tem = .true.309 dta_bdy(ib_bdy)%ll_sal = .true.310 CASE('orlanski_npo')311 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging'312 dta_bdy(ib_bdy)%ll_tem = .true.313 dta_bdy(ib_bdy)%ll_sal = .true.314 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' )315 END SELECT316 IF( cn_tra(ib_bdy) /= 'none' ) THEN317 SELECT CASE( nn_tra_dta(ib_bdy) ) !318 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'319 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'320 CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' )321 END SELECT322 ENDIF323 324 IF ( ln_tra_dmp(ib_bdy) ) THEN325 IF ( cn_tra(ib_bdy) == 'none' ) THEN326 IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.'327 ln_tra_dmp(ib_bdy)=.false.328 ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN329 CALL ctl_stop( 'Use FRS OR relaxation' )330 ELSE331 IF(lwp) WRITE(numout,*) ' + T/S relaxation zone'332 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days'333 IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days'334 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )335 dta_bdy(ib_bdy)%ll_tem = .true.336 dta_bdy(ib_bdy)%ll_sal = .true.337 ENDIF338 ELSE339 IF(lwp) WRITE(numout,*) ' NO T/S relaxation'340 ENDIF341 IF(lwp) WRITE(numout,*)342 343 #if defined key_si3344 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: '345 SELECT CASE( cn_ice(ib_bdy) )346 CASE('none')347 IF(lwp) WRITE(numout,*) ' no open boundary condition'348 dta_bdy(ib_bdy)%ll_a_i = .false.349 dta_bdy(ib_bdy)%ll_h_i = .false.350 dta_bdy(ib_bdy)%ll_h_s = .false.351 CASE('frs')352 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme'353 dta_bdy(ib_bdy)%ll_a_i = .true.354 dta_bdy(ib_bdy)%ll_h_i = .true.355 dta_bdy(ib_bdy)%ll_h_s = .true.356 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' )357 END SELECT358 IF( cn_ice(ib_bdy) /= 'none' ) THEN359 SELECT CASE( nn_ice_dta(ib_bdy) ) !360 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data'361 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file'362 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' )363 END SELECT364 ENDIF365 IF(lwp) WRITE(numout,*)366 IF(lwp) WRITE(numout,*) ' tem of bdy sea-ice = ', rn_ice_tem(ib_bdy)367 IF(lwp) WRITE(numout,*) ' sal of bdy sea-ice = ', rn_ice_sal(ib_bdy)368 IF(lwp) WRITE(numout,*) ' age of bdy sea-ice = ', rn_ice_age(ib_bdy)369 #endif370 371 IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy)372 IF(lwp) WRITE(numout,*)373 !374 END DO375 376 IF( nb_bdy > 0 ) THEN377 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value)378 IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries'379 IF(lwp) WRITE(numout,*)380 SELECT CASE ( nn_volctl )381 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' The total volume will be constant'382 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' The total volume will vary according to the surface E-P flux'383 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' )384 END SELECT385 IF(lwp) WRITE(numout,*)386 !387 ! sanity check if used with tides388 IF( ln_tide ) THEN389 IF(lwp) WRITE(numout,*) ' The total volume correction is not working with tides. '390 IF(lwp) WRITE(numout,*) ' Set ln_vol to .FALSE. '391 IF(lwp) WRITE(numout,*) ' or '392 IF(lwp) WRITE(numout,*) ' equilibriate your bdy input files '393 CALL ctl_stop( 'The total volume correction is not working with tides.' )394 END IF395 ELSE396 IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries'397 IF(lwp) WRITE(numout,*)398 ENDIF399 IF( nb_jpk_bdy(ib_bdy) > 0 ) THEN400 IF(lwp) WRITE(numout,*) '*** open boundary will be interpolate in the vertical onto the native grid ***'401 ELSE402 IF(lwp) WRITE(numout,*) '*** open boundary will be read straight onto the native grid without vertical interpolation ***'403 ENDIF404 ENDIF405 361 406 362 ! ------------------------------------------------- … … 408 364 ! ------------------------------------------------- 409 365 410 ! Work out global dimensions of boundary data411 ! ---------------------------------------------412 366 REWIND( numnam_cfg ) 413 414 367 nblendta(:,:) = 0 415 368 nbdysege = 0 … … 417 370 nbdysegn = 0 418 371 nbdysegs = 0 419 icount = 0 ! count user defined segments 420 ! Dimensions below are used to allocate arrays to read external data 421 jpbdtas = 1 ! Maximum size of boundary data (structured case) 422 jpbdtau = 1 ! Maximum size of boundary data (unstructured case) 423 372 373 ! Define all boundaries 374 ! --------------------- 424 375 DO ib_bdy = 1, nb_bdy 425 426 IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters 427 428 icount = icount + 1 429 ! No REWIND here because may need to read more than one nambdy_index namelist. 430 ! Read only namelist_cfg to avoid unseccessfull overwrite 431 ! keep full control of the configuration namelist 432 READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 433 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist', lwp ) 434 IF(lwm) WRITE ( numond, nambdy_index ) 435 436 SELECT CASE ( TRIM(ctypebdy) ) 437 CASE( 'N' ) 438 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 439 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. 440 nbdybeg = 2 441 nbdyend = jpiglo - 1 442 ENDIF 443 nbdysegn = nbdysegn + 1 444 npckgn(nbdysegn) = ib_bdy ! Save bdy package number 445 jpjnob(nbdysegn) = nbdyind 446 jpindt(nbdysegn) = nbdybeg 447 jpinft(nbdysegn) = nbdyend 448 ! 449 CASE( 'S' ) 450 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 451 nbdyind = 2 ! set boundary to whole side of model domain. 452 nbdybeg = 2 453 nbdyend = jpiglo - 1 454 ENDIF 455 nbdysegs = nbdysegs + 1 456 npckgs(nbdysegs) = ib_bdy ! Save bdy package number 457 jpjsob(nbdysegs) = nbdyind 458 jpisdt(nbdysegs) = nbdybeg 459 jpisft(nbdysegs) = nbdyend 460 ! 461 CASE( 'E' ) 462 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 463 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain. 464 nbdybeg = 2 465 nbdyend = jpjglo - 1 466 ENDIF 467 nbdysege = nbdysege + 1 468 npckge(nbdysege) = ib_bdy ! Save bdy package number 469 jpieob(nbdysege) = nbdyind 470 jpjedt(nbdysege) = nbdybeg 471 jpjeft(nbdysege) = nbdyend 472 ! 473 CASE( 'W' ) 474 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 475 nbdyind = 2 ! set boundary to whole side of model domain. 476 nbdybeg = 2 477 nbdyend = jpjglo - 1 478 ENDIF 479 nbdysegw = nbdysegw + 1 480 npckgw(nbdysegw) = ib_bdy ! Save bdy package number 481 jpiwob(nbdysegw) = nbdyind 482 jpjwdt(nbdysegw) = nbdybeg 483 jpjwft(nbdysegw) = nbdyend 484 ! 485 CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 486 END SELECT 487 488 ! For simplicity we assume that in case of straight bdy, arrays have the same length 489 ! (even if it is true that last tangential velocity points 490 ! are useless). This simplifies a little bit boundary data format (and agrees with format 491 ! used so far in obc package) 492 493 nblendta(1:jpbgrd,ib_bdy) = (nbdyend - nbdybeg + 1) * nn_rimwidth(ib_bdy) 494 jpbdtas = MAX(jpbdtas, (nbdyend - nbdybeg + 1)) 495 IF (lwp.and.(nn_rimwidth(ib_bdy)>nrimmax)) & 496 & CALL ctl_stop( 'rimwidth must be lower than nrimmax' ) 497 498 ELSE ! Read size of arrays in boundary coordinates file. 376 ! 377 IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! build bdy coordinates with segments defined in namelist 378 379 CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) 380 381 ELSE ! Read size of arrays in boundary coordinates file. 382 499 383 CALL iom_open( cn_coords_file(ib_bdy), inum ) 500 384 DO igrd = 1, jpbgrd 501 385 id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) 502 386 nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) 503 jpbdtau = MAX(jpbdtau, MAXVAL(kdimsz))504 387 END DO 505 388 CALL iom_close( inum ) 506 ! 507 ENDIF 389 ENDIF 508 390 ! 509 391 END DO ! ib_bdy 510 392 511 IF (nb_bdy>0) THEN512 jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy))513 514 ! Allocate arrays515 !---------------516 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), &517 & nbrdta(jpbdta, jpbgrd, nb_bdy) )518 519 jpk_max = MAXVAL(nb_jpk_bdy)520 jpk_max = MAX(jpk_max, jpk)521 522 ALLOCATE( dta_global(jpbdtau, 1, jpk_max) )523 ALLOCATE( dta_global_z(jpbdtau, 1, jpk_max) ) ! needed ?? TODO524 ALLOCATE( dta_global_dz(jpbdtau, 1, jpk_max) )! needed ?? TODO525 526 IF ( icount>0 ) THEN527 ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk_max) )528 ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk_max) ) ! needed ?? TODO529 ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk_max) )! needed ?? TODO530 ENDIF531 !532 ENDIF533 534 393 ! Now look for crossings in user (namelist) defined open boundary segments: 535 !-------------------------------------------------------------------------- 536 IF( icount>0 ) CALL bdy_ctl_seg 537 394 IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0) CALL bdy_ctl_seg 395 396 ! Allocate arrays 397 !--------------- 398 jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) 399 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) 400 538 401 ! Calculate global boundary index arrays or read in from file 539 402 !------------------------------------------------------------ … … 543 406 IF( ln_coords_file(ib_bdy) ) THEN 544 407 ! 408 ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) ) 545 409 CALL iom_open( cn_coords_file(ib_bdy), inum ) 410 ! 546 411 DO igrd = 1, jpbgrd 547 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )412 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 548 413 DO ii = 1,nblendta(igrd,ib_bdy) 549 nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )414 nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 550 415 END DO 551 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )416 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 552 417 DO ii = 1,nblendta(igrd,ib_bdy) 553 nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )418 nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 554 419 END DO 555 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )420 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 556 421 DO ii = 1,nblendta(igrd,ib_bdy) 557 nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )422 nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 558 423 END DO 559 424 ! … … 563 428 IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) 564 429 IF (ibr_max < nn_rimwidth(ib_bdy)) & 565 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 566 END DO 430 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 431 END DO 432 ! 567 433 CALL iom_close( inum ) 434 DEALLOCATE( zz_read ) 568 435 ! 569 ENDIF 570 ! 571 END DO 572 436 ENDIF 437 ! 438 END DO 439 573 440 ! 2. Now fill indices corresponding to straight open boundary arrays: 574 ! East 575 !----- 576 DO iseg = 1, nbdysege 577 ib_bdy = npckge(iseg) 578 ! 579 ! ------------ T points ------------- 580 igrd=1 581 icount=0 582 DO ir = 1, nn_rimwidth(ib_bdy) 583 DO ij = jpjedt(iseg), jpjeft(iseg) 584 icount = icount + 1 585 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 586 nbjdta(icount, igrd, ib_bdy) = ij 587 nbrdta(icount, igrd, ib_bdy) = ir 588 ENDDO 589 ENDDO 590 ! 591 ! ------------ U points ------------- 592 igrd=2 593 icount=0 594 DO ir = 1, nn_rimwidth(ib_bdy) 595 DO ij = jpjedt(iseg), jpjeft(iseg) 596 icount = icount + 1 597 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 598 nbjdta(icount, igrd, ib_bdy) = ij 599 nbrdta(icount, igrd, ib_bdy) = ir 600 ENDDO 601 ENDDO 602 ! 603 ! ------------ V points ------------- 604 igrd=3 605 icount=0 606 DO ir = 1, nn_rimwidth(ib_bdy) 607 ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 608 DO ij = jpjedt(iseg), jpjeft(iseg) 609 icount = icount + 1 610 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 611 nbjdta(icount, igrd, ib_bdy) = ij 612 nbrdta(icount, igrd, ib_bdy) = ir 613 ENDDO 614 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 615 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 616 ENDDO 617 ENDDO 618 ! 619 ! West 620 !----- 621 DO iseg = 1, nbdysegw 622 ib_bdy = npckgw(iseg) 623 ! 624 ! ------------ T points ------------- 625 igrd=1 626 icount=0 627 DO ir = 1, nn_rimwidth(ib_bdy) 628 DO ij = jpjwdt(iseg), jpjwft(iseg) 629 icount = icount + 1 630 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 631 nbjdta(icount, igrd, ib_bdy) = ij 632 nbrdta(icount, igrd, ib_bdy) = ir 633 ENDDO 634 ENDDO 635 ! 636 ! ------------ U points ------------- 637 igrd=2 638 icount=0 639 DO ir = 1, nn_rimwidth(ib_bdy) 640 DO ij = jpjwdt(iseg), jpjwft(iseg) 641 icount = icount + 1 642 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 643 nbjdta(icount, igrd, ib_bdy) = ij 644 nbrdta(icount, igrd, ib_bdy) = ir 645 ENDDO 646 ENDDO 647 ! 648 ! ------------ V points ------------- 649 igrd=3 650 icount=0 651 DO ir = 1, nn_rimwidth(ib_bdy) 652 ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 653 DO ij = jpjwdt(iseg), jpjwft(iseg) 654 icount = icount + 1 655 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 656 nbjdta(icount, igrd, ib_bdy) = ij 657 nbrdta(icount, igrd, ib_bdy) = ir 658 ENDDO 659 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 660 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 661 ENDDO 662 ENDDO 663 ! 664 ! North 665 !----- 666 DO iseg = 1, nbdysegn 667 ib_bdy = npckgn(iseg) 668 ! 669 ! ------------ T points ------------- 670 igrd=1 671 icount=0 672 DO ir = 1, nn_rimwidth(ib_bdy) 673 DO ii = jpindt(iseg), jpinft(iseg) 674 icount = icount + 1 675 nbidta(icount, igrd, ib_bdy) = ii 676 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 677 nbrdta(icount, igrd, ib_bdy) = ir 678 ENDDO 679 ENDDO 680 ! 681 ! ------------ U points ------------- 682 igrd=2 683 icount=0 684 DO ir = 1, nn_rimwidth(ib_bdy) 685 ! DO ii = jpindt(iseg), jpinft(iseg) - 1 686 DO ii = jpindt(iseg), jpinft(iseg) 687 icount = icount + 1 688 nbidta(icount, igrd, ib_bdy) = ii 689 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 690 nbrdta(icount, igrd, ib_bdy) = ir 691 ENDDO 692 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 693 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 694 ENDDO 695 ! 696 ! ------------ V points ------------- 697 igrd=3 698 icount=0 699 DO ir = 1, nn_rimwidth(ib_bdy) 700 DO ii = jpindt(iseg), jpinft(iseg) 701 icount = icount + 1 702 nbidta(icount, igrd, ib_bdy) = ii 703 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 704 nbrdta(icount, igrd, ib_bdy) = ir 705 ENDDO 706 ENDDO 707 ENDDO 708 ! 709 ! South 710 !----- 711 DO iseg = 1, nbdysegs 712 ib_bdy = npckgs(iseg) 713 ! 714 ! ------------ T points ------------- 715 igrd=1 716 icount=0 717 DO ir = 1, nn_rimwidth(ib_bdy) 718 DO ii = jpisdt(iseg), jpisft(iseg) 719 icount = icount + 1 720 nbidta(icount, igrd, ib_bdy) = ii 721 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 722 nbrdta(icount, igrd, ib_bdy) = ir 723 ENDDO 724 ENDDO 725 ! 726 ! ------------ U points ------------- 727 igrd=2 728 icount=0 729 DO ir = 1, nn_rimwidth(ib_bdy) 730 ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 731 DO ii = jpisdt(iseg), jpisft(iseg) 732 icount = icount + 1 733 nbidta(icount, igrd, ib_bdy) = ii 734 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 735 nbrdta(icount, igrd, ib_bdy) = ir 736 ENDDO 737 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 738 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 739 ENDDO 740 ! 741 ! ------------ V points ------------- 742 igrd=3 743 icount=0 744 DO ir = 1, nn_rimwidth(ib_bdy) 745 DO ii = jpisdt(iseg), jpisft(iseg) 746 icount = icount + 1 747 nbidta(icount, igrd, ib_bdy) = ii 748 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 749 nbrdta(icount, igrd, ib_bdy) = ir 750 ENDDO 751 ENDDO 752 ENDDO 441 CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) 753 442 754 443 ! Deal with duplicated points … … 764 453 DO ib2 = 1, nblendta(igrd,ib_bdy2) 765 454 IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & 766 & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN767 ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', &768 ! & nbidta(ib1, igrd, ib_bdy1), &769 ! & nbjdta(ib2, igrd, ib_bdy2)455 & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN 456 ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & 457 ! & nbidta(ib1, igrd, ib_bdy1), & 458 ! & nbjdta(ib2, igrd, ib_bdy2) 770 459 ! keep only points with the lowest distance to boundary: 771 460 IF (nbrdta(ib1, igrd, ib_bdy1)<nbrdta(ib2, igrd, ib_bdy2)) THEN 772 nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2773 nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2461 nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 462 nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 774 463 ELSEIF (nbrdta(ib1, igrd, ib_bdy1)>nbrdta(ib2, igrd, ib_bdy2)) THEN 775 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1776 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1777 ! Arbitrary choice if distances are the same:464 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 465 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 466 ! Arbitrary choice if distances are the same: 778 467 ELSE 779 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1780 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1468 nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 469 nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 781 470 ENDIF 782 471 END IF … … 787 476 END DO 788 477 END DO 789 790 ! Work out dimensions of boundary data on each processor 791 ! ------------------------------------------------------ 792 793 ! Rather assume that boundary data indices are given on global domain 794 ! TO BE DISCUSSED ? 795 ! iw = mig(1) + 1 ! if monotasking and no zoom, iw=2 796 ! ie = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 797 ! is = mjg(1) + 1 ! if monotasking and no zoom, is=2 798 ! in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 799 iwe = mig(1) - 1 + 2 ! if monotasking and no zoom, iw=2 800 ies = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 801 iso = mjg(1) - 1 + 2 ! if monotasking and no zoom, is=2 802 ino = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 803 804 ALLOCATE( nbondi_bdy(nb_bdy)) 805 ALLOCATE( nbondj_bdy(nb_bdy)) 806 nbondi_bdy(:)=2 807 nbondj_bdy(:)=2 808 ALLOCATE( nbondi_bdy_b(nb_bdy)) 809 ALLOCATE( nbondj_bdy_b(nb_bdy)) 810 nbondi_bdy_b(:)=2 811 nbondj_bdy_b(:)=2 812 813 ! Work out dimensions of boundary data on each neighbour process 814 IF(nbondi == 0) THEN 815 iw_b(1) = 1 + nimppt(nowe+1) 816 ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 817 is_b(1) = 1 + njmppt(nowe+1) 818 in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 819 820 iw_b(2) = 1 + nimppt(noea+1) 821 ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 822 is_b(2) = 1 + njmppt(noea+1) 823 in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 824 ELSEIF(nbondi == 1) THEN 825 iw_b(1) = 1 + nimppt(nowe+1) 826 ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 827 is_b(1) = 1 + njmppt(nowe+1) 828 in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 829 ELSEIF(nbondi == -1) THEN 830 iw_b(2) = 1 + nimppt(noea+1) 831 ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 832 is_b(2) = 1 + njmppt(noea+1) 833 in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 834 ENDIF 835 836 IF(nbondj == 0) THEN 837 iw_b(3) = 1 + nimppt(noso+1) 838 ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 839 is_b(3) = 1 + njmppt(noso+1) 840 in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 841 842 iw_b(4) = 1 + nimppt(nono+1) 843 ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 844 is_b(4) = 1 + njmppt(nono+1) 845 in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 846 ELSEIF(nbondj == 1) THEN 847 iw_b(3) = 1 + nimppt(noso+1) 848 ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 849 is_b(3) = 1 + njmppt(noso+1) 850 in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 851 ELSEIF(nbondj == -1) THEN 852 iw_b(4) = 1 + nimppt(nono+1) 853 ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 854 is_b(4) = 1 + njmppt(nono+1) 855 in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 856 ENDIF 857 478 ! 479 ! Find lenght of boundaries and rim on local mpi domain 480 !------------------------------------------------------ 481 ! 482 iwe = mig(1) 483 ies = mig(jpi) 484 iso = mjg(1) 485 ino = mjg(jpj) 486 ! 858 487 DO ib_bdy = 1, nb_bdy 859 488 DO igrd = 1, jpbgrd 860 icount = 0 861 icountr = 0 862 idx_bdy(ib_bdy)%nblen(igrd) = 0 863 idx_bdy(ib_bdy)%nblenrim(igrd) = 0 489 icount = 0 ! initialization of local bdy length 490 icountr = 0 ! initialization of local rim 0 and rim 1 bdy length 491 icountr0 = 0 ! initialization of local rim 0 bdy length 492 idx_bdy(ib_bdy)%nblen(igrd) = 0 493 idx_bdy(ib_bdy)%nblenrim(igrd) = 0 494 idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 864 495 DO ib = 1, nblendta(igrd,ib_bdy) 865 496 ! check that data is in correct order in file 866 ibm1 = MAX(1,ib-1) 867 IF(lwp) THEN ! Since all procs read global data only need to do this check on one proc... 868 IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN 497 IF( ib > 1 ) THEN 498 IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN 869 499 CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & 870 871 872 ENDIF 500 & ' in order of distance from edge nbr A utility for re-ordering ', & 501 & ' boundary coordinates and data files exists in the TOOLS/OBC directory') 502 ENDIF 873 503 ENDIF 874 504 ! check if point is in local domain … … 876 506 & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN 877 507 ! 878 icount = icount 879 !880 IF( nbrdta(ib,igrd,ib_bdy) == 1 ) icountr = icountr+1508 icount = icount + 1 509 IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 ) icountr = icountr + 1 510 IF( nbrdta(ib,igrd,ib_bdy) == 0 ) icountr0 = icountr0 + 1 881 511 ENDIF 882 512 END DO 883 idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 884 idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc 885 END DO ! igrd 513 idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc 514 idx_bdy(ib_bdy)%nblenrim (igrd) = icountr !: length of rim 0 and rim 1 boundary data on each proc 515 idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc 516 END DO ! igrd 886 517 887 518 ! Allocate index arrays for this boundary set … … 893 524 & idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) , & 894 525 & idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) , & 526 & idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) , & 895 527 & idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) , & 896 528 & idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) , & … … 900 532 ! Dispatch mapping indices and discrete distances on each processor 901 533 ! ----------------------------------------------------------------- 902 903 com_east = 0904 com_west = 0905 com_south = 0906 com_north = 0907 908 com_east_b = 0909 com_west_b = 0910 com_south_b = 0911 com_north_b = 0912 913 534 DO igrd = 1, jpbgrd 914 535 icount = 0 915 ! Loop on rimwidth to ensure outermost points come first in the local arrays.916 DO ir =1, nn_rimwidth(ib_bdy)536 ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. 537 DO ir = 0, nn_rimwidth(ib_bdy) 917 538 DO ib = 1, nblendta(igrd,ib_bdy) 918 539 ! check if point is in local domain and equals ir … … 922 543 ! 923 544 icount = icount + 1 924 925 ! Rather assume that boundary data indices are given on global domain 926 ! TO BE DISCUSSED ? 927 ! idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 928 ! idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 929 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 930 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 931 ! check if point has to be sent 932 ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 933 ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 934 if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then 935 com_east = 1 936 elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 937 com_west = 1 938 endif 939 if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 940 com_south = 1 941 elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then 942 com_north = 1 943 endif 545 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 ! global to local indexes 546 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 ! global to local indexes 944 547 idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) 945 548 idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 946 549 ENDIF 947 ! check if point has to be received from a neighbour 948 IF(nbondi == 0) THEN 949 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & 950 & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & 951 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 952 ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 953 if( ii == (nlcit(nowe+1)-1) ) then 954 ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 955 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 956 com_south = 1 957 elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 958 com_north = 1 959 endif 960 com_west_b = 1 961 endif 962 ENDIF 963 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & 964 & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & 965 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 966 ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 967 if( ii == 2 ) then 968 ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 969 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 970 com_south = 1 971 elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 972 com_north = 1 973 endif 974 com_east_b = 1 975 endif 976 ENDIF 977 ELSEIF(nbondi == 1) THEN 978 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & 979 & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & 980 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 981 ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 982 if( ii == (nlcit(nowe+1)-1) ) then 983 ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 984 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 985 com_south = 1 986 elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 987 com_north = 1 988 endif 989 com_west_b = 1 990 endif 991 ENDIF 992 ELSEIF(nbondi == -1) THEN 993 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & 994 & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & 995 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 996 ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 997 if( ii == 2 ) then 998 ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 999 if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 1000 com_south = 1 1001 elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 1002 com_north = 1 1003 endif 1004 com_east_b = 1 1005 endif 1006 ENDIF 1007 ENDIF 1008 IF(nbondj == 0) THEN 1009 IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & 1010 & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 1011 & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1012 com_north_b = 1 1013 ENDIF 1014 IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 & 1015 &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 1016 & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1017 com_south_b = 1 1018 ENDIF 1019 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & 1020 & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & 1021 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1022 ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 1023 if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 1024 com_south_b = 1 1025 endif 1026 ENDIF 1027 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & 1028 & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & 1029 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1030 ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 1031 if((com_north_b .ne. 1) .and. (ij == 2)) then 1032 com_north_b = 1 1033 endif 1034 ENDIF 1035 ELSEIF(nbondj == 1) THEN 1036 IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. & 1037 & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 1038 & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1039 com_south_b = 1 1040 ENDIF 1041 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & 1042 & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & 1043 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1044 ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 1045 if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 1046 com_south_b = 1 1047 endif 1048 ENDIF 1049 ELSEIF(nbondj == -1) THEN 1050 IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & 1051 & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 1052 & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 1053 com_north_b = 1 1054 ENDIF 1055 IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & 1056 & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & 1057 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 1058 ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 1059 if((com_north_b .ne. 1) .and. (ij == 2)) then 1060 com_north_b = 1 1061 endif 1062 ENDIF 1063 ENDIF 1064 ENDDO 1065 ENDDO 1066 ENDDO 1067 1068 ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries 1069 IF( (com_east == 1) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 0 1070 ELSEIF( (com_east == 1) .and. (com_west == 0) ) THEN ; nbondi_bdy(ib_bdy) = -1 1071 ELSEIF( (com_east == 0) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 1 1072 ENDIF 1073 IF( (com_north == 1) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 0 1074 ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN ; nbondj_bdy(ib_bdy) = -1 1075 ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 1 1076 ENDIF 1077 1078 ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries 1079 IF( (com_east_b == 1) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 0 1080 ELSEIF( (com_east_b == 1) .and. (com_west_b == 0) ) THEN ; nbondi_bdy_b(ib_bdy) = -1 1081 ELSEIF( (com_east_b == 0) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 1 1082 ENDIF 1083 IF( (com_north_b == 1) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 0 1084 ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN ; nbondj_bdy_b(ib_bdy) = -1 1085 ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 1 1086 ENDIF 550 END DO 551 END DO 552 END DO ! igrd 553 554 END DO ! ib_bdy 555 556 ! Initialize array indicating communications in bdy 557 ! ------------------------------------------------- 558 ALLOCATE( lsend_bdy(nb_bdy,jpbgrd,4,0:1), lrecv_bdy(nb_bdy,jpbgrd,4,0:1) ) 559 lsend_bdy(:,:,:,:) = .false. 560 lrecv_bdy(:,:,:,:) = .false. 561 562 DO ib_bdy = 1, nb_bdy 563 DO igrd = 1, jpbgrd 564 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! only the rim triggers communications, see bdy routines 565 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 566 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 567 IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN ; ir = 0 568 ELSE ; ir = 1 569 END IF 570 ! 571 ! check if point has to be sent to a neighbour 572 ! W neighbour and on the inner left side 573 IF( ii == 2 .and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true. 574 ! E neighbour and on the inner right side 575 IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true. 576 ! S neighbour and on the inner down side 577 IF( ij == 2 .and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true. 578 ! N neighbour and on the inner up side 579 IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true. 580 ! 581 ! check if point has to be received from a neighbour 582 ! W neighbour and on the outter left side 583 IF( ii == 1 .and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true. 584 ! E neighbour and on the outter right side 585 IF( ii == jpi .and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true. 586 ! S neighbour and on the outter down side 587 IF( ij == 1 .and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true. 588 ! N neighbour and on the outter up side 589 IF( ij == jpj .and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true. 590 ! 591 END DO 592 END DO ! igrd 1087 593 1088 594 ! Compute rim weights for FRS scheme … … 1090 596 DO igrd = 1, jpbgrd 1091 597 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 1092 nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)1093 idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 ) ! tanh formulation1094 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic1095 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)) ! linear1096 END DO 1097 END DO 598 ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same weights 599 idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 ) ! tanh formulation 600 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 601 ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)) ! linear 602 END DO 603 END DO 1098 604 1099 605 ! Compute damping coefficients … … 1101 607 DO igrd = 1, jpbgrd 1102 608 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 1103 nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)609 ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same damping coefficients 1104 610 idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & 1105 & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic611 & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 1106 612 idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & 1107 & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic1108 END DO 1109 END DO 1110 1111 END DO 613 & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic 614 END DO 615 END DO 616 617 END DO ! ib_bdy 1112 618 1113 619 ! ------------------------------------------------------ 1114 620 ! Initialise masks and find normal/tangential directions 1115 621 ! ------------------------------------------------------ 622 623 ! ------------------------------------------ 624 ! handle rim0, do as if rim 1 was free ocean 625 ! ------------------------------------------ 626 627 ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) 628 ! For the flagu/flagv calculation below we require a version of fmask without 629 ! the land boundary condition (shlat) included: 630 DO ij = 1, jpjm1 631 DO ii = 1, jpim1 632 zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & 633 & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 634 END DO 635 END DO 636 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 1116 637 1117 638 ! Read global 2D mask at T-points: bdytmask … … 1119 640 ! bdytmask = 1 on the computational domain AND on open boundaries 1120 641 ! = 0 elsewhere 1121 642 1122 643 bdytmask(:,:) = ssmask(:,:) 1123 644 1124 645 ! Derive mask on U and V grid from mask on T grid 1125 1126 bdyumask(:,:) = 0._wp1127 bdyvmask(:,:) = 0._wp1128 646 DO ij = 1, jpjm1 1129 647 DO ii = 1, jpim1 1130 bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij)648 bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) 1131 649 bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii ,ij+1) 1132 650 END DO 1133 651 END DO 1134 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1. ) ! Lateral boundary cond. 1135 1136 ! bdy masks are now set to zero on boundary points: 1137 ! 1138 igrd = 1 652 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. ) ! Lateral boundary cond. 653 654 ! bdy masks are now set to zero on rim 0 points: 1139 655 DO ib_bdy = 1, nb_bdy 1140 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1141 bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1142 END DO 1143 END DO 1144 ! 1145 igrd = 2 656 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 657 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 658 END DO 659 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 660 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 661 END DO 662 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 663 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 664 END DO 665 END DO 666 667 CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 668 669 ! ------------------------------------ 670 ! handle rim1, do as if rim 0 was land 671 ! ------------------------------------ 672 673 ! z[tuv]mask are now set to zero on rim 0 points: 1146 674 DO ib_bdy = 1, nb_bdy 1147 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1148 bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1149 END DO 1150 END DO 1151 ! 1152 igrd = 3 675 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 676 ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 677 END DO 678 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 679 zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 680 END DO 681 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 682 zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 683 END DO 684 END DO 685 686 ! Recompute zfmask 687 DO ij = 1, jpjm1 688 DO ii = 1, jpim1 689 zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & 690 & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 691 END DO 692 END DO 693 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 694 695 ! bdy masks are now set to zero on rim1 points: 1153 696 DO ib_bdy = 1, nb_bdy 1154 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1155 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 1156 END DO 1157 END DO 1158 1159 ! For the flagu/flagv calculation below we require a version of fmask without 1160 ! the land boundary condition (shlat) included: 1161 zfmask(:,:) = 0 1162 DO ij = 2, jpjm1 1163 DO ii = 2, jpim1 1164 zfmask(ii,ij) = tmask(ii,ij ,1) * tmask(ii+1,ij ,1) & 1165 & * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 1166 END DO 1167 END DO 1168 1169 ! Lateral boundary conditions 1170 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 1171 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1., bdytmask, 'T', 1. ) 697 DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 698 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 699 END DO 700 DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 701 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 702 END DO 703 DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 704 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 705 END DO 706 END DO 707 708 CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 709 ! 710 ! Check which boundaries might need communication 711 ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,4,0:1), lrecv_bdyint(nb_bdy,jpbgrd,4,0:1) ) 712 lsend_bdyint(:,:,:,:) = .false. 713 lrecv_bdyint(:,:,:,:) = .false. 714 ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,4,0:1), lrecv_bdyext(nb_bdy,jpbgrd,4,0:1) ) 715 lsend_bdyext(:,:,:,:) = .false. 716 lrecv_bdyext(:,:,:,:) = .false. 717 ! 718 DO igrd = 1, jpbgrd 719 DO ib_bdy = 1, nb_bdy 720 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 721 IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE 722 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 723 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 724 ir = idx_bdy(ib_bdy)%nbr(ib,igrd) 725 flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) 726 flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) 727 iibe = ii - flagu ! neighbouring point towards the exterior of the computational domain 728 ijbe = ij - flagv 729 iibi = ii + flagu ! neighbouring point towards the interior of the computational domain 730 ijbi = ij + flagv 731 CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 ) ! free ocean neighbours 732 ! 733 ! search neighbour in the west/east direction 734 ! Rim is on the halo and computed ocean is towards exterior of mpi domain 735 ! <-- (o exterior) --> 736 ! (1) o|x OR (2) x|o 737 ! |___ ___| 738 IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. 739 IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true. 740 IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. 741 IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true. 742 ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 743 ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: 744 ! : | x:o | neighbour limited by ... would need o | o:x | : 745 ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: 746 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. & 747 & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 748 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & 749 & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 750 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 751 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 752 ! 753 ! search neighbour in the north/south direction 754 ! Rim is on the halo and computed ocean is towards exterior of mpi domain 755 !(3) | | ^ ___o___ 756 ! | |___x___| OR | | x | 757 ! v o (4) | | 758 IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. 759 IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. 760 IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. 761 IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. 762 ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo 763 ! ^ | o | : : 764 ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| 765 ! :_________: (3) S neighbour N neighbour (4) v | o | 766 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. & 767 & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 768 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & 769 & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 770 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 771 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 772 END DO 773 END DO 774 END DO 775 776 DO ib_bdy = 1,nb_bdy 777 IF( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & 778 & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & 779 & cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' ) THEN 780 DO igrd = 1, jpbgrd 781 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 782 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 783 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 784 IF( mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2 ) THEN 785 WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 786 CALL ctl_stop( ctmp1 ) 787 END IF 788 END DO 789 END DO 790 END IF 791 END DO 792 ! 793 DEALLOCATE( nbidta, nbjdta, nbrdta ) 794 ! 795 END SUBROUTINE bdy_def 796 797 798 SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) 799 !!---------------------------------------------------------------------- 800 !! *** ROUTINE bdy_rim_treat *** 801 !! 802 !! ** Purpose : Initialize structures ( flagu, flagv, ntreat ) indicating how rim points 803 !! are to be handled in the boundary condition treatment 804 !! 805 !! ** Method : - to handle rim 0 zmasks must indicate ocean points (set at one on rim 0 and rim 1 and interior) 806 !! and bdymasks must be set at 0 on rim 0 (set at one on rim 1 and interior) 807 !! (as if rim 1 was free ocean) 808 !! - to handle rim 1 zmasks must be set at 0 on rim 0 (set at one on rim 1 and interior) 809 !! and bdymasks must indicate free ocean points (set at one on interior) 810 !! (as if rim 0 was land) 811 !! - we can then check in which direction the interior of the computational domain is with the difference 812 !! mask array values on both sides to compute flagu and flagv 813 !! - and look at the ocean neighbours to compute ntreat 814 !!---------------------------------------------------------------------- 815 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) 816 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary t/u/v mask array 817 LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 818 INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices 819 INTEGER :: i_offset, j_offset, inn ! local integer 820 INTEGER :: ibeg, iend ! local integer 821 LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour 822 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 823 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 824 CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid 825 REAL(wp) , DIMENSION(jpi,jpj) :: ztmp 826 !!---------------------------------------------------------------------- 827 828 cgrid = (/'t','u','v'/) 829 1172 830 DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components 1173 1174 idx_bdy(ib_bdy)%flagu(:,:) = 0._wp1175 idx_bdy(ib_bdy)%flagv(:,:) = 0._wp1176 icount = 01177 831 1178 832 ! Calculate relationship of U direction to the local orientation of the boundary … … 1180 834 ! flagu = 0 : u is tangential 1181 835 ! flagu = 1 : u is normal to the boundary and is direction is inward 1182 1183 836 DO igrd = 1, jpbgrd 1184 837 SELECT CASE( igrd ) 1185 CASE( 1 ) ; pmask => umask (:,:,1); i_offset = 01186 CASE( 2 ) ; pmask => bdytmask(:,:); i_offset = 11187 CASE( 3 ) ; pmask => zfmask (:,:); i_offset = 0838 CASE( 1 ) ; zmask => pumask ; i_offset = 0 839 CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 840 CASE( 3 ) ; zmask => pfmask ; i_offset = 0 1188 841 END SELECT 1189 842 icount = 0 1190 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1191 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1192 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1193 zefl = pmask(nbi+i_offset-1,nbj) 1194 zwfl = pmask(nbi+i_offset,nbj) 843 ztmp(:,:) = -999._wp 844 IF( lrim0 ) THEN ! extent of rim 0 845 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 846 ELSE ! extent of rim 1 847 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 848 END IF 849 DO ib = ibeg, iend 850 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 851 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 852 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 853 zwfl = zmask(ii+i_offset-1,ij) 854 zefl = zmask(ii+i_offset ,ij) 1195 855 ! This error check only works if you are using the bdyXmask arrays 1196 IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN856 IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN 1197 857 icount = icount + 1 1198 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig( nbi),mjg(nbj)858 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 1199 859 ELSE 1200 idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl860 ztmp(ii,ij) = -zwfl + zefl 1201 861 ENDIF 1202 862 END DO 1203 863 IF( icount /= 0 ) THEN 1204 WRITE(ctmp1,*) ' E R R O R :Some ',cgrid(igrd),' grid points,', &864 WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & 1205 865 ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1206 WRITE(ctmp2,*) ' ========== ' 1207 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 866 CALL ctl_stop( ctmp1 ) 1208 867 ENDIF 868 SELECT CASE( igrd ) 869 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 870 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 871 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 872 END SELECT 873 DO ib = ibeg, iend 874 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 875 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 876 idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) 877 END DO 1209 878 END DO 1210 879 … … 1213 882 ! flagv = 0 : v is tangential 1214 883 ! flagv = 1 : v is normal to the boundary and is direction is inward 1215 1216 884 DO igrd = 1, jpbgrd 1217 885 SELECT CASE( igrd ) 1218 CASE( 1 ) ; pmask => vmask (:,:,1); j_offset = 01219 CASE( 2 ) ; pmask => zfmask(:,:); j_offset = 01220 CASE( 3 ) ; pmask => bdytmask; j_offset = 1886 CASE( 1 ) ; zmask => pvmask ; j_offset = 0 887 CASE( 2 ) ; zmask => pfmask ; j_offset = 0 888 CASE( 3 ) ; zmask => bdytmask ; j_offset = 1 1221 889 END SELECT 1222 890 icount = 0 1223 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1224 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1225 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1226 znfl = pmask(nbi,nbj+j_offset-1) 1227 zsfl = pmask(nbi,nbj+j_offset ) 891 ztmp(:,:) = -999._wp 892 IF( lrim0 ) THEN ! extent of rim 0 893 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 894 ELSE ! extent of rim 1 895 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 896 END IF 897 DO ib = ibeg, iend 898 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 899 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 900 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 901 zsfl = zmask(ii,ij+j_offset-1) 902 znfl = zmask(ii,ij+j_offset ) 1228 903 ! This error check only works if you are using the bdyXmask arrays 1229 IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN1230 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig( nbi),mjg(nbj)904 IF( j_offset == 1 .and. znfl + zsfl == 2. ) THEN 905 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 1231 906 icount = icount + 1 1232 907 ELSE 1233 idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl908 ztmp(ii,ij) = -zsfl + znfl 1234 909 END IF 1235 910 END DO 1236 911 IF( icount /= 0 ) THEN 1237 WRITE(ctmp1,*) ' E R R O R :Some ',cgrid(igrd),' grid points,', &912 WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & 1238 913 ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1239 WRITE(ctmp2,*) ' ========== ' 1240 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1241 ENDIF 1242 END DO 1243 ! 1244 END DO 1245 ! 1246 ! Tidy up 1247 !-------- 1248 IF( nb_bdy>0 ) DEALLOCATE( nbidta, nbjdta, nbrdta ) 1249 ! 1250 END SUBROUTINE bdy_segs 1251 914 CALL ctl_stop( ctmp1 ) 915 ENDIF 916 SELECT CASE( igrd ) 917 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 918 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 919 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 920 END SELECT 921 DO ib = ibeg, iend 922 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 923 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 924 idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) 925 END DO 926 END DO 927 ! 928 END DO ! ib_bdy 929 930 DO ib_bdy = 1, nb_bdy 931 DO igrd = 1, jpbgrd 932 SELECT CASE( igrd ) 933 CASE( 1 ) ; zmask => bdytmask 934 CASE( 2 ) ; zmask => bdyumask 935 CASE( 3 ) ; zmask => bdyvmask 936 END SELECT 937 ztmp(:,:) = -999._wp 938 IF( lrim0 ) THEN ! extent of rim 0 939 ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 940 ELSE ! extent of rim 1 941 ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) 942 END IF 943 DO ib = ibeg, iend 944 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 945 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 946 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 947 llnon = zmask(ii ,ij+1) == 1. 948 llson = zmask(ii ,ij-1) == 1. 949 llean = zmask(ii+1,ij ) == 1. 950 llwen = zmask(ii-1,ij ) == 1. 951 inn = COUNT( (/ llnon, llson, llean, llwen /) ) 952 IF( inn == 0 ) THEN ! no neighbours -> interior of a corner or cluster of rim points 953 ! ! ! _____ ! _____ ! __ __ 954 ! 1 | o ! 2 o | ! 3 | x ! 4 x | ! | | -> error 955 ! |_x_ _ ! _ _x_| ! | o ! o | ! |x_x| 956 IF( zmask(ii+1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 1. 957 ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 2. 958 ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 3. 959 ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 4. 960 ELSE ; ztmp(ii,ij) = -1. 961 WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & 962 ' on boundary set ', ib_bdy, ' has no free ocean neighbour' 963 IF( lrim0 ) THEN 964 WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' 965 ELSE 966 WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' 967 END IF 968 CALL ctl_warn( ctmp1, ctmp2 ) 969 END IF 970 END IF 971 IF( inn == 1 ) THEN ! middle of linear bdy or incomplete corner ! ___ o 972 ! | ! | ! o ! ______ ! |x___ 973 ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x 974 ! | ! | ! ! o 975 IF( llean ) ztmp(ii,ij) = 5. 976 IF( llwen ) ztmp(ii,ij) = 6. 977 IF( llnon ) ztmp(ii,ij) = 7. 978 IF( llson ) ztmp(ii,ij) = 8. 979 END IF 980 IF( inn == 2 ) THEN ! exterior of a corner 981 ! o ! o ! _____| ! |_____ 982 ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x 983 ! | ! | ! o ! o 984 IF( llnon .AND. llean ) ztmp(ii,ij) = 9. 985 IF( llnon .AND. llwen ) ztmp(ii,ij) = 10. 986 IF( llson .AND. llean ) ztmp(ii,ij) = 11. 987 IF( llson .AND. llwen ) ztmp(ii,ij) = 12. 988 END IF 989 IF( inn == 3 ) THEN ! 3 neighbours __ __ 990 ! |_ o ! o _| ! |_| ! o 991 ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o 992 ! | o ! o | ! o ! __|¨|__ 993 IF( llnon .AND. llean .AND. llson ) ztmp(ii,ij) = 13. 994 IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14. 995 IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15. 996 IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16. 997 END IF 998 IF( inn == 4 ) THEN 999 WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & 1000 ' on boundary set ', ib_bdy, ' have 4 neighbours' 1001 CALL ctl_stop( ctmp1 ) 1002 END IF 1003 END DO 1004 SELECT CASE( igrd ) 1005 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) 1006 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) 1007 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) 1008 END SELECT 1009 DO ib = ibeg, iend 1010 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1011 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1012 idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) 1013 END DO 1014 END DO 1015 END DO 1016 1017 END SUBROUTINE bdy_rim_treat 1018 1019 1020 SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) 1021 !!---------------------------------------------------------------------- 1022 !! *** ROUTINE find_neib *** 1023 !! 1024 !! ** Purpose : get ii1, ij1, ii2, ij2, ii3, ij3, the indices of 1025 !! the free ocean neighbours of (ii,ij) for bdy treatment 1026 !! 1027 !! ** Method : use itreat input to select a case 1028 !! N.B. ntreat is defined for all bdy points in routine bdy_rim_treat 1029 !! 1030 !!---------------------------------------------------------------------- 1031 INTEGER, INTENT(in ) :: ii, ij, itreat 1032 INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 1033 !!---------------------------------------------------------------------- 1034 SELECT CASE( itreat ) ! points that will be used by bdy routines, -1 will be discarded 1035 ! ! ! _____ ! _____ 1036 ! 1 | o ! 2 o | ! 3 | x ! 4 x | 1037 ! |_x_ _ ! _ _x_| ! | o ! o | 1038 CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1039 CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1040 CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1041 CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1042 ! | ! | ! o ! ______ ! or incomplete corner 1043 ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o 1044 ! | ! | ! ! o ! |x___ 1045 CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1046 CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1047 CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1048 CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 1049 ! o ! o ! _____| ! |_____ 1050 ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x 1051 ! | ! | ! o ! o 1052 CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1053 CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1054 CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1055 CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 1056 ! |_ o ! o _| ! ¨¨|_|¨¨ ! o 1057 ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o 1058 ! | o ! o | ! o ! __|¨|__ 1059 CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1060 CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1061 CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij 1062 CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij 1063 END SELECT 1064 END SUBROUTINE find_neib 1065 1066 1067 SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) 1068 !!---------------------------------------------------------------------- 1069 !! *** ROUTINE bdy_coords_seg *** 1070 !! 1071 !! ** Purpose : build bdy coordinates with segments defined in namelist 1072 !! 1073 !! ** Method : read namelist nambdy_index blocks 1074 !! 1075 !!---------------------------------------------------------------------- 1076 INTEGER , INTENT (in ) :: kb_bdy ! bdy number 1077 INTEGER, DIMENSION(jpbgrd), INTENT ( out) :: knblendta ! length of index arrays 1078 !! 1079 INTEGER :: ios ! Local integer output status for namelist read 1080 INTEGER :: nbdyind, nbdybeg, nbdyend 1081 CHARACTER(LEN=1) :: ctypebdy ! - - 1082 NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 1083 !!---------------------------------------------------------------------- 1084 1085 ! No REWIND here because may need to read more than one nambdy_index namelist. 1086 ! Read only namelist_cfg to avoid unseccessfull overwrite 1087 ! keep full control of the configuration namelist 1088 READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 1089 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) 1090 IF(lwm) WRITE ( numond, nambdy_index ) 1091 1092 SELECT CASE ( TRIM(ctypebdy) ) 1093 CASE( 'N' ) 1094 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1095 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. 1096 nbdybeg = 2 1097 nbdyend = jpiglo - 1 1098 ENDIF 1099 nbdysegn = nbdysegn + 1 1100 npckgn(nbdysegn) = kb_bdy ! Save bdy package number 1101 jpjnob(nbdysegn) = nbdyind 1102 jpindt(nbdysegn) = nbdybeg 1103 jpinft(nbdysegn) = nbdyend 1104 ! 1105 CASE( 'S' ) 1106 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1107 nbdyind = 2 ! set boundary to whole side of model domain. 1108 nbdybeg = 2 1109 nbdyend = jpiglo - 1 1110 ENDIF 1111 nbdysegs = nbdysegs + 1 1112 npckgs(nbdysegs) = kb_bdy ! Save bdy package number 1113 jpjsob(nbdysegs) = nbdyind 1114 jpisdt(nbdysegs) = nbdybeg 1115 jpisft(nbdysegs) = nbdyend 1116 ! 1117 CASE( 'E' ) 1118 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1119 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain. 1120 nbdybeg = 2 1121 nbdyend = jpjglo - 1 1122 ENDIF 1123 nbdysege = nbdysege + 1 1124 npckge(nbdysege) = kb_bdy ! Save bdy package number 1125 jpieob(nbdysege) = nbdyind 1126 jpjedt(nbdysege) = nbdybeg 1127 jpjeft(nbdysege) = nbdyend 1128 ! 1129 CASE( 'W' ) 1130 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1131 nbdyind = 2 ! set boundary to whole side of model domain. 1132 nbdybeg = 2 1133 nbdyend = jpjglo - 1 1134 ENDIF 1135 nbdysegw = nbdysegw + 1 1136 npckgw(nbdysegw) = kb_bdy ! Save bdy package number 1137 jpiwob(nbdysegw) = nbdyind 1138 jpjwdt(nbdysegw) = nbdybeg 1139 jpjwft(nbdysegw) = nbdyend 1140 ! 1141 CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 1142 END SELECT 1143 1144 ! For simplicity we assume that in case of straight bdy, arrays have the same length 1145 ! (even if it is true that last tangential velocity points 1146 ! are useless). This simplifies a little bit boundary data format (and agrees with format 1147 ! used so far in obc package) 1148 1149 knblendta(1:jpbgrd) = (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) 1150 1151 END SUBROUTINE bdy_read_seg 1152 1153 1252 1154 SUBROUTINE bdy_ctl_seg 1253 1155 !!---------------------------------------------------------------------- … … 1279 1181 &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1280 1182 IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1281 IF (jpindt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1282 IF (jpinft(ib).g e.jpiglo) CALL ctl_stop( 'End index out of domain' )1183 IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1184 IF (jpinft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) 1283 1185 END DO 1284 1186 ! … … 1288 1190 &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1289 1191 IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1290 IF (jpisdt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1291 IF (jpisft(ib).g e.jpiglo) CALL ctl_stop( 'End index out of domain' )1192 IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1193 IF (jpisft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) 1292 1194 END DO 1293 1195 ! … … 1297 1199 &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1298 1200 IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1299 IF (jpjedt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1300 IF (jpjeft(ib).g e.jpjglo) CALL ctl_stop( 'End index out of domain' )1201 IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1202 IF (jpjeft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) 1301 1203 END DO 1302 1204 ! … … 1306 1208 &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1307 1209 IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1308 IF (jpjwdt(ib).l e.1 ) CALL ctl_stop( 'Start index out of domain' )1309 IF (jpjwft(ib).g e.jpjglo) CALL ctl_stop( 'End index out of domain' )1210 IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1211 IF (jpjwft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) 1310 1212 ENDDO 1311 1213 ! … … 1336 1238 icorns(ib2,1) = npckgw(ib1) 1337 1239 ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN 1338 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1240 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1339 1241 & jpisft(ib2), jpjwft(ib1) 1340 WRITE(ctmp2,*) ' ==========Not allowed yet'1341 WRITE(ctmp3,*) ' 1342 & 1343 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1242 WRITE(ctmp2,*) ' Not allowed yet' 1243 WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1244 & ' and South segment: ',npckgs(ib2) 1245 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1344 1246 ELSE 1345 WRITE(ctmp1,*) ' E R R O R :Check South and West Open boundary indices'1346 WRITE(ctmp2,*) ' ==========Crossing problem with West segment: ',npckgw(ib1) , &1347 & 1348 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1247 WRITE(ctmp1,*) ' Check South and West Open boundary indices' 1248 WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & 1249 & ' and South segment: ',npckgs(ib2) 1250 CALL ctl_stop( ctmp1, ctmp2 ) 1349 1251 END IF 1350 1252 END IF … … 1368 1270 icorns(ib2,2) = npckge(ib1) 1369 1271 ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN 1370 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1272 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1371 1273 & jpisdt(ib2), jpjeft(ib1) 1372 WRITE(ctmp2,*) ' ==========Not allowed yet'1373 WRITE(ctmp3,*) ' 1374 & 1375 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1274 WRITE(ctmp2,*) ' Not allowed yet' 1275 WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 1276 & ' and South segment: ',npckgs(ib2) 1277 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1376 1278 ELSE 1377 WRITE(ctmp1,*) ' E R R O R :Check South and East Open boundary indices'1378 WRITE(ctmp2,*) ' ==========Crossing problem with East segment: ',npckge(ib1), &1379 & 1380 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1279 WRITE(ctmp1,*) ' Check South and East Open boundary indices' 1280 WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 1281 & ' and South segment: ',npckgs(ib2) 1282 CALL ctl_stop( ctmp1, ctmp2 ) 1381 1283 END IF 1382 1284 END IF … … 1400 1302 icornn(ib2,1) = npckgw(ib1) 1401 1303 ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN 1402 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1304 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1403 1305 & jpinft(ib2), jpjwdt(ib1) 1404 WRITE(ctmp2,*) ' ==========Not allowed yet'1405 WRITE(ctmp3,*) ' 1406 & 1407 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1306 WRITE(ctmp2,*) ' Not allowed yet' 1307 WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1308 & ' and North segment: ',npckgn(ib2) 1309 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1408 1310 ELSE 1409 WRITE(ctmp1,*) ' E R R O R :Check North and West Open boundary indices'1410 WRITE(ctmp2,*) ' ==========Crossing problem with West segment: ',npckgw(ib1), &1411 & 1412 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1311 WRITE(ctmp1,*) ' Check North and West Open boundary indices' 1312 WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & 1313 & ' and North segment: ',npckgn(ib2) 1314 CALL ctl_stop( ctmp1, ctmp2 ) 1413 1315 END IF 1414 1316 END IF … … 1432 1334 icornn(ib2,2) = npckge(ib1) 1433 1335 ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN 1434 WRITE(ctmp1,*) ' E R R O R :Found an acute open boundary corner at point (i,j)= ', &1336 WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 1435 1337 & jpindt(ib2), jpjedt(ib1) 1436 WRITE(ctmp2,*) ' ==========Not allowed yet'1437 WRITE(ctmp3,*) ' 1438 & 1439 CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ')1338 WRITE(ctmp2,*) ' Not allowed yet' 1339 WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 1340 & ' and North segment: ',npckgn(ib2) 1341 CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 1440 1342 ELSE 1441 WRITE(ctmp1,*) ' E R R O R :Check North and East Open boundary indices'1442 WRITE(ctmp2,*) ' ==========Crossing problem with East segment: ',npckge(ib1), &1443 & 1444 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ')1343 WRITE(ctmp1,*) ' Check North and East Open boundary indices' 1344 WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 1345 & ' and North segment: ',npckgn(ib2) 1346 CALL ctl_stop( ctmp1, ctmp2 ) 1445 1347 END IF 1446 1348 END IF … … 1468 1370 IF (ztestmask(1)==1) THEN 1469 1371 IF (icornw(ib,1)==0) THEN 1470 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 1471 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1472 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1372 WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 1373 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1473 1374 ELSE 1474 1375 ! This is a corner … … 1480 1381 IF (ztestmask(2)==1) THEN 1481 1382 IF (icornw(ib,2)==0) THEN 1482 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 1483 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1484 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1383 WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 1384 CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) 1485 1385 ELSE 1486 1386 ! This is a corner … … 1508 1408 IF (ztestmask(1)==1) THEN 1509 1409 IF (icorne(ib,1)==0) THEN 1510 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 1511 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1512 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1410 WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 1411 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1513 1412 ELSE 1514 1413 ! This is a corner … … 1520 1419 IF (ztestmask(2)==1) THEN 1521 1420 IF (icorne(ib,2)==0) THEN 1522 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 1523 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1524 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1421 WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 1422 CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 1525 1423 ELSE 1526 1424 ! This is a corner … … 1547 1445 1548 1446 IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN 1549 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 1550 WRITE(ctmp2,*) ' ========== does not start on land or on a corner' 1551 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1447 WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 1448 CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 1552 1449 ENDIF 1553 1450 IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN 1554 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 1555 WRITE(ctmp2,*) ' ========== does not end on land or on a corner' 1556 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1451 WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 1452 CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 1557 1453 ENDIF 1558 1454 END DO … … 1573 1469 1574 1470 IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN 1575 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 1576 WRITE(ctmp2,*) ' ========== does not start on land' 1577 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1471 WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 1472 CALL ctl_stop( ctmp1, ' does not start on land' ) 1578 1473 ENDIF 1579 1474 IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN 1580 WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 1581 WRITE(ctmp2,*) ' ========== does not end on land' 1582 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1475 WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 1476 CALL ctl_stop( ctmp1, ' does not end on land' ) 1583 1477 ENDIF 1584 1478 END DO … … 1593 1487 END SUBROUTINE bdy_ctl_seg 1594 1488 1595 1489 1490 SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta ) 1491 !!---------------------------------------------------------------------- 1492 !! *** ROUTINE bdy_coords_seg *** 1493 !! 1494 !! ** Purpose : build nbidta, nbidta, nbrdta for bdy built with segments 1495 !! 1496 !! ** Method : 1497 !! 1498 !!---------------------------------------------------------------------- 1499 INTEGER, DIMENSION(:,:,:), intent( out) :: nbidta, nbjdta, nbrdta ! Index arrays: i and j indices of bdy dta 1500 !! 1501 INTEGER :: ii, ij, ir, iseg 1502 INTEGER :: igrd ! grid type (t=1, u=2, v=3) 1503 INTEGER :: icount ! 1504 INTEGER :: ib_bdy ! bdy number 1505 !!---------------------------------------------------------------------- 1506 1507 ! East 1508 !----- 1509 DO iseg = 1, nbdysege 1510 ib_bdy = npckge(iseg) 1511 ! 1512 ! ------------ T points ------------- 1513 igrd=1 1514 icount=0 1515 DO ir = 1, nn_rimwidth(ib_bdy) 1516 DO ij = jpjedt(iseg), jpjeft(iseg) 1517 icount = icount + 1 1518 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1519 nbjdta(icount, igrd, ib_bdy) = ij 1520 nbrdta(icount, igrd, ib_bdy) = ir 1521 ENDDO 1522 ENDDO 1523 ! 1524 ! ------------ U points ------------- 1525 igrd=2 1526 icount=0 1527 DO ir = 1, nn_rimwidth(ib_bdy) 1528 DO ij = jpjedt(iseg), jpjeft(iseg) 1529 icount = icount + 1 1530 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 1531 nbjdta(icount, igrd, ib_bdy) = ij 1532 nbrdta(icount, igrd, ib_bdy) = ir 1533 ENDDO 1534 ENDDO 1535 ! 1536 ! ------------ V points ------------- 1537 igrd=3 1538 icount=0 1539 DO ir = 1, nn_rimwidth(ib_bdy) 1540 ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 1541 DO ij = jpjedt(iseg), jpjeft(iseg) 1542 icount = icount + 1 1543 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1544 nbjdta(icount, igrd, ib_bdy) = ij 1545 nbrdta(icount, igrd, ib_bdy) = ir 1546 ENDDO 1547 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1548 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1549 ENDDO 1550 ENDDO 1551 ! 1552 ! West 1553 !----- 1554 DO iseg = 1, nbdysegw 1555 ib_bdy = npckgw(iseg) 1556 ! 1557 ! ------------ T points ------------- 1558 igrd=1 1559 icount=0 1560 DO ir = 1, nn_rimwidth(ib_bdy) 1561 DO ij = jpjwdt(iseg), jpjwft(iseg) 1562 icount = icount + 1 1563 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1564 nbjdta(icount, igrd, ib_bdy) = ij 1565 nbrdta(icount, igrd, ib_bdy) = ir 1566 ENDDO 1567 ENDDO 1568 ! 1569 ! ------------ U points ------------- 1570 igrd=2 1571 icount=0 1572 DO ir = 1, nn_rimwidth(ib_bdy) 1573 DO ij = jpjwdt(iseg), jpjwft(iseg) 1574 icount = icount + 1 1575 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1576 nbjdta(icount, igrd, ib_bdy) = ij 1577 nbrdta(icount, igrd, ib_bdy) = ir 1578 ENDDO 1579 ENDDO 1580 ! 1581 ! ------------ V points ------------- 1582 igrd=3 1583 icount=0 1584 DO ir = 1, nn_rimwidth(ib_bdy) 1585 ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 1586 DO ij = jpjwdt(iseg), jpjwft(iseg) 1587 icount = icount + 1 1588 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1589 nbjdta(icount, igrd, ib_bdy) = ij 1590 nbrdta(icount, igrd, ib_bdy) = ir 1591 ENDDO 1592 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1593 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1594 ENDDO 1595 ENDDO 1596 ! 1597 ! North 1598 !----- 1599 DO iseg = 1, nbdysegn 1600 ib_bdy = npckgn(iseg) 1601 ! 1602 ! ------------ T points ------------- 1603 igrd=1 1604 icount=0 1605 DO ir = 1, nn_rimwidth(ib_bdy) 1606 DO ii = jpindt(iseg), jpinft(iseg) 1607 icount = icount + 1 1608 nbidta(icount, igrd, ib_bdy) = ii 1609 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1610 nbrdta(icount, igrd, ib_bdy) = ir 1611 ENDDO 1612 ENDDO 1613 ! 1614 ! ------------ U points ------------- 1615 igrd=2 1616 icount=0 1617 DO ir = 1, nn_rimwidth(ib_bdy) 1618 ! DO ii = jpindt(iseg), jpinft(iseg) - 1 1619 DO ii = jpindt(iseg), jpinft(iseg) 1620 icount = icount + 1 1621 nbidta(icount, igrd, ib_bdy) = ii 1622 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1623 nbrdta(icount, igrd, ib_bdy) = ir 1624 ENDDO 1625 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1626 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1627 ENDDO 1628 ! 1629 ! ------------ V points ------------- 1630 igrd=3 1631 icount=0 1632 DO ir = 1, nn_rimwidth(ib_bdy) 1633 DO ii = jpindt(iseg), jpinft(iseg) 1634 icount = icount + 1 1635 nbidta(icount, igrd, ib_bdy) = ii 1636 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 1637 nbrdta(icount, igrd, ib_bdy) = ir 1638 ENDDO 1639 ENDDO 1640 ENDDO 1641 ! 1642 ! South 1643 !----- 1644 DO iseg = 1, nbdysegs 1645 ib_bdy = npckgs(iseg) 1646 ! 1647 ! ------------ T points ------------- 1648 igrd=1 1649 icount=0 1650 DO ir = 1, nn_rimwidth(ib_bdy) 1651 DO ii = jpisdt(iseg), jpisft(iseg) 1652 icount = icount + 1 1653 nbidta(icount, igrd, ib_bdy) = ii 1654 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1655 nbrdta(icount, igrd, ib_bdy) = ir 1656 ENDDO 1657 ENDDO 1658 ! 1659 ! ------------ U points ------------- 1660 igrd=2 1661 icount=0 1662 DO ir = 1, nn_rimwidth(ib_bdy) 1663 ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 1664 DO ii = jpisdt(iseg), jpisft(iseg) 1665 icount = icount + 1 1666 nbidta(icount, igrd, ib_bdy) = ii 1667 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1668 nbrdta(icount, igrd, ib_bdy) = ir 1669 ENDDO 1670 nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1671 nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 1672 ENDDO 1673 ! 1674 ! ------------ V points ------------- 1675 igrd=3 1676 icount=0 1677 DO ir = 1, nn_rimwidth(ib_bdy) 1678 DO ii = jpisdt(iseg), jpisft(iseg) 1679 icount = icount + 1 1680 nbidta(icount, igrd, ib_bdy) = ii 1681 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1682 nbrdta(icount, igrd, ib_bdy) = ir 1683 ENDDO 1684 ENDDO 1685 ENDDO 1686 1687 1688 END SUBROUTINE bdy_coords_seg 1689 1690 1596 1691 SUBROUTINE bdy_ctl_corn( ib1, ib2 ) 1597 1692 !!---------------------------------------------------------------------- … … 1619 1714 ! 1620 1715 IF( itest>0 ) THEN 1621 WRITE(ctmp1,*) ' E R R O R : Segments ', ib1, 'and ', ib2 1622 WRITE(ctmp2,*) ' ========== have different open bdy schemes' 1623 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 1716 WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 1717 CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) 1624 1718 ENDIF 1625 1719 ! 1626 1720 END SUBROUTINE bdy_ctl_corn 1627 1721 1722 1723 SUBROUTINE bdy_meshwri() 1724 !!---------------------------------------------------------------------- 1725 !! *** ROUTINE bdy_meshwri *** 1726 !! 1727 !! ** Purpose : write netcdf file with nbr, flagu, flagv, ntreat for T, U 1728 !! and V points in 2D arrays for easier visualisation/control 1729 !! 1730 !! ** Method : use iom_rstput as in domwri.F 1731 !!---------------------------------------------------------------------- 1732 INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices 1733 INTEGER :: inum ! - - 1734 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 1735 REAL(wp) , DIMENSION(jpi,jpj) :: ztmp 1736 CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid 1737 !!---------------------------------------------------------------------- 1738 cgrid = (/'t','u','v'/) 1739 CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) 1740 DO igrd = 1, jpbgrd 1741 SELECT CASE( igrd ) 1742 CASE( 1 ) ; zmask => tmask(:,:,1) 1743 CASE( 2 ) ; zmask => umask(:,:,1) 1744 CASE( 3 ) ; zmask => vmask(:,:,1) 1745 END SELECT 1746 ztmp(:,:) = zmask(:,:) 1747 DO ib_bdy = 1, nb_bdy 1748 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims 1749 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1750 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1751 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. 1752 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1753 END DO 1754 END DO 1755 CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1756 ztmp(:,:) = zmask(:,:) 1757 DO ib_bdy = 1, nb_bdy 1758 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 1759 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1760 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1761 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. 1762 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1763 END DO 1764 END DO 1765 CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1766 ztmp(:,:) = zmask(:,:) 1767 DO ib_bdy = 1, nb_bdy 1768 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 1769 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1770 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1771 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. 1772 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1773 END DO 1774 END DO 1775 CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1776 ztmp(:,:) = zmask(:,:) 1777 DO ib_bdy = 1, nb_bdy 1778 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 1779 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 1780 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 1781 ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. 1782 IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 1783 END DO 1784 END DO 1785 CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 1786 END DO 1787 CALL iom_close( inum ) 1788 1789 END SUBROUTINE bdy_meshwri 1790 1628 1791 !!================================================================================= 1629 1792 END MODULE bdyini -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdylib.F90
r10529 r12143 15 15 USE bdy_oce ! ocean open boundary conditions 16 16 USE phycst ! physical constants 17 USE bdyini 17 18 ! 18 19 USE in_out_manager ! … … 75 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 76 77 !! 77 REAL(wp) :: zwgt ! boundary weight78 78 INTEGER :: ib, ik, igrd ! dummy loop indices 79 79 INTEGER :: ii, ij ! 2D addresses … … 92 92 93 93 94 SUBROUTINE bdy_orl( idx, ptb, pta, dta, l l_npo )94 SUBROUTINE bdy_orl( idx, ptb, pta, dta, lrim0, ll_npo ) 95 95 !!---------------------------------------------------------------------- 96 96 !! *** SUBROUTINE bdy_orl *** … … 104 104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptb ! before tracer field 105 105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 106 LOGICAL , OPTIONAL, INTENT(in) :: lrim0 ! indicate if rim 0 is treated 106 107 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 107 108 !! … … 111 112 igrd = 1 ! Everything is at T-points here 112 113 ! 113 CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), dta, l l_npo )114 CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), dta, lrim0, ll_npo ) 114 115 ! 115 116 END SUBROUTINE bdy_orl 116 117 117 118 118 SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, l l_npo )119 SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 119 120 !!---------------------------------------------------------------------- 120 121 !! *** SUBROUTINE bdy_orlanski_2d *** … … 132 133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) 133 134 REAL(wp), DIMENSION(:) , INTENT(in ) :: phi_ext ! external forcing data 135 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 134 136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 135 137 ! … … 140 142 INTEGER :: ii_offset, ij_offset ! offsets for mask indices 141 143 INTEGER :: flagu, flagv ! short cuts 144 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 142 145 REAL(wp) :: zmask_x, zmask_y1, zmask_y2 143 146 REAL(wp) :: zex1, zex2, zey, zey1, zey2 … … 146 149 REAL(wp) :: zdy_1, zdy_2, zsign_ups 147 150 REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value 148 REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! land/sea mask for field149 REAL(wp), POINTER, DIMENSION(:,:) :: pmask_xdif ! land/sea mask for x-derivatives150 REAL(wp), POINTER, DIMENSION(:,:) :: pmask_ydif ! land/sea mask for y-derivatives151 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! land/sea mask for field 152 REAL(wp), POINTER, DIMENSION(:,:) :: zmask_xdif ! land/sea mask for x-derivatives 153 REAL(wp), POINTER, DIMENSION(:,:) :: zmask_ydif ! land/sea mask for y-derivatives 151 154 REAL(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives 152 155 REAL(wp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives … … 159 162 SELECT CASE(igrd) 160 163 CASE(1) 161 pmask => tmask(:,:,1)162 pmask_xdif => umask(:,:,1)163 pmask_ydif => vmask(:,:,1)164 zmask => tmask(:,:,1) 165 zmask_xdif => umask(:,:,1) 166 zmask_ydif => vmask(:,:,1) 164 167 pe_xdif => e1u(:,:) 165 168 pe_ydif => e2v(:,:) … … 167 170 ij_offset = 0 168 171 CASE(2) 169 pmask => umask(:,:,1)170 pmask_xdif => tmask(:,:,1)171 pmask_ydif => fmask(:,:,1)172 zmask => umask(:,:,1) 173 zmask_xdif => tmask(:,:,1) 174 zmask_ydif => fmask(:,:,1) 172 175 pe_xdif => e1t(:,:) 173 176 pe_ydif => e2f(:,:) … … 175 178 ij_offset = 0 176 179 CASE(3) 177 pmask => vmask(:,:,1)178 pmask_xdif => fmask(:,:,1)179 pmask_ydif => tmask(:,:,1)180 zmask => vmask(:,:,1) 181 zmask_xdif => fmask(:,:,1) 182 zmask_ydif => tmask(:,:,1) 180 183 pe_xdif => e1f(:,:) 181 184 pe_ydif => e2t(:,:) … … 185 188 END SELECT 186 189 ! 187 DO jb = 1, idx%nblenrim(igrd) 190 IF( PRESENT(lrim0) ) THEN 191 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 192 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 193 END IF 194 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 195 END IF 196 ! 197 DO jb = ibeg, iend 188 198 ii = idx%nbi(jb,igrd) 189 199 ij = idx%nbj(jb,igrd) 200 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 190 201 flagu = int( idx%flagu(jb,igrd) ) 191 202 flagv = int( idx%flagv(jb,igrd) ) … … 203 214 ! 204 215 ! Calculate scale factors for calculation of spatial derivatives. 205 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 )&206 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset) )207 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 )&208 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset) )209 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) &216 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 217 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) 218 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & 219 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2 +ij_offset) ) 220 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 210 221 & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 211 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1)&212 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset) )222 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 223 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) 213 224 ! make sure scale factors are nonzero 214 225 if( zey1 .lt. rsmall ) zey1 = zey2 … … 217 228 zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 218 229 ! 219 ! Calculate masks for calculation of spatial derivatives. 220 zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2 )&221 & + abs(ijbm1-ijbm2) * pmask_ydif(iibm2 ,ijbm2+ij_offset) )222 zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 )&223 & + (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) )224 zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1)&225 & + (ijbm1jp1-ijbm1) * pmask_ydif(iibm1 ,ijbm1+ij_offset) )230 ! Calculate masks for calculation of spatial derivatives. 231 zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ) & 232 & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset) ) 233 zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 234 & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 235 zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ) & 236 & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset) ) 226 237 227 238 ! Calculation of terms required for both versions of the scheme. … … 231 242 ! Note no rdt factor in expression for zdt because it cancels in the expressions for 232 243 ! zrx and zry. 233 zdt = phia(iibm1,ijbm1) - phib(iibm1,ijbm1)234 zdx = ( ( phia(iibm1,ijbm1) - phia(iibm2,ijbm2) ) / zex2 ) * zmask_x244 zdt = phia(iibm1 ,ijbm1 ) - phib(iibm1 ,ijbm1 ) 245 zdx = ( ( phia(iibm1 ,ijbm1 ) - phia(iibm2 ,ijbm2 ) ) / zex2 ) * zmask_x 235 246 zdy_1 = ( ( phib(iibm1 ,ijbm1 ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1 236 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 )) / zey2 ) * zmask_y2247 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 ) ) / zey2 ) * zmask_y2 237 248 zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) 238 249 !!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) … … 265 276 & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 266 277 end if 267 phia(ii,ij) = phia(ii,ij) * pmask(ii,ij)278 phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 268 279 END DO 269 280 ! … … 271 282 272 283 273 SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, l l_npo )284 SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 274 285 !!---------------------------------------------------------------------- 275 286 !! *** SUBROUTINE bdy_orlanski_3d *** … … 287 298 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 288 299 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: phi_ext ! external forcing data 300 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 289 301 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 290 302 ! … … 295 307 INTEGER :: ii_offset, ij_offset ! offsets for mask indices 296 308 INTEGER :: flagu, flagv ! short cuts 309 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 297 310 REAL(wp) :: zmask_x, zmask_y1, zmask_y2 298 311 REAL(wp) :: zex1, zex2, zey, zey1, zey2 … … 301 314 REAL(wp) :: zdy_1, zdy_2, zsign_ups 302 315 REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value 303 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask ! land/sea mask for field304 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask_xdif ! land/sea mask for x-derivatives305 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask_ydif ! land/sea mask for y-derivatives316 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field 317 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_xdif ! land/sea mask for x-derivatives 318 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_ydif ! land/sea mask for y-derivatives 306 319 REAL(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives 307 320 REAL(wp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives … … 314 327 SELECT CASE(igrd) 315 328 CASE(1) 316 pmask => tmask(:,:,:)317 pmask_xdif => umask(:,:,:)318 pmask_ydif => vmask(:,:,:)329 zmask => tmask(:,:,:) 330 zmask_xdif => umask(:,:,:) 331 zmask_ydif => vmask(:,:,:) 319 332 pe_xdif => e1u(:,:) 320 333 pe_ydif => e2v(:,:) … … 322 335 ij_offset = 0 323 336 CASE(2) 324 pmask => umask(:,:,:)325 pmask_xdif => tmask(:,:,:)326 pmask_ydif => fmask(:,:,:)337 zmask => umask(:,:,:) 338 zmask_xdif => tmask(:,:,:) 339 zmask_ydif => fmask(:,:,:) 327 340 pe_xdif => e1t(:,:) 328 341 pe_ydif => e2f(:,:) … … 330 343 ij_offset = 0 331 344 CASE(3) 332 pmask => vmask(:,:,:)333 pmask_xdif => fmask(:,:,:)334 pmask_ydif => tmask(:,:,:)345 zmask => vmask(:,:,:) 346 zmask_xdif => fmask(:,:,:) 347 zmask_ydif => tmask(:,:,:) 335 348 pe_xdif => e1f(:,:) 336 349 pe_ydif => e2t(:,:) … … 339 352 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) 340 353 END SELECT 341 354 ! 355 IF( PRESENT(lrim0) ) THEN 356 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 357 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 358 END IF 359 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 360 END IF 361 ! 342 362 DO jk = 1, jpk 343 363 ! 344 DO jb = 1, idx%nblenrim(igrd)364 DO jb = ibeg, iend 345 365 ii = idx%nbi(jb,igrd) 346 366 ij = idx%nbj(jb,igrd) 367 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 347 368 flagu = int( idx%flagu(jb,igrd) ) 348 369 flagv = int( idx%flagv(jb,igrd) ) … … 360 381 ! 361 382 ! Calculate scale factors for calculation of spatial derivatives. 362 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 )&363 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset) )364 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 )&365 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset) )366 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) &383 zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 384 & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) 385 zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & 386 & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset ) ) 387 zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & 367 388 & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) 368 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1)&369 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset) )389 zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & 390 & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) 370 391 ! make sure scale factors are nonzero 371 392 if( zey1 .lt. rsmall ) zey1 = zey2 … … 375 396 ! 376 397 ! Calculate masks for calculation of spatial derivatives. 377 zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2 ,jk)&378 & + abs(ijbm1-ijbm2) * pmask_ydif(iibm2 ,ijbm2+ij_offset,jk) )379 zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) &380 & + (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) )381 zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1 ,jk)&382 & + (ijbm1jp1-ijbm1) * pmask_ydif(iibm1 ,ijbm1+ij_offset,jk) )398 zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ,jk) & 399 & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset,jk) ) 400 zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) & 401 & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) ) 402 zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ,jk) & 403 & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset,jk) ) 383 404 ! 384 405 ! Calculate normal (zrx) and tangential (zry) components of radiation velocities. … … 386 407 ! Centred derivative is calculated as average of "left" and "right" derivatives for 387 408 ! this reason. 388 zdt = phia(iibm1,ijbm1,jk) - phib(iibm1,ijbm1,jk)389 zdx = ( ( phia(iibm1,ijbm1,jk) - phia(iibm2,ijbm2,jk) ) / zex2 ) * zmask_x409 zdt = phia(iibm1 ,ijbm1 ,jk) - phib(iibm1 ,ijbm1 ,jk) 410 zdx = ( ( phia(iibm1 ,ijbm1 ,jk) - phia(iibm2 ,ijbm2 ,jk) ) / zex2 ) * zmask_x 390 411 zdy_1 = ( ( phib(iibm1 ,ijbm1 ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1 391 412 zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1 ,ijbm1 ,jk) ) / zey2 ) * zmask_y2 … … 421 442 & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 422 443 end if 423 phia(ii,ij,jk) = phia(ii,ij,jk) * pmask(ii,ij,jk)444 phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 424 445 END DO 425 446 ! … … 428 449 END SUBROUTINE bdy_orlanski_3d 429 450 430 SUBROUTINE bdy_nmn( idx, igrd, phia )451 SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0 ) 431 452 !!---------------------------------------------------------------------- 432 453 !! *** SUBROUTINE bdy_nmn *** … … 434 455 !! ** Purpose : Duplicate the value at open boundaries, zero gradient. 435 456 !! 436 !!---------------------------------------------------------------------- 437 INTEGER, INTENT(in) :: igrd ! grid index 438 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 439 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 457 !! 458 !! ** Method : - take the average of free ocean neighbours 459 !! 460 !! ___ ! |_____| ! ___| ! __|x o ! |_ _| ! | 461 !! __|x ! x ! x o ! o ! |_| ! |x o 462 !! o ! o ! o ! ! o x o ! |x_x_ 463 !! ! o 464 !!---------------------------------------------------------------------- 465 INTEGER, INTENT(in ) :: igrd ! grid index 466 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 467 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 468 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 440 469 !! 441 REAL(wp) :: zcoef, zcoef1, zcoef2 442 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask ! land/sea mask for field 443 REAL(wp), POINTER, DIMENSION(:,:) :: bdypmask ! land/sea mask for field 470 REAL(wp) :: zweight 471 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field 444 472 INTEGER :: ib, ik ! dummy loop indices 445 INTEGER :: ii, ij, ip, jp ! 2D addresses 446 !!---------------------------------------------------------------------- 473 INTEGER :: ii, ij ! 2D addresses 474 INTEGER :: ipkm1 ! size of phia third dimension minus 1 475 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) 476 INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3, itreat 477 !!---------------------------------------------------------------------- 478 ! 479 ipkm1 = MAX( SIZE(phia,3) - 1, 1 ) 447 480 ! 448 481 SELECT CASE(igrd) 449 CASE(1) 450 pmask => tmask(:,:,:) 451 bdypmask => bdytmask(:,:) 452 CASE(2) 453 pmask => umask(:,:,:) 454 bdypmask => bdyumask(:,:) 455 CASE(3) 456 pmask => vmask(:,:,:) 457 bdypmask => bdyvmask(:,:) 482 CASE(1) ; zmask => tmask(:,:,:) 483 CASE(2) ; zmask => umask(:,:,:) 484 CASE(3) ; zmask => vmask(:,:,:) 458 485 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) 459 486 END SELECT 460 DO ib = 1, idx%nblenrim(igrd) 487 ! 488 IF( PRESENT(lrim0) ) THEN 489 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 490 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 END IF 492 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 493 END IF 494 ! 495 DO ib = ibeg, iend 461 496 ii = idx%nbi(ib,igrd) 462 497 ij = idx%nbj(ib,igrd) 463 DO ik = 1, jpkm1 464 ! search the sense of the gradient 465 zcoef1 = bdypmask(ii-1,ij )*pmask(ii-1,ij,ik) + bdypmask(ii+1,ij )*pmask(ii+1,ij,ik) 466 zcoef2 = bdypmask(ii ,ij-1)*pmask(ii,ij-1,ik) + bdypmask(ii ,ij+1)*pmask(ii,ij+1,ik) 467 IF ( nint(zcoef1+zcoef2) == 0) THEN 468 ! corner **** we probably only want to set the tangentail component for the dynamics here 469 zcoef = pmask(ii-1,ij,ik) + pmask(ii+1,ij,ik) + pmask(ii,ij-1,ik) + pmask(ii,ij+1,ik) 470 IF (zcoef > .5_wp) THEN ! Only set none isolated points. 471 phia(ii,ij,ik) = phia(ii-1,ij ,ik) * pmask(ii-1,ij ,ik) + & 472 & phia(ii+1,ij ,ik) * pmask(ii+1,ij ,ik) + & 473 & phia(ii ,ij-1,ik) * pmask(ii ,ij-1,ik) + & 474 & phia(ii ,ij+1,ik) * pmask(ii ,ij+1,ik) 475 phia(ii,ij,ik) = ( phia(ii,ij,ik) / zcoef ) * pmask(ii,ij,ik) 476 ELSE 477 phia(ii,ij,ik) = phia(ii,ij ,ik) * pmask(ii,ij ,ik) 478 ENDIF 479 ELSEIF ( nint(zcoef1+zcoef2) == 2) THEN 480 ! oblique corner **** we probably only want to set the normal component for the dynamics here 481 zcoef = pmask(ii-1,ij,ik)*bdypmask(ii-1,ij ) + pmask(ii+1,ij,ik)*bdypmask(ii+1,ij ) + & 482 & pmask(ii,ij-1,ik)*bdypmask(ii,ij -1 ) + pmask(ii,ij+1,ik)*bdypmask(ii,ij+1 ) 483 phia(ii,ij,ik) = phia(ii-1,ij ,ik) * pmask(ii-1,ij ,ik)*bdypmask(ii-1,ij ) + & 484 & phia(ii+1,ij ,ik) * pmask(ii+1,ij ,ik)*bdypmask(ii+1,ij ) + & 485 & phia(ii ,ij-1,ik) * pmask(ii ,ij-1,ik)*bdypmask(ii,ij -1 ) + & 486 & phia(ii ,ij+1,ik) * pmask(ii ,ij+1,ik)*bdypmask(ii,ij+1 ) 487 488 phia(ii,ij,ik) = ( phia(ii,ij,ik) / MAX(1._wp, zcoef) ) * pmask(ii,ij,ik) 489 ELSE 490 ip = nint(bdypmask(ii+1,ij )*pmask(ii+1,ij,ik) - bdypmask(ii-1,ij )*pmask(ii-1,ij,ik)) 491 jp = nint(bdypmask(ii ,ij+1)*pmask(ii,ij+1,ik) - bdypmask(ii ,ij-1)*pmask(ii,ij-1,ik)) 492 phia(ii,ij,ik) = phia(ii+ip,ij+jp,ik) * pmask(ii+ip,ij+jp,ik) 493 ENDIF 494 END DO 498 itreat = idx%ntreat(ib,igrd) 499 CALL find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) ! find free ocean neighbours 500 SELECT CASE( itreat ) 501 CASE( 1:8 ) 502 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 503 DO ik = 1, ipkm1 504 IF( zmask(ii1,ij1,ik) /= 0. ) phia(ii,ij,ik) = phia(ii1,ij1,ik) 505 END DO 506 CASE( 9:12 ) 507 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 508 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE 509 DO ik = 1, ipkm1 510 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) 511 IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) ) / zweight 512 END DO 513 CASE( 13:16 ) 514 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE 515 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE 516 IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj ) CYCLE 517 DO ik = 1, ipkm1 518 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) 519 IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) + phia(ii3,ij3,ik) ) / zweight 520 END DO 521 END SELECT 495 522 END DO 496 523 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdytides.F90
r10068 r12143 70 70 INTEGER :: inum, igrd 71 71 INTEGER, DIMENSION(3) :: ilen0 !: length of boundary data (from OBC arrays) 72 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts73 72 INTEGER :: ios ! Local integer output status for namelist read 74 73 CHARACTER(len=80) :: clfile !: full file name for tidal input file … … 77 76 !! 78 77 TYPE(TIDES_DATA), POINTER :: td !: local short cut 79 TYPE(MAP_POINTER), DIMENSION(jpbgrd) :: ibmap_ptr !: array of pointers to nbmap80 78 !! 81 79 NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj 82 80 !!---------------------------------------------------------------------- 83 81 ! 84 IF (nb_bdy>0) THEN 85 IF(lwp) WRITE(numout,*) 86 IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 87 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 88 ENDIF 82 IF(lwp) WRITE(numout,*) 83 IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 84 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 89 85 90 86 REWIND(numnam_cfg) … … 94 90 ! 95 91 td => tides(ib_bdy) 96 nblen => idx_bdy(ib_bdy)%nblen97 nblenrim => idx_bdy(ib_bdy)%nblenrim98 92 99 93 ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries 100 94 filtide(:) = '' 101 95 96 REWIND( numnam_ref ) 97 READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) 98 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) 102 99 ! Don't REWIND here - may need to read more than one of these namelists. 103 READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901)104 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist', lwp )105 100 READ ( numnam_cfg, nambdy_tide, IOSTAT = ios, ERR = 902 ) 106 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' , lwp)101 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' ) 107 102 IF(lwm) WRITE ( numond, nambdy_tide ) 108 103 ! ! Parameter control and print … … 125 120 ! JC: If FRS scheme is used, we assume that tidal is needed over the whole 126 121 ! relaxation area 127 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = nblen (:)128 ELSE ; ilen0(:) = nblenrim(:)122 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = idx_bdy(ib_bdy)%nblen (:) 123 ELSE ; ilen0(:) = idx_bdy(ib_bdy)%nblenrim(:) 129 124 ENDIF 130 125 … … 161 156 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 162 157 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 158 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 163 159 td%ssh0(ib,itide,1) = ztr(ii,ij) 164 160 td%ssh0(ib,itide,2) = zti(ii,ij) … … 177 173 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 178 174 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 175 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 179 176 td%u0(ib,itide,1) = ztr(ii,ij) 180 177 td%u0(ib,itide,2) = zti(ii,ij) … … 193 190 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 194 191 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 192 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove? 195 193 td%v0(ib,itide,1) = ztr(ii,ij) 196 194 td%v0(ib,itide,2) = zti(ii,ij) … … 207 205 ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 208 206 ! 209 ! Set map structure210 ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1) ; ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy)211 ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2) ; ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy)212 ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3) ; ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy)213 214 207 ! Open files and read in tidal forcing data 215 208 ! ----------------------------------------- … … 219 212 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' 220 213 CALL iom_open( clfile, inum ) 221 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) )214 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 222 215 td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 223 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) )216 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 224 217 td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 225 218 CALL iom_close( inum ) … … 227 220 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' 228 221 CALL iom_open( clfile, inum ) 229 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, i bmap_ptr(2) )222 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 230 223 td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 231 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, i bmap_ptr(2) )224 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 232 225 td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 233 226 CALL iom_close( inum ) … … 235 228 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' 236 229 CALL iom_open( clfile, inum ) 237 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, i bmap_ptr(3) )230 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 238 231 td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 239 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, i bmap_ptr(3) )232 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 240 233 td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 241 234 CALL iom_close( inum ) … … 269 262 270 263 271 SUBROUTINE bdytide_update( kt, idx, dta, td, jit, time_offset )264 SUBROUTINE bdytide_update( kt, idx, dta, td, kit, kt_offset ) 272 265 !!---------------------------------------------------------------------- 273 266 !! *** SUBROUTINE bdytide_update *** … … 280 273 TYPE(OBC_DATA) , INTENT(inout) :: dta ! OBC external data 281 274 TYPE(TIDES_DATA) , INTENT(inout) :: td ! tidal harmonics data 282 INTEGER, OPTIONAL, INTENT(in ) :: jit ! Barotropic timestep counter (for timesplitting option)283 INTEGER, OPTIONAL, INTENT(in ) :: time_offset ! time offset in units of timesteps. NB. if jit275 INTEGER, OPTIONAL, INTENT(in ) :: kit ! Barotropic timestep counter (for timesplitting option) 276 INTEGER, OPTIONAL, INTENT(in ) :: kt_offset ! time offset in units of timesteps. NB. if kit 284 277 ! ! is present then units = subcycle timesteps. 285 ! ! time_offset = 0 => get data at "now" time level286 ! ! time_offset = -1 => get data at "before" time level287 ! ! time_offset = +1 => get data at "after" time level278 ! ! kt_offset = 0 => get data at "now" time level 279 ! ! kt_offset = -1 => get data at "before" time level 280 ! ! kt_offset = +1 => get data at "after" time level 288 281 ! ! etc. 289 282 ! … … 300 293 301 294 zflag=1 302 IF ( PRESENT( jit) ) THEN303 IF ( jit /= 1 ) zflag=0295 IF ( PRESENT(kit) ) THEN 296 IF ( kit /= 1 ) zflag=0 304 297 ENDIF 305 298 … … 320 313 321 314 time_add = 0 322 IF( PRESENT( time_offset) ) THEN323 time_add = time_offset315 IF( PRESENT(kt_offset) ) THEN 316 time_add = kt_offset 324 317 ENDIF 325 318 326 IF( PRESENT( jit) ) THEN327 z_arg = ((kt-kt_tide) * rdt + ( jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) )319 IF( PRESENT(kit) ) THEN 320 z_arg = ((kt-kt_tide) * rdt + (kit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 328 321 ELSE 329 322 z_arg = ((kt-kt_tide)+time_add) * rdt … … 358 351 359 352 360 SUBROUTINE bdy_dta_tides( kt, kit, time_offset )353 SUBROUTINE bdy_dta_tides( kt, kit, kt_offset ) 361 354 !!---------------------------------------------------------------------- 362 355 !! *** SUBROUTINE bdy_dta_tides *** … … 367 360 INTEGER, INTENT(in) :: kt ! Main timestep counter 368 361 INTEGER, OPTIONAL, INTENT(in) :: kit ! Barotropic timestep counter (for timesplitting option) 369 INTEGER, OPTIONAL, INTENT(in) :: time_offset! time offset in units of timesteps. NB. if kit362 INTEGER, OPTIONAL, INTENT(in) :: kt_offset ! time offset in units of timesteps. NB. if kit 370 363 ! ! is present then units = subcycle timesteps. 371 ! ! time_offset = 0 => get data at "now" time level372 ! ! time_offset = -1 => get data at "before" time level373 ! ! time_offset = +1 => get data at "after" time level364 ! ! kt_offset = 0 => get data at "now" time level 365 ! ! kt_offset = -1 => get data at "before" time level 366 ! ! kt_offset = +1 => get data at "after" time level 374 367 ! ! etc. 375 368 ! … … 386 379 387 380 time_add = 0 388 IF( PRESENT( time_offset) ) THEN389 time_add = time_offset381 IF( PRESENT(kt_offset) ) THEN 382 time_add = kt_offset 390 383 ENDIF 391 384 … … 432 425 ! If time splitting, initialize arrays from slow varying open boundary data: 433 426 IF ( PRESENT(kit) ) THEN 434 IF ( dta_bdy(ib_bdy)%l l_ssh) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1))435 IF ( dta_bdy(ib_bdy)%l l_u2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2))436 IF ( dta_bdy(ib_bdy)%l l_v2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3))427 IF ( dta_bdy(ib_bdy)%lneed_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 428 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 429 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 437 430 ENDIF 438 431 ! … … 444 437 z_sist = zramp * SIN( z_sarg ) 445 438 ! 446 IF ( dta_bdy(ib_bdy)%l l_ssh ) THEN439 IF ( dta_bdy(ib_bdy)%lneed_ssh ) THEN 447 440 igrd=1 ! SSH on tracer grid 448 441 DO ib = 1, ilen0(igrd) … … 453 446 ENDIF 454 447 ! 455 IF ( dta_bdy(ib_bdy)%l l_u2d ) THEN448 IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 456 449 igrd=2 ! U grid 457 450 DO ib = 1, ilen0(igrd) … … 460 453 & tides(ib_bdy)%u(ib,itide,2)*z_sist ) 461 454 END DO 462 ENDIF463 !464 IF ( dta_bdy(ib_bdy)%ll_v2d ) THEN465 455 igrd=3 ! V grid 466 456 DO ib = 1, ilen0(igrd) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdytra.F90
r10529 r12143 49 49 INTEGER, INTENT(in) :: kt ! Main time step counter 50 50 ! 51 INTEGER :: ib_bdy, jn, igrd ! Loop indeces 52 TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure 51 INTEGER :: ib_bdy, jn, igrd, ir ! Loop indeces 52 TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure 53 LOGICAL :: llrim0 ! indicate if rim 0 is treated 54 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 53 55 !!---------------------------------------------------------------------- 54 56 igrd = 1 55 56 DO ib_bdy=1, nb_bdy 57 llsend1(:) = .false. ; llrecv1(:) = .false. 58 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 59 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 60 ELSE ; llrim0 = .FALSE. 61 END IF 62 DO ib_bdy=1, nb_bdy 63 ! 64 zdta(1)%tra => dta_bdy(ib_bdy)%tem 65 zdta(2)%tra => dta_bdy(ib_bdy)%sal 66 ! 67 DO jn = 1, jpts 68 ! 69 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 70 CASE('none' ) ; CYCLE 71 CASE('frs' ) ! treat the whole boundary at once 72 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 73 CASE('specified' ) ! treat the whole rim at once 74 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 75 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn), llrim0 ) ! tsa masked 76 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 77 & zdta(jn)%tra, llrim0, ll_npo=.false. ) 78 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 79 & zdta(jn)%tra, llrim0, ll_npo=.true. ) 80 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), tsa(:,:,:,jn), jn, llrim0 ) 81 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 82 END SELECT 83 ! 84 END DO 85 END DO 57 86 ! 58 zdta(1)%tra => dta_bdy(ib_bdy)%tem 59 zdta(2)%tra => dta_bdy(ib_bdy)%sal 87 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 88 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF 89 DO ib_bdy=1, nb_bdy 90 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 91 CASE('neumann','runoff') 92 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 93 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 94 CASE('orlanski', 'orlanski_npo') 95 llsend1(:) = llsend1(:) .OR. lsend_bdy(ib_bdy,1,:,ir) ! possibly every direction, T points 96 llrecv1(:) = llrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:,ir) ! possibly every direction, T points 97 END SELECT 98 END DO 99 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 100 CALL lbc_lnk( 'bdytra', tsa, 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 101 END IF 60 102 ! 61 DO jn = 1, jpts 62 ! 63 SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 64 CASE('none' ) ; CYCLE 65 CASE('frs' ) ; CALL bdy_frs ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 66 CASE('specified' ) ; CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 67 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn) ) 68 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.false. ) 69 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.true. ) 70 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), tsa(:,:,:,jn), jn ) 71 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 72 END SELECT 73 ! Boundary points should be updated 74 CALL lbc_bdy_lnk( 'bdytra', tsa(:,:,:,jn), 'T', 1., ib_bdy ) 75 ! 76 END DO 77 END DO 103 END DO ! ir 78 104 ! 79 105 END SUBROUTINE bdy_tra 80 106 81 107 82 SUBROUTINE bdy_rnf( idx, pta, jpa )108 SUBROUTINE bdy_rnf( idx, pta, jpa, llrim0 ) 83 109 !!---------------------------------------------------------------------- 84 110 !! *** SUBROUTINE bdy_rnf *** … … 89 115 !! 90 116 !!---------------------------------------------------------------------- 91 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 92 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 93 INTEGER, INTENT(in) :: jpa ! TRA index 117 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 118 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend 119 INTEGER, INTENT(in) :: jpa ! TRA index 120 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 94 121 ! 95 REAL(wp) :: zwgt ! boundary weight 96 INTEGER :: ib, ik, igrd ! dummy loop indices 97 INTEGER :: ii, ij, ip, jp ! 2D addresses 122 INTEGER :: ib, ii, ij, igrd ! dummy loop indices 123 INTEGER :: ik, ip, jp ! 2D addresses 98 124 !!---------------------------------------------------------------------- 99 125 ! 100 126 igrd = 1 ! Everything is at T-points here 101 DO ib = 1, idx%nblenrim(igrd)102 ii = idx%nbi(ib,igrd)103 ij = idx%nbj(ib,igrd)104 DO ik = 1, jpkm1105 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij )106 jp = bdytmask(ii ,ij+1) - bdytmask(ii ,ij-1)107 i f (jpa == jp_tem) pta(ii,ij,ik) = pta(ii+ip,ij+jp,ik) * tmask(ii,ij,ik)108 if (jpa == jp_sal) pta(ii,ij,ik) = 0.1 * tmask(ii,ij,ik)127 IF( jpa == jp_tem ) THEN 128 CALL bdy_nmn( idx, igrd, pta, llrim0 ) 129 ELSE IF( jpa == jp_sal ) THEN 130 IF( .NOT. llrim0 ) RETURN 131 DO ib = 1, idx%nblenrim(igrd) ! if llrim0 then treat the whole rim 132 ii = idx%nbi(ib,igrd) 133 ij = idx%nbj(ib,igrd) 134 pta(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 109 135 END DO 110 END DO136 END IF 111 137 ! 112 138 END SUBROUTINE bdy_rnf -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/BDY/bdyvol.F90
r11987 r12143 99 99 ii = idx%nbi(jb,jgrd) 100 100 ij = idx%nbj(jb,jgrd) 101 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice 101 102 zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 102 103 END DO … … 105 106 ii = idx%nbi(jb,jgrd) 106 107 ij = idx%nbj(jb,jgrd) 108 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice 107 109 zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 108 110 END DO … … 126 128 ii = idx%nbi(jb,jgrd) 127 129 ij = idx%nbj(jb,jgrd) 130 !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? 128 131 pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij) 129 132 END DO … … 132 135 ii = idx%nbi(jb,jgrd) 133 136 ij = idx%nbj(jb,jgrd) 137 !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? 134 138 pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1) 135 139 END DO … … 139 143 ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 140 144 ! ------------------------------------------------------ 141 IF( MOD( kt, n write ) == 0 .AND. ( kc == 1 ) ) THEN145 IF( MOD( kt, nn_write ) == 0 .AND. ( kc == 1 ) ) THEN 142 146 ! 143 147 ! compute residual transport across boundary … … 150 154 ii = idx%nbi(jb,jgrd) 151 155 ij = idx%nbj(jb,jgrd) 156 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 152 157 ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 153 158 END DO … … 156 161 ii = idx%nbi(jb,jgrd) 157 162 ij = idx%nbj(jb,jgrd) 163 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE 158 164 ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 159 165 END DO … … 195 201 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 196 202 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 203 IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE 197 204 zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd) 198 205 bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj) & … … 207 214 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 208 215 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 216 IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE 209 217 zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd) 210 218 bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj) & -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/C1D/c1d.F90
r10068 r12143 52 52 REWIND( numnam_ref ) ! Namelist namc1d in reference namelist : Tracer advection scheme 53 53 READ ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) 54 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' , lwp)54 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' ) 55 55 ! 56 56 REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 57 57 READ ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 ) 58 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' , lwp)58 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' ) 59 59 IF(lwm) WRITE ( numond, namc1d ) 60 60 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/C1D/dtauvd.F90
r10068 r12143 62 62 REWIND( numnam_ref ) ! Namelist namc1d_uvd in reference namelist : 63 63 READ ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) 64 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' , lwp)64 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) 65 65 ! 66 66 REWIND( numnam_cfg ) ! Namelist namc1d_uvd in configuration namelist : Parameters of the run 67 67 READ ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 ) 68 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' , lwp)68 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' ) 69 69 IF(lwm) WRITE ( numond, namc1d_uvd ) 70 70 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/C1D/dyndmp.F90
r10425 r12143 81 81 REWIND( numnam_ref ) ! Namelist namc1d_dyndmp in reference namelist : 82 82 READ ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) 83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' , lwp)83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) 84 84 REWIND( numnam_cfg ) ! Namelist namc1d_dyndmp in configuration namelist : Parameters of the run 85 85 READ ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 ) 86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namc1d_dyndmp ) 88 88 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/CRS/README.rst
r10279 r12143 2 2 On line biogeochemistry coarsening 3 3 ********************************** 4 5 .. todo:: 6 7 4 8 5 9 .. contents:: … … 63 67 ! 1, MAX of KZ 64 68 ! 2, MIN of KZ 65 ! 3, 10^(MEAN(LOG(KZ)) 66 ! 4, MEDIANE of KZ 69 ! 3, 10^(MEAN(LOG(KZ)) 70 ! 4, MEDIANE of KZ 67 71 ln_crs_wn = .false. ! wn coarsened (T) or computed using horizontal divergence ( F ) 68 72 ! ! … … 73 77 the north-fold lateral boundary condition (ORCA025, ORCA12, ORCA36, ...). 74 78 - ``nn_msh_crs = 1`` will activate the generation of the coarsened grid meshmask. 75 - ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. 79 - ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. 76 80 - ``ln_crs_wn`` 77 81 … … 80 84 - when ``key_vvl`` is not activated, 81 85 82 - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) 86 - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) 83 87 - or coarsened vertical velocities are computed with an average operator (``ln_crs_wn = .true.``) 84 88 - ``ln_crs_top = .true.``: should be activated to run BCG model in coarsened space; … … 97 101 98 102 In the [attachment:iodef.xml iodef.xml] file, a "nemo" context is defined and 99 some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. 103 some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. 100 104 To write variables on the coarsened grid, and in particular the passive tracers, 101 105 a "nemo_crs" context should be defined in [attachment:iodef.xml iodef.xml] and … … 111 115 interpolated `on-the-fly <http://forge.ipsl.jussieu.fr/nemo/wiki/Users/SetupNewConfiguration/Weight-creator>`_. 112 116 Example of namelist for PISCES : 113 117 114 118 .. code-block:: fortran 115 119 … … 134 138 rn_trfac(14) = 1.0e-06 ! - - - - 135 139 rn_trfac(23) = 7.6e-06 ! - - - - 136 140 137 141 cn_dir = './' ! root directory for the location of the data files 138 142 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/CRS/crsdom.F90
r10068 r12143 296 296 ENDDO 297 297 298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, p val=1.0 )299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, p val=1.0 )298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 ) 299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 ) 300 300 301 301 END SUBROUTINE crs_dom_hgr … … 579 579 ENDDO 580 580 CASE DEFAULT 581 STOP581 CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' ) 582 582 END SELECT 583 583 … … 1748 1748 ENDDO 1749 1749 1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, p val=1.0 )1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, p val=1.0 )1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pfillval=1.0 ) 1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 ) 1752 1752 ! 1753 1753 ! … … 1857 1857 ENDDO 1858 1858 1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, p val=1.0 )1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, p val=1.0 )1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pfillval=1.0 ) 1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 ) 1861 1861 1862 1862 END SUBROUTINE crs_dom_sfc … … 1947 1947 1948 1948 CASE DEFAULT 1949 STOP1949 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 1950 1950 END SELECT 1951 1951 IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 … … 1996 1996 1997 1997 CASE DEFAULT 1998 STOP1998 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 1999 1999 END SELECT 2000 2000 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/CRS/crsini.F90
r10068 r12143 82 82 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 83 83 READ ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 84 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' , lwp)84 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' ) 85 85 REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run 86 86 READ ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 87 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' , lwp)87 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) 88 88 IF(lwm) WRITE ( numond, namcrs ) 89 89 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/CRS/crslbclnk.F90
r10425 r12143 27 27 CONTAINS 28 28 29 SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval)29 SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) 30 30 !!--------------------------------------------------------------------- 31 31 !! *** SUBROUTINE crs_lbc_lnk *** … … 40 40 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 41 41 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied 42 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo43 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing)42 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) 43 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 44 44 ! 45 45 LOGICAL :: ll_grid_crs 46 REAL(wp) :: zval ! valeur sur les halo47 46 !!---------------------------------------------------------------------- 48 47 ! 49 48 ll_grid_crs = ( jpi == jpi_crs ) 50 49 ! 51 IF( PRESENT(pval) ) THEN ; zval = pval52 ELSE ; zval = 0._wp53 ENDIF54 !55 50 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 56 51 ! 57 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 58 ELSE ; CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn , pval=zval ) 59 ENDIF 52 CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode, pfillval ) 60 53 ! 61 54 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain … … 64 57 65 58 66 SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)59 SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, kfillmode, pfillval ) 67 60 !!--------------------------------------------------------------------- 68 61 !! *** SUBROUTINE crs_lbc_lnk *** … … 77 70 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 78 71 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 79 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo80 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing)72 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 73 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 81 74 ! 82 75 LOGICAL :: ll_grid_crs 83 REAL(wp) :: zval ! valeur sur les halo84 76 !!---------------------------------------------------------------------- 85 77 ! 86 78 ll_grid_crs = ( jpi == jpi_crs ) 87 79 ! 88 IF( PRESENT(pval) ) THEN ; zval = pval89 ELSE ; zval = 0._wp90 ENDIF91 !92 80 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 93 81 ! 94 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, cd_mpp, pval=zval ) 95 ELSE ; CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn , pval=zval ) 96 ENDIF 82 CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode, pfillval ) 97 83 ! 98 84 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/dia25h.F90
r10641 r12143 55 55 REWIND ( numnam_ref ) ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics 56 56 READ ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) 57 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' , lwp)57 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) 58 58 REWIND( numnam_cfg ) ! Namelist nam_dia25h in configuration namelist 25hour diagnostics 59 59 READ ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) 60 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' , lwp)60 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) 61 61 IF(lwm) WRITE ( numond, nam_dia25h ) 62 62 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diacfl.F90
r10824 r12143 29 29 REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number 30 30 31 !!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc !32 !!gm I don't understand why.33 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace34 !!gm end35 36 31 PUBLIC dia_cfl ! routine called by step.F90 37 32 PUBLIC dia_cfl_init ! routine called by nemogcm … … 55 50 INTEGER, INTENT(in) :: kt ! ocean time-step index 56 51 ! 57 INTEGER :: ji, jj, jk! dummy loop indices58 REAL(wp) :: z2dt, zCu_max, zCv_max, zCw_max! local scalars59 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc! workspace60 !!gm this does not work REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl! workspace52 INTEGER :: ji, jj, jk ! dummy loop indices 53 REAL(wp) :: z2dt, zCu_max, zCv_max, zCw_max ! local scalars 54 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 55 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 61 56 !!---------------------------------------------------------------------- 62 57 ! … … 71 66 DO jk = 1, jpk ! calculate Courant numbers 72 67 DO jj = 1, jpj 73 DO ji = 1, fs_jpim1 ! vector opt.68 DO ji = 1, jpi 74 69 zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u (ji,jj) ! for i-direction 75 70 zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v (ji,jj) ! for j-direction … … 111 106 ! ! write out to file 112 107 IF( lwp ) THEN 113 WRITE(numcfl,FMT='(2x,i 4,5x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3)108 WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 114 109 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 115 110 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) … … 172 167 rCw_max = 0._wp 173 168 ! 174 !!gm required to work175 ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) )176 !!gm end177 !178 169 END SUBROUTINE dia_cfl_init 179 170 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diadct.F90
r10425 r12143 11 11 !! 3.4 ! 09/2011 (C Bricaud) 12 12 !!---------------------------------------------------------------------- 13 #if defined key_diadct 14 !!---------------------------------------------------------------------- 15 !! 'key_diadct' : 16 !!---------------------------------------------------------------------- 13 !! does not work with agrif 14 #if ! defined key_agrif 17 15 !!---------------------------------------------------------------------- 18 16 !! dia_dct : Compute the transport through a sec. … … 42 40 43 41 PUBLIC dia_dct ! routine called by step.F90 44 PUBLIC dia_dct_init ! routine called by opa.F90 45 PUBLIC diadct_alloc ! routine called by nemo_init in nemogcm.F90 46 PRIVATE readsec 47 PRIVATE removepoints 48 PRIVATE transport 49 PRIVATE dia_dct_wri 50 51 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .TRUE. !: model-data diagnostics flag 52 53 INTEGER :: nn_dct ! Frequency of computation 54 INTEGER :: nn_dctwri ! Frequency of output 55 INTEGER :: nn_secdebug ! Number of the section to debug 42 PUBLIC dia_dct_init ! routine called by nemogcm.F90 43 44 ! !!** namelist variables ** 45 LOGICAL, PUBLIC :: ln_diadct !: Calculate transport thru a section or not 46 INTEGER :: nn_dct ! Frequency of computation 47 INTEGER :: nn_dctwri ! Frequency of output 48 INTEGER :: nn_secdebug ! Number of the section to debug 56 49 57 50 INTEGER, PARAMETER :: nb_class_max = 10 … … 104 97 CONTAINS 105 98 106 INTEGER FUNCTION diadct_alloc() 107 !!---------------------------------------------------------------------- 108 !! *** FUNCTION diadct_alloc *** 109 !!---------------------------------------------------------------------- 110 INTEGER :: ierr(2) 111 !!---------------------------------------------------------------------- 112 113 ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) ) 114 ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=ierr(2) ) 115 116 diadct_alloc = MAXVAL( ierr ) 117 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 118 119 END FUNCTION diadct_alloc 120 99 INTEGER FUNCTION diadct_alloc() 100 !!---------------------------------------------------------------------- 101 !! *** FUNCTION diadct_alloc *** 102 !!---------------------------------------------------------------------- 103 104 ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & 105 & transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=diadct_alloc ) 106 107 CALL mpp_sum( 'diadct', diadct_alloc ) 108 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 109 110 END FUNCTION diadct_alloc 121 111 122 112 SUBROUTINE dia_dct_init … … 130 120 INTEGER :: ios ! Local integer output status for namelist read 131 121 !! 132 NAMELIST/nam dct/nn_dct,nn_dctwri,nn_secdebug122 NAMELIST/nam_diadct/ln_diadct, nn_dct, nn_dctwri, nn_secdebug 133 123 !!--------------------------------------------------------------------- 134 124 135 REWIND( numnam_ref ) ! Namelist nam dct in reference namelist : Diagnostic: transport through sections136 READ ( numnam_ref, nam dct, IOSTAT = ios, ERR = 901)137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam dct in reference namelist', lwp)138 139 REWIND( numnam_cfg ) ! Namelist nam dct in configuration namelist : Diagnostic: transport through sections140 READ ( numnam_cfg, nam dct, IOSTAT = ios, ERR = 902 )141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam dct in configuration namelist', lwp)142 IF(lwm) WRITE ( numond, nam dct )125 REWIND( numnam_ref ) ! Namelist nam_diadct in reference namelist : Diagnostic: transport through sections 126 READ ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) 127 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) 128 129 REWIND( numnam_cfg ) ! Namelist nam_diadct in configuration namelist : Diagnostic: transport through sections 130 READ ( numnam_cfg, nam_diadct, IOSTAT = ios, ERR = 902 ) 131 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diadct in configuration namelist' ) 132 IF(lwm) WRITE ( numond, nam_diadct ) 143 133 144 134 IF( lwp ) THEN … … 146 136 WRITE(numout,*) "diadct_init: compute transports through sections " 147 137 WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" 148 WRITE(numout,*) " Frequency of computation: nn_dct = ",nn_dct 149 WRITE(numout,*) " Frequency of write: nn_dctwri = ",nn_dctwri 138 WRITE(numout,*) " Calculate transport thru sections: ln_diadct = ", ln_diadct 139 WRITE(numout,*) " Frequency of computation: nn_dct = ", nn_dct 140 WRITE(numout,*) " Frequency of write: nn_dctwri = ", nn_dctwri 150 141 151 142 IF ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN … … 155 146 ELSE ; WRITE(numout,*)" Wrong value for nn_secdebug : ",nn_secdebug 156 147 ENDIF 157 148 ENDIF 149 150 IF( ln_diadct ) THEN 151 ! control 158 152 IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & 159 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 160 153 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 154 155 ! allocate dia_dct arrays 156 IF( diadct_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 157 158 !Read section_ijglobal.diadct 159 CALL readsec 160 161 !open output file 162 IF( lwm ) THEN 163 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 164 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 165 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 166 ENDIF 167 168 ! Initialise arrays to zero 169 transports_3d(:,:,:,:)=0.0 170 transports_2d(:,:,:) =0.0 171 ! 161 172 ENDIF 162 163 !Read section_ijglobal.diadct164 CALL readsec165 166 !open output file167 IF( lwm ) THEN168 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )169 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )170 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )171 ENDIF172 173 ! Initialise arrays to zero174 transports_3d(:,:,:,:)=0.0175 transports_2d(:,:,:) =0.0176 173 ! 177 174 END SUBROUTINE dia_dct_init … … 1241 1238 #else 1242 1239 !!---------------------------------------------------------------------- 1243 !! D efault option : Dummy module1240 !! Dummy module 1244 1241 !!---------------------------------------------------------------------- 1245 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .FALSE. !: diamht flag 1246 PUBLIC 1247 !! $Id$ 1242 LOGICAL, PUBLIC :: ln_diadct = .FALSE. 1248 1243 CONTAINS 1249 1250 SUBROUTINE dia_dct_init ! Dummy routine 1244 SUBROUTINE dia_dct_init 1251 1245 IMPLICIT NONE 1252 WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?'1253 1246 END SUBROUTINE dia_dct_init 1254 1255 SUBROUTINE dia_dct( kt ) ! Dummy routine 1247 SUBROUTINE dia_dct( kt ) 1256 1248 IMPLICIT NONE 1257 INTEGER, INTENT( in ) :: kt ! ocean time-step index 1258 WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 1249 INTEGER, INTENT(in) :: kt 1259 1250 END SUBROUTINE dia_dct 1251 ! 1260 1252 #endif 1261 1253 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diaharm.F90
r10835 r12143 5 5 !!====================================================================== 6 6 !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code 7 !!----------------------------------------------------------------------8 #if defined key_diaharm9 !!----------------------------------------------------------------------10 !! 'key_diaharm'11 7 !!---------------------------------------------------------------------- 12 8 USE oce ! ocean dynamics and tracers variables … … 26 22 IMPLICIT NONE 27 23 PRIVATE 28 29 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .TRUE.30 24 31 25 INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo … … 33 27 34 28 ! !!** namelist variables ** 35 INTEGER :: nit000_han ! First time step used for harmonic analysis 36 INTEGER :: nitend_han ! Last time step used for harmonic analysis 37 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 38 INTEGER :: nb_ana ! Number of harmonics to analyse 29 LOGICAL, PUBLIC :: ln_diaharm ! Choose tidal harmonic output or not 30 INTEGER :: nit000_han ! First time step used for harmonic analysis 31 INTEGER :: nitend_han ! Last time step used for harmonic analysis 32 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 33 INTEGER :: nb_ana ! Number of harmonics to analyse 39 34 40 35 INTEGER , ALLOCATABLE, DIMENSION(:) :: name … … 53 48 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) 54 49 55 PUBLIC dia_harm ! routine called by step.F90 50 PUBLIC dia_harm ! routine called by step.F90 51 PUBLIC dia_harm_init ! routine called by nemogcm.F90 56 52 57 53 !!---------------------------------------------------------------------- … … 71 67 !! 72 68 !!-------------------------------------------------------------------- 73 INTEGER :: jh, nhan, jk, ji69 INTEGER :: jh, nhan, ji 74 70 INTEGER :: ios ! Local integer output status for namelist read 75 71 76 NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname72 NAMELIST/nam_diaharm/ ln_diaharm, nit000_han, nitend_han, nstep_han, tname 77 73 !!---------------------------------------------------------------------- 78 74 … … 83 79 ENDIF 84 80 ! 85 IF( .NOT. ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis')86 !87 CALL tide_init_Wave88 !89 81 REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis 90 82 READ ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) 91 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' , lwp)83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' ) 92 84 REWIND( numnam_cfg ) ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis 93 85 READ ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) 94 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' ) 95 87 IF(lwm) WRITE ( numond, nam_diaharm ) 96 88 ! 97 89 IF(lwp) THEN 98 WRITE(numout,*) 'First time step used for analysis: nit000_han= ', nit000_han 99 WRITE(numout,*) 'Last time step used for analysis: nitend_han= ', nitend_han 100 WRITE(numout,*) 'Time step frequency for harmonic analysis: nstep_han= ', nstep_han 90 WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm 91 WRITE(numout,*) ' First time step used for analysis: nit000_han= ', nit000_han 92 WRITE(numout,*) ' Last time step used for analysis: nitend_han= ', nitend_han 93 WRITE(numout,*) ' Time step frequency for harmonic analysis: nstep_han = ', nstep_han 101 94 ENDIF 102 95 103 ! Basic checks on harmonic analysis time window: 104 ! ---------------------------------------------- 105 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 106 & ' restart capability not implemented' ) 107 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 108 & 'restart capability not implemented' ) 109 110 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 111 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 112 113 nb_ana = 0 114 DO jk=1,jpmax_harmo 115 DO ji=1,jpmax_harmo 116 IF(TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 117 nb_ana=nb_ana+1 118 ENDIF 119 END DO 120 END DO 121 ! 122 IF(lwp) THEN 123 WRITE(numout,*) ' Namelist nam_diaharm' 124 WRITE(numout,*) ' nb_ana = ', nb_ana 125 CALL flush(numout) 96 IF( ln_diaharm .AND. .NOT.ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 97 98 IF( ln_diaharm ) THEN 99 100 CALL tide_init_Wave 101 ! 102 ! Basic checks on harmonic analysis time window: 103 ! ---------------------------------------------- 104 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 105 & ' restart capability not implemented' ) 106 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 107 & 'restart capability not implemented' ) 108 109 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 110 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 111 ! 112 nb_ana = 0 113 DO jh=1,jpmax_harmo 114 DO ji=1,jpmax_harmo 115 IF(TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 116 nb_ana=nb_ana+1 117 ENDIF 118 END DO 119 END DO 120 ! 121 IF(lwp) THEN 122 WRITE(numout,*) ' Namelist nam_diaharm' 123 WRITE(numout,*) ' nb_ana = ', nb_ana 124 CALL flush(numout) 125 ENDIF 126 ! 127 IF (nb_ana > jpmax_harmo) THEN 128 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 129 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 130 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 131 ENDIF 132 133 ALLOCATE(name (nb_ana)) 134 DO jh=1,nb_ana 135 DO ji=1,jpmax_harmo 136 IF (TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 137 name(jh) = ji 138 EXIT 139 END IF 140 END DO 141 END DO 142 143 ! Initialize frequency array: 144 ! --------------------------- 145 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 146 147 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 148 149 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' 150 151 DO jh = 1, nb_ana 152 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) 153 END DO 154 155 ! Initialize temporary arrays: 156 ! ---------------------------- 157 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 158 ana_temp(:,:,:,:) = 0._wp 159 126 160 ENDIF 127 !128 IF (nb_ana > jpmax_harmo) THEN129 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo'130 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo131 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 )132 ENDIF133 134 ALLOCATE(name (nb_ana))135 DO jk=1,nb_ana136 DO ji=1,jpmax_harmo137 IF (TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN138 name(jk) = ji139 EXIT140 END IF141 END DO142 END DO143 144 ! Initialize frequency array:145 ! ---------------------------146 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) )147 148 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana )149 150 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency '151 152 DO jh = 1, nb_ana153 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh)154 END DO155 156 ! Initialize temporary arrays:157 ! ----------------------------158 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) )159 ana_temp(:,:,:,:) = 0._wp160 161 161 162 END SUBROUTINE dia_harm_init … … 177 178 !!-------------------------------------------------------------------- 178 179 IF( ln_timing ) CALL timing_start('dia_harm') 179 !180 IF( kt == nit000 ) CALL dia_harm_init181 180 ! 182 181 IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN … … 422 421 INTEGER, INTENT(in) :: init 423 422 ! 424 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, j k1_sd, jk2_sd423 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd 425 424 REAL(wp) :: zval1, zval2, zx1 426 425 REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 … … 434 433 ztmp3(:,:) = 0._wp 435 434 ! 436 DO j k1_sd = 1, nsparse437 DO j k2_sd = 1, nsparse438 nisparse(j k2_sd) = nisparse(jk2_sd)439 njsparse(j k2_sd) = njsparse(jk2_sd)440 IF( nisparse(j k2_sd) == nisparse(jk1_sd) ) THEN441 ztmp3(njsparse(j k1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) &442 & + valuesparse(j k1_sd)*valuesparse(jk2_sd)435 DO jh1_sd = 1, nsparse 436 DO jh2_sd = 1, nsparse 437 nisparse(jh2_sd) = nisparse(jh2_sd) 438 njsparse(jh2_sd) = njsparse(jh2_sd) 439 IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN 440 ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) & 441 & + valuesparse(jh1_sd)*valuesparse(jh2_sd) 443 442 ENDIF 444 443 END DO … … 515 514 END SUBROUTINE SUR_DETERMINE 516 515 517 #else518 !!----------------------------------------------------------------------519 !! Default case : Empty module520 !!----------------------------------------------------------------------521 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE.522 CONTAINS523 SUBROUTINE dia_harm ( kt ) ! Empty routine524 INTEGER, INTENT( IN ) :: kt525 WRITE(*,*) 'dia_harm: you should not have seen this print'526 END SUBROUTINE dia_harm527 #endif528 529 516 !!====================================================================== 530 517 END MODULE diaharm -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diahsb.F90
r11987 r12143 367 367 REWIND( numnam_ref ) ! Namelist namhsb in reference namelist 368 368 READ ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) 369 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' , lwp)369 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' ) 370 370 REWIND( numnam_cfg ) ! Namelist namhsb in configuration namelist 371 371 READ ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) 372 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' , lwp)372 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) 373 373 IF(lwm) WRITE( numond, namhsb ) 374 374 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diaptr.F90
r10425 r12143 393 393 REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport 394 394 READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 395 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' , lwp)395 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 396 396 397 397 REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport 398 398 READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 399 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' , lwp)399 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 400 400 IF(lwm) WRITE ( numond, namptr ) 401 401 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diatmb.F90
r10499 r12143 43 43 REWIND( numnam_ref ) ! Read Namelist nam_diatmb in reference namelist : TMB diagnostics 44 44 READ ( numnam_ref, nam_diatmb, IOSTAT=ios, ERR= 901 ) 45 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist' , lwp)45 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist' ) 46 46 47 47 REWIND( numnam_cfg ) ! Namelist nam_diatmb in configuration namelist TMB diagnostics 48 48 READ ( numnam_cfg, nam_diatmb, IOSTAT = ios, ERR = 902 ) 49 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist' , lwp)49 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist' ) 50 50 IF(lwm) WRITE ( numond, nam_diatmb ) 51 51 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIA/diawri.F90
r11987 r12143 212 212 ENDIF 213 213 214 IF( ln_zad_Aimp ) wn = wn + wi ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 215 ! 214 216 CALL iom_put( "woce", wn ) ! vertical velocity 215 217 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value … … 222 224 IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 223 225 ENDIF 226 ! 227 IF( ln_zad_Aimp ) wn = wn - wi ! Remove implicit part of vertical velocity that was added for diagnostic output 224 228 225 229 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. … … 428 432 !! define all the NETCDF files and fields 429 433 !! At each time step call histdef to compute the mean if ncessary 430 !! Each n write time step, output the instantaneous or mean fields434 !! Each nn_write time step, output the instantaneous or mean fields 431 435 !!---------------------------------------------------------------------- 432 436 INTEGER, INTENT( in ) :: kt ! ocean time-step index … … 444 448 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace 445 449 !!---------------------------------------------------------------------- 446 !447 IF( ln_timing ) CALL timing_start('dia_wri')448 450 ! 449 451 IF( ninist == 1 ) THEN !== Output the initial state and forcings ==! … … 452 454 ENDIF 453 455 ! 456 IF( nn_write == -1 ) RETURN ! we will never do any output 457 ! 458 IF( ln_timing ) CALL timing_start('dia_wri') 459 ! 454 460 ! 0. Initialisation 455 461 ! ----------------- … … 461 467 clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) 462 468 #if defined key_diainstant 463 zsto = n write * rdt469 zsto = nn_write * rdt 464 470 clop = "inst("//TRIM(clop)//")" 465 471 #else … … 467 473 clop = "ave("//TRIM(clop)//")" 468 474 #endif 469 zout = n write * rdt475 zout = nn_write * rdt 470 476 zmax = ( nitend - nit000 + 1 ) * rdt 471 477 … … 498 504 ! WRITE root name in date.file for use by postpro 499 505 IF(lwp) THEN 500 CALL dia_nam( clhstnam, n write,' ' )506 CALL dia_nam( clhstnam, nn_write,' ' ) 501 507 CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 502 508 WRITE(inum,*) clhstnam … … 506 512 ! Define the T grid FILE ( nid_T ) 507 513 508 CALL dia_nam( clhstnam, n write, 'grid_T' )514 CALL dia_nam( clhstnam, nn_write, 'grid_T' ) 509 515 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename 510 516 CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit … … 542 548 ! Define the U grid FILE ( nid_U ) 543 549 544 CALL dia_nam( clhstnam, n write, 'grid_U' )550 CALL dia_nam( clhstnam, nn_write, 'grid_U' ) 545 551 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename 546 552 CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu … … 555 561 ! Define the V grid FILE ( nid_V ) 556 562 557 CALL dia_nam( clhstnam, n write, 'grid_V' ) ! filename563 CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename 558 564 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 559 565 CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv … … 568 574 ! Define the W grid FILE ( nid_W ) 569 575 570 CALL dia_nam( clhstnam, n write, 'grid_W' ) ! filename576 CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename 571 577 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 572 578 CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit … … 659 665 ENDIF 660 666 661 IF( .NOT. ln_cpl) THEN667 IF( ln_ssr ) THEN 662 668 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 663 669 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 667 673 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 668 674 ENDIF 669 670 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 671 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 672 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 673 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 674 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 675 CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping" , "Kg/m2/s", & ! erp * sn 676 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 677 ENDIF 678 675 679 676 clmx ="l_max(only(x))" ! max index on a period 680 677 ! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX … … 752 749 ! donne le nombre d'elements, et ndex la liste des indices a sortir 753 750 754 IF( lwp .AND. MOD( itmod, n write ) == 0 ) THEN751 IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN 755 752 WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' 756 753 WRITE(numout,*) '~~~~~~ ' … … 816 813 ENDIF 817 814 818 IF( .NOT. ln_cpl) THEN815 IF( ln_ssr ) THEN 819 816 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 820 817 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 821 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 822 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 823 ENDIF 824 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 825 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 826 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 827 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 818 zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 828 819 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 829 820 ENDIF … … 844 835 CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress 845 836 846 CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current 837 IF( ln_zad_Aimp ) THEN 838 CALL histwrite( nid_W, "vovecrtz", it, wn + wi , ndim_T, ndex_T ) ! vert. current 839 ELSE 840 CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current 841 ENDIF 847 842 CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef. 848 843 CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef. … … 906 901 CALL iom_rstput( 0, 0, inum, 'vozocrtx', un ) ! now i-velocity 907 902 CALL iom_rstput( 0, 0, inum, 'vomecrty', vn ) ! now j-velocity 908 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity 903 IF( ln_zad_Aimp ) THEN 904 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn + wi ) ! now k-velocity 905 ELSE 906 CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity 907 ENDIF 909 908 CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) ! now k-velocity 910 909 CALL iom_rstput( 0, 0, inum, 'ht_n' , ht_n ) ! now k-velocity -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DIU/diurnal_bulk.F90
r10069 r12143 54 54 REWIND( numnam_ref ) 55 55 READ ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) 56 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' , lwp)56 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' ) 57 57 REWIND( numnam_cfg ) 58 58 READ ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 ) 59 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' , lwp)59 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' ) 60 60 ! 61 61 IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DOM/domain.F90
r11823 r12143 101 101 CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)' 102 102 CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)' 103 CASE( 2 ) ; WRITE(numout,*) ' (i.e. equatorial symmetric)'103 CASE( 2 ) ; WRITE(numout,*) ' (i.e. cyclic north-south)' 104 104 CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)' 105 105 CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)' … … 300 300 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 301 301 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 302 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' , lwp)302 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) 303 303 REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run 304 304 READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 305 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' , lwp)305 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' ) 306 306 IF(lwm) WRITE ( numond, namrun ) 307 307 ! … … 328 328 WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock 329 329 ENDIF 330 #if ! defined key_iomput 330 331 WRITE(numout,*) ' frequency of output file nn_write = ', nn_write 332 #endif 331 333 WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland 332 334 WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta … … 349 351 nleapy = nn_leapy 350 352 ninist = nn_istate 351 nstock = nn_stock352 nstocklist = nn_stocklist353 nwrite = nn_write354 353 neuler = nn_euler 355 354 IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN … … 360 359 ENDIF 361 360 ! ! control of output frequency 362 IF( nstock == 0 .OR. nstock > nitend ) THEN 363 WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 361 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 362 IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 363 IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN 364 WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend 365 CALL ctl_warn( ctmp1 ) 366 nn_stock = nitend 367 ENDIF 368 ENDIF 369 #if ! defined key_iomput 370 IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) 371 IF ( nn_write == 0 ) THEN 372 WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend 364 373 CALL ctl_warn( ctmp1 ) 365 nstock = nitend 366 ENDIF 367 IF ( nwrite == 0 ) THEN 368 WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 369 CALL ctl_warn( ctmp1 ) 370 nwrite = nitend 371 ENDIF 374 nn_write = nitend 375 ENDIF 376 #endif 372 377 373 378 #if defined key_agrif … … 392 397 REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 393 398 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 394 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' , lwp)399 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 395 400 REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 396 401 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 397 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' , lwp)402 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 398 403 IF(lwm) WRITE( numond, namdom ) 399 404 ! … … 423 428 REWIND( numnam_ref ) ! Namelist namnc4 in reference namelist : NETCDF 424 429 READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 425 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' , lwp)430 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) 426 431 REWIND( numnam_cfg ) ! Namelist namnc4 in configuration namelist : NETCDF 427 432 READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 428 908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' , lwp)433 908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) 429 434 IF(lwm) WRITE( numond, namnc4 ) 430 435 … … 501 506 502 507 503 SUBROUTINE domain_cfg( ldtxt,cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )508 SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 504 509 !!---------------------------------------------------------------------- 505 510 !! *** ROUTINE dom_nam *** … … 509 514 !! ** Method : read the cn_domcfg NetCDF file 510 515 !!---------------------------------------------------------------------- 511 CHARACTER(len=*), DIMENSION(:), INTENT(out) :: ldtxt ! stored print information512 516 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 513 517 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution … … 515 519 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 516 520 ! 517 INTEGER :: inum , ii! local integer521 INTEGER :: inum ! local integer 518 522 REAL(wp) :: zorca_res ! local scalars 519 REAL(wp) :: ziglo, zjglo, zkglo, zperio ! - - 520 !!---------------------------------------------------------------------- 521 ! 522 ii = 1 523 WRITE(ldtxt(ii),*) ' ' ; ii = ii+1 524 WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' ; ii = ii+1 525 WRITE(ldtxt(ii),*) '~~~~~~~~~~ ' ; ii = ii+1 523 REAL(wp) :: zperio ! - - 524 INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions 525 !!---------------------------------------------------------------------- 526 ! 527 IF(lwp) THEN 528 WRITE(numout,*) ' ' 529 WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' 530 WRITE(numout,*) '~~~~~~~~~~ ' 531 ENDIF 526 532 ! 527 533 CALL iom_open( cn_domcfg, inum ) … … 534 540 CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) 535 541 ! 536 WRITE(ldtxt(ii),*) ' .' ; ii = ii+1 537 WRITE(ldtxt(ii),*) ' ==>>> ORCA configuration ' ; ii = ii+1 538 WRITE(ldtxt(ii),*) ' .' ; ii = ii+1 542 IF(lwp) THEN 543 WRITE(numout,*) ' .' 544 WRITE(numout,*) ' ==>>> ORCA configuration ' 545 WRITE(numout,*) ' .' 546 ENDIF 539 547 ! 540 548 ELSE !- cd_cfg & k_cfg are not used … … 549 557 ! 550 558 ENDIF 551 ! 552 CALL iom_get( inum, 'jpiglo', ziglo ) ; kpi = NINT( ziglo ) 553 CALL iom_get( inum, 'jpjglo', zjglo ) ; kpj = NINT( zjglo ) 554 CALL iom_get( inum, 'jpkglo', zkglo ) ; kpk = NINT( zkglo ) 559 ! 560 idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo 561 kpi = idimsz(1) 562 kpj = idimsz(2) 563 kpk = idimsz(3) 555 564 CALL iom_get( inum, 'jperio', zperio ) ; kperio = NINT( zperio ) 556 565 CALL iom_close( inum ) 557 566 ! 558 WRITE(ldtxt(ii),*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg ; ii = ii+1 559 WRITE(ldtxt(ii),*) ' jpiglo = ', kpi ; ii = ii+1 560 WRITE(ldtxt(ii),*) ' jpjglo = ', kpj ; ii = ii+1 561 WRITE(ldtxt(ii),*) ' jpkglo = ', kpk ; ii = ii+1 562 WRITE(ldtxt(ii),*) ' type of global domain lateral boundary jperio = ', kperio ; ii = ii+1 567 IF(lwp) THEN 568 WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg 569 WRITE(numout,*) ' jpiglo = ', kpi 570 WRITE(numout,*) ' jpjglo = ', kpj 571 WRITE(numout,*) ' jpkglo = ', kpk 572 WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio 573 ENDIF 563 574 ! 564 575 END SUBROUTINE domain_cfg -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DOM/dommsk.F90
r11233 r12143 100 100 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 101 101 & cn_ice, nn_ice_dta, & 102 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 103 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 102 & ln_vol, nn_volctl, nn_rimwidth 104 103 !!--------------------------------------------------------------------- 105 104 ! 106 105 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition 107 106 READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) 108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' , lwp)107 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' ) 109 108 REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition 110 109 READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) 111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' , lwp)110 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) 112 111 IF(lwm) WRITE ( numond, namlbc ) 113 112 … … 151 150 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries 152 151 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 153 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' , lwp)152 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 154 153 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries 155 154 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 156 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' , lwp)155 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 157 156 ! ------------------------ 158 157 IF ( ln_bdy .AND. ln_mask_file ) THEN -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DOM/domvvl.F90
r11823 r12143 353 353 END DO 354 354 ! 355 IF( ln_vvl_ztilde .OR. ln_vvl_layer.AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !356 ! ! ------baroclinic part------ !355 IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate ! 356 ! ! ------baroclinic part------ ! 357 357 ! I - initialization 358 358 ! ================== … … 1021 1021 REWIND( numnam_ref ) ! Namelist nam_vvl in reference namelist : 1022 1022 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 1023 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' , lwp)1023 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) 1024 1024 REWIND( numnam_cfg ) ! Namelist nam_vvl in configuration namelist : Parameters of the run 1025 1025 READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) 1026 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' , lwp)1026 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) 1027 1027 IF(lwm) WRITE ( numond, nam_vvl ) 1028 1028 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DOM/domwri.F90
r11987 r12143 161 161 CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 162 162 ! ! vertical mesh 163 CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8 ) ! ! scale factors 164 CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8 ) 165 CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8 ) 166 CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8 ) 163 CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors 164 CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 ) 165 166 CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) 167 CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) 168 CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) 169 CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) 170 CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) 171 CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8 ) 172 CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8 ) 167 173 ! 168 174 CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DOM/dtatsd.F90
r10213 r12143 67 67 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : 68 68 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 69 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' , lwp)69 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) 70 70 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run 71 71 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 72 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' , lwp)72 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) 73 73 IF(lwm) WRITE ( numond, namtsd ) 74 74 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynadv.F90
r10068 r12143 106 106 REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 107 107 READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' , lwp)108 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 109 109 REWIND( numnam_cfg ) ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 110 110 READ ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' , lwp)111 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 112 112 IF(lwm) WRITE ( numond, namdyn_adv ) 113 113 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynhpg.F90
r11987 r12143 39 39 USE trd_oce ! trends: ocean variables 40 40 USE trddyn ! trend manager: dynamics 41 !jcUSE zpshde ! partial step: hor. derivative (zps_hde routine)41 USE zpshde ! partial step: hor. derivative (zps_hde routine) 42 42 ! 43 43 USE in_out_manager ! I/O manager … … 154 154 REWIND( numnam_ref ) ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient 155 155 READ ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) 156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' , lwp)156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) 157 157 ! 158 158 REWIND( numnam_cfg ) ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient 159 159 READ ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) 160 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' , lwp)160 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) 161 161 IF(lwm) WRITE ( numond, namdyn_hpg ) 162 162 ! … … 299 299 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 300 300 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 301 REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 301 302 !!---------------------------------------------------------------------- 302 303 ! … … 307 308 ENDIF 308 309 309 ! Partial steps: bottom beforehorizontal gradient of t, s, rd at the last ocean level310 !jc CALL zps_hde ( kt, jpts, tsn, gtsu, gtsv, rhd, gru ,grv )310 ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level 311 CALL zps_hde( kt, jpts, tsn, zgtsu, zgtsv, rhd, zgru , zgrv ) 311 312 312 313 ! Local constant initialization … … 346 347 END DO 347 348 348 ! partial steps correction at the last level (use gru &grv computed in zpshde.F90)349 ! partial steps correction at the last level (use zgru & zgrv computed in zpshde.F90) 349 350 DO jj = 2, jpjm1 350 351 DO ji = 2, jpim1 … … 356 357 ua (ji,jj,iku) = ua(ji,jj,iku) - zhpi(ji,jj,iku) ! subtract old value 357 358 zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1) & ! compute the new one 358 & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + gru(ji,jj) ) * r1_e1u(ji,jj)359 & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) 359 360 ua (ji,jj,iku) = ua(ji,jj,iku) + zhpi(ji,jj,iku) ! add the new one to the general momentum trend 360 361 ENDIF … … 362 363 va (ji,jj,ikv) = va(ji,jj,ikv) - zhpj(ji,jj,ikv) ! subtract old value 363 364 zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1) & ! compute the new one 364 & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + grv(ji,jj) ) * r1_e2v(ji,jj)365 & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) 365 366 va (ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend 366 367 ENDIF -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynkeg.F90
r10996 r12143 74 74 INTEGER, INTENT( in ) :: kscheme ! =0/1 type of KEG scheme 75 75 ! 76 INTEGER :: ji, jj, jk, jb ! dummy loop indices 77 INTEGER :: ifu, ifv, igrd, ib_bdy ! local integers 76 INTEGER :: ji, jj, jk ! dummy loop indices 78 77 REAL(wp) :: zu, zv ! local scalars 79 78 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke 80 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 81 REAL(wp) :: zweightu, zweightv82 80 !!---------------------------------------------------------------------- 83 81 ! … … 112 110 END DO 113 111 END DO 114 !115 IF (ln_bdy) THEN116 ! Maria Luneva & Fred Wobus: July-2016117 ! compensate for lack of turbulent kinetic energy on liquid bdy points118 DO ib_bdy = 1, nb_bdy119 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN120 igrd = 1 ! compensating null velocity on the bdy121 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)122 ji = idx_bdy(ib_bdy)%nbi(jb,igrd) ! maximum extent : from 2 to jpi-1123 jj = idx_bdy(ib_bdy)%nbj(jb,igrd) ! maximum extent : from 2 to jpj-1124 DO jk = 1, jpkm1125 zhke(ji,jj,jk) = 0._wp126 zweightu = umask(ji-1,jj ,jk) + umask(ji,jj,jk)127 zweightv = vmask(ji ,jj-1,jk) + vmask(ji,jj,jk)128 zu = un(ji-1,jj ,jk) * un(ji-1,jj ,jk) + un(ji ,jj ,jk) * un(ji ,jj ,jk)129 zv = vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) + vn(ji ,jj ,jk) * vn(ji ,jj ,jk)130 IF( zweightu > 0._wp ) zhke(ji,jj,jk) = zhke(ji,jj,jk) + zu / (2._wp * zweightu)131 IF( zweightv > 0._wp ) zhke(ji,jj,jk) = zhke(ji,jj,jk) + zv / (2._wp * zweightv)132 END DO133 END DO134 END IF135 CALL lbc_bdy_lnk( 'dynkeg', zhke, 'T', 1., ib_bdy ) ! send 2 and recv jpi, jpj used in the computation of the speed tendencies136 END DO137 END IF138 !139 112 CASE ( nkeg_HW ) !-- Hollingsworth scheme --! 140 113 DO jk = 1, jpkm1 … … 154 127 END DO 155 128 END DO 156 IF (ln_bdy) THEN157 ! Maria Luneva & Fred Wobus: July-2016158 ! compensate for lack of turbulent kinetic energy on liquid bdy points159 DO ib_bdy = 1, nb_bdy160 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN161 igrd = 1 ! compensation null velocity on land at the bdy162 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)163 ji = idx_bdy(ib_bdy)%nbi(jb,igrd) ! maximum extent : from 2 to jpi-1164 jj = idx_bdy(ib_bdy)%nbj(jb,igrd) ! maximum extent : from 2 to jpj-1165 DO jk = 1, jpkm1166 zhke(ji,jj,jk) = 0._wp167 zweightu = 8._wp * ( umask(ji-1,jj ,jk) + umask(ji ,jj ,jk) ) &168 & + 2._wp * ( umask(ji-1,jj-1,jk) + umask(ji-1,jj+1,jk) + umask(ji ,jj-1,jk) + umask(ji ,jj+1,jk) )169 zweightv = 8._wp * ( vmask(ji ,jj-1,jk) + vmask(ji ,jj-1,jk) ) &170 & + 2._wp * ( vmask(ji-1,jj-1,jk) + vmask(ji+1,jj-1,jk) + vmask(ji-1,jj ,jk) + vmask(ji+1,jj ,jk) )171 zu = 8._wp * ( un(ji-1,jj ,jk) * un(ji-1,jj ,jk) &172 & + un(ji ,jj ,jk) * un(ji ,jj ,jk) ) &173 & + ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) &174 & + ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) ) * ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) )175 zv = 8._wp * ( vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) &176 & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) &177 & + ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) &178 & + ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) ) * ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) )179 IF( zweightu > 0._wp ) zhke(ji,jj,jk) = zhke(ji,jj,jk) + zu / ( 2._wp * zweightu )180 IF( zweightv > 0._wp ) zhke(ji,jj,jk) = zhke(ji,jj,jk) + zv / ( 2._wp * zweightv )181 END DO182 END DO183 END IF184 END DO185 END IF186 129 CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 187 130 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynnxt.F90
r11987 r12143 176 176 IF( neuler == 0 .AND. kt == nit000 ) THEN !* Euler at first time-step: only swap 177 177 DO jk = 1, jpkm1 178 ub(:,:,jk) = un(:,:,jk) ! ub <-- un 179 vb(:,:,jk) = vn(:,:,jk) 178 180 un(:,:,jk) = ua(:,:,jk) ! un <-- ua 179 181 vn(:,:,jk) = va(:,:,jk) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynspg.F90
r10068 r12143 202 202 REWIND( numnam_ref ) ! Namelist namdyn_spg in reference namelist : Free surface 203 203 READ ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) 204 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' , lwp)204 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) 205 205 ! 206 206 REWIND( numnam_cfg ) ! Namelist namdyn_spg in configuration namelist : Free surface 207 207 READ ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) 208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' , lwp)208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) 209 209 IF(lwm) WRITE ( numond, namdyn_spg ) 210 210 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynspg_ts.F90
r11987 r12143 64 64 USE diatmb ! Top,middle,bottom output 65 65 66 USE iom ! to remove 67 66 68 IMPLICIT NONE 67 69 PRIVATE … … 104 106 ! 105 107 ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT=ierr(1) ) 106 !107 108 IF( ln_dynvor_een .OR. ln_dynvor_eeT ) & 108 & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , & 109 & ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(2) ) 109 & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2) ) 110 110 ! 111 111 ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj) , STAT=ierr(3) ) … … 149 149 LOGICAL :: ll_fw_start ! =T : forward integration 150 150 LOGICAL :: ll_init ! =T : special startup of 2d equations 151 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables used in W/D 152 INTEGER :: ikbu, iktu, noffset ! local integers 153 INTEGER :: ikbv, iktv ! - - 154 REAL(wp) :: r1_2dt_b, z2dt_bf ! local scalars 155 REAL(wp) :: zx1, zx2, zu_spg, zhura, z1_hu ! - - 156 REAL(wp) :: zy1, zy2, zv_spg, zhvra, z1_hv ! - - 151 INTEGER :: noffset ! local integers : time offset for bdy update 152 REAL(wp) :: r1_2dt_b, z1_hu, z1_hv ! local scalars 157 153 REAL(wp) :: za0, za1, za2, za3 ! - - 158 REAL(wp) :: zmdi, zztmp , z1_ht ! - - 159 REAL(wp), DIMENSION(jpi,jpj) :: zsshp2_e, zhf 160 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zu_trd, zu_frc, zssh_frc 161 REAL(wp), DIMENSION(jpi,jpj) :: zwy, zv_trd, zv_frc, zhdiv 162 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhust_e, zhtp2_e 163 REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zhvst_e 154 REAL(wp) :: zmdi, zztmp, zldg ! - - 155 REAL(wp) :: zhu_bck, zhv_bck, zhdiv ! - - 156 REAL(wp) :: zun_save, zvn_save ! - - 157 REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc 158 REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg 159 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e 160 REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e 164 161 REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points 162 REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes 165 163 ! 166 164 REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. … … 182 180 zwdramp = r_rn_wdmin1 ! simplest ramp 183 181 ! zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp 184 ! ! reciprocal of baroclinic time step 185 IF( kt == nit000 .AND. neuler == 0 ) THEN ; z2dt_bf = rdt 186 ELSE ; z2dt_bf = 2.0_wp * rdt 187 ENDIF 188 r1_2dt_b = 1.0_wp / z2dt_bf 182 ! ! inverse of baroclinic time step 183 IF( kt == nit000 .AND. neuler == 0 ) THEN ; r1_2dt_b = 1._wp / ( rdt ) 184 ELSE ; r1_2dt_b = 1._wp / ( 2._wp * rdt ) 185 ENDIF 189 186 ! 190 187 ll_init = ln_bt_av ! if no time averaging, then no specific restart … … 210 207 ll_fw_start =.FALSE. 211 208 ENDIF 212 ! 213 ! Set averaging weights and cycle length: 209 ! ! Set averaging weights and cycle length: 214 210 CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 215 211 ! 216 ENDIF217 !218 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)219 DO jj = 2, jpjm1220 DO ji = fs_2, fs_jpim1 ! vector opt.221 zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) )222 zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) )223 END DO224 END DO225 ELSE ! bottom friction only226 DO jj = 2, jpjm1227 DO ji = fs_2, fs_jpim1 ! vector opt.228 zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) )229 zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) )230 END DO231 END DO232 ENDIF233 !234 ! Set arrays to remove/compute coriolis trend.235 ! Do it once at kt=nit000 if volume is fixed, else at each long time step.236 ! Note that these arrays are also used during barotropic loop. These are however frozen237 ! although they should be updated in the variable volume case. Not a big approximation.238 ! To remove this approximation, copy lines below inside barotropic loop239 ! and update depths at T-F points (ht and zhf resp.) at each barotropic time step240 !241 IF( kt == nit000 .OR. .NOT.ln_linssh ) THEN242 !243 SELECT CASE( nvor_scheme )244 CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme)245 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point246 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)247 DO jj = 1, jpjm1248 DO ji = 1, jpim1249 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + &250 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp251 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)252 END DO253 END DO254 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)255 DO jj = 1, jpjm1256 DO ji = 1, jpim1257 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) &258 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) &259 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) &260 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) )261 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)262 END DO263 END DO264 END SELECT265 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp )266 !267 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp268 DO jj = 2, jpj269 DO ji = 2, jpi270 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)271 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )272 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1)273 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj )274 END DO275 END DO276 !277 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme)278 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp279 DO jj = 2, jpj280 DO ji = 2, jpi281 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) )282 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht283 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht284 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht285 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht286 END DO287 END DO288 !289 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT !290 !291 zwz(:,:) = 0._wp292 zhf(:,:) = 0._wp293 294 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed295 !!gm A priori a better value should be something like :296 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)297 !!gm divided by the sum of the corresponding mask298 !!gm299 !!300 IF( .NOT.ln_sco ) THEN301 302 !!gm agree the JC comment : this should be done in a much clear way303 304 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case305 ! Set it to zero for the time being306 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level307 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth308 ! ENDIF309 ! zhf(:,:) = gdepw_0(:,:,jk+1)310 !311 ELSE312 !313 !zhf(:,:) = hbatf(:,:)314 DO jj = 1, jpjm1315 DO ji = 1, jpim1316 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) &317 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) &318 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) &319 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp )320 END DO321 END DO322 ENDIF323 !324 DO jj = 1, jpjm1325 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1))326 END DO327 !328 DO jk = 1, jpkm1329 DO jj = 1, jpjm1330 zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk)331 END DO332 END DO333 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp )334 ! JC: TBC. hf should be greater than 0335 DO jj = 1, jpj336 DO ji = 1, jpi337 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) ! zhf is actually hf here but it saves an array338 END DO339 END DO340 zwz(:,:) = ff_f(:,:) * zwz(:,:)341 END SELECT342 212 ENDIF 343 213 ! … … 348 218 CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 349 219 ENDIF 220 ! 350 221 351 222 ! ----------------------------------------------------------------------------- … … 354 225 ! 355 226 ! 356 ! !* e3*d/dt(Ua) (Vertically integrated) 357 ! ! -------------------------------------------------- 358 zu_frc(:,:) = 0._wp 359 zv_frc(:,:) = 0._wp 360 ! 361 DO jk = 1, jpkm1 362 zu_frc(:,:) = zu_frc(:,:) + e3u_n(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 363 zv_frc(:,:) = zv_frc(:,:) + e3v_n(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) 364 END DO 365 ! 366 zu_frc(:,:) = zu_frc(:,:) * r1_hu_n(:,:) 367 zv_frc(:,:) = zv_frc(:,:) * r1_hv_n(:,:) 368 ! 369 ! 370 ! !* baroclinic momentum trend (remove the vertical mean trend) 371 DO jk = 1, jpkm1 ! ----------------------------------------------------------- 372 DO jj = 2, jpjm1 373 DO ji = fs_2, fs_jpim1 ! vector opt. 374 ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk) 375 va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk) 376 END DO 377 END DO 227 ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) 228 ! ! --------------------------- ! 229 zu_frc(:,:) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) 230 zv_frc(:,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) 231 ! 232 ! 233 ! != Ua => baroclinic trend =! (remove its vertical mean) 234 DO jk = 1, jpkm1 ! ------------------------ ! 235 ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(:,:) ) * umask(:,:,jk) 236 va(:,:,jk) = ( va(:,:,jk) - zv_frc(:,:) ) * vmask(:,:,jk) 378 237 END DO 379 238 … … 381 240 !!gm Is it correct to do so ? I think so... 382 241 383 ! 384 ! !* barotropic Coriolis trends (vorticity scheme dependent) 385 ! ! -------------------------------------------------------- 386 ! 387 zwx(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 388 zwy(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) 389 ! 390 SELECT CASE( nvor_scheme ) 391 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 392 DO jj = 2, jpjm1 393 DO ji = 2, jpim1 ! vector opt. 394 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * r1_hu_n(ji,jj) & 395 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 396 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 397 ! 398 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * r1_hv_n(ji,jj) & 399 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 400 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 401 END DO 402 END DO 403 ! 404 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 405 DO jj = 2, jpjm1 406 DO ji = fs_2, fs_jpim1 ! vector opt. 407 zy1 = ( zwy(ji,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 408 zy2 = ( zwy(ji,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 409 zx1 = ( zwx(ji-1,jj) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 410 zx2 = ( zwx(ji ,jj) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 411 ! energy conserving formulation for planetary vorticity term 412 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 413 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 414 END DO 415 END DO 416 ! 417 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 418 DO jj = 2, jpjm1 419 DO ji = fs_2, fs_jpim1 ! vector opt. 420 zy1 = r1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 421 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 422 zx1 = - r1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 423 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 424 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 425 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 426 END DO 427 END DO 428 ! 429 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 430 DO jj = 2, jpjm1 431 DO ji = fs_2, fs_jpim1 ! vector opt. 432 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 433 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 434 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 435 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 436 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 437 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 438 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 439 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 440 END DO 441 END DO 442 ! 443 END SELECT 444 ! 445 ! !* Right-Hand-Side of the barotropic momentum equation 446 ! ! ---------------------------------------------------- 447 IF( .NOT.ln_linssh ) THEN ! Variable volume : remove surface pressure gradient 448 IF( ln_wd_il ) THEN ! Calculating and applying W/D gravity filters 242 ! != remove 2D Coriolis and pressure gradient trends =! 243 ! ! ------------------------------------------------- ! 244 ! 245 IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init ! Set zwz, the barotropic Coriolis force coefficient 246 ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes 247 ! 248 ! !* 2D Coriolis trends 249 zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 250 zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 251 ! 252 CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, & ! <<== in 253 & zu_trd, zv_trd ) ! ==>> out 254 ! 255 IF( .NOT.ln_linssh ) THEN !* surface pressure gradient (variable volume only) 256 ! 257 IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg 258 CALL wad_spg( sshn, zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy 449 259 DO jj = 2, jpjm1 450 DO ji = 2, jpim1 451 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 452 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 453 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 454 & > rn_wdmin1 + rn_wdmin2 455 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 456 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 457 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 458 IF(ll_tmp1) THEN 459 zcpx(ji,jj) = 1.0_wp 460 ELSEIF(ll_tmp2) THEN 461 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 462 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 463 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 464 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 465 ELSE 466 zcpx(ji,jj) = 0._wp 467 ENDIF 468 ! 469 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 470 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 471 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 472 & > rn_wdmin1 + rn_wdmin2 473 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 474 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 475 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 476 477 IF(ll_tmp1) THEN 478 zcpy(ji,jj) = 1.0_wp 479 ELSE IF(ll_tmp2) THEN 480 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 481 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 482 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 483 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 484 ELSE 485 zcpy(ji,jj) = 0._wp 486 ENDIF 487 END DO 488 END DO 489 ! 490 DO jj = 2, jpjm1 491 DO ji = 2, jpim1 260 DO ji = 2, jpim1 ! SPG with the application of W/D gravity filters 492 261 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & 493 262 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth … … 496 265 END DO 497 266 END DO 498 ! 499 ELSE 500 ! 267 ELSE ! now suface pressure gradient 501 268 DO jj = 2, jpjm1 502 269 DO ji = fs_2, fs_jpim1 ! vector opt. … … 516 283 END DO 517 284 ! 518 ! ! Add bottom stress contribution from baroclinic velocities: 519 IF (ln_bt_fw) THEN 520 DO jj = 2, jpjm1 521 DO ji = fs_2, fs_jpim1 ! vector opt. 522 ikbu = mbku(ji,jj) 523 ikbv = mbkv(ji,jj) 524 zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities 525 zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 526 END DO 527 END DO 528 ELSE 529 DO jj = 2, jpjm1 530 DO ji = fs_2, fs_jpim1 ! vector opt. 531 ikbu = mbku(ji,jj) 532 ikbv = mbkv(ji,jj) 533 zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities 534 zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 535 END DO 536 END DO 537 ENDIF 538 ! 539 ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 540 IF( ln_wd_il ) THEN 541 zztmp = -1._wp / rdtbt 542 DO jj = 2, jpjm1 543 DO ji = fs_2, fs_jpim1 ! vector opt. 544 zu_frc(ji,jj) = zu_frc(ji,jj) + & 545 & MAX(r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ), zztmp ) * zwx(ji,jj) * wdrampu(ji,jj) 546 zv_frc(ji,jj) = zv_frc(ji,jj) + & 547 & MAX(r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ), zztmp ) * zwy(ji,jj) * wdrampv(ji,jj) 548 END DO 549 END DO 550 ELSE 551 DO jj = 2, jpjm1 552 DO ji = fs_2, fs_jpim1 ! vector opt. 553 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj) 554 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zwy(ji,jj) 555 END DO 556 END DO 557 END IF 558 ! 559 IF( ln_isfcav ) THEN ! Add TOP stress contribution from baroclinic velocities: 560 IF( ln_bt_fw ) THEN 561 DO jj = 2, jpjm1 285 ! != Add bottom stress contribution from baroclinic velocities =! 286 ! ! ----------------------------------------------------------- ! 287 CALL dyn_drg_init( zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients 288 ! 289 ! != Add atmospheric pressure forcing =! 290 ! ! ---------------------------------- ! 291 IF( ln_apr_dyn ) THEN 292 IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 293 DO jj = 2, jpjm1 562 294 DO ji = fs_2, fs_jpim1 ! vector opt. 563 iktu = miku(ji,jj) 564 iktv = mikv(ji,jj) 565 zwx(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) ! NOW top baroclinic velocities 566 zwy(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 567 END DO 568 END DO 569 ELSE 570 DO jj = 2, jpjm1 295 zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 296 zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 297 END DO 298 END DO 299 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 300 zztmp = grav * r1_2 301 DO jj = 2, jpjm1 571 302 DO ji = fs_2, fs_jpim1 ! vector opt. 572 iktu = miku(ji,jj) 573 iktv = mikv(ji,jj) 574 zwx(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) ! BEFORE top baroclinic velocities 575 zwy(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 576 END DO 577 END DO 578 ENDIF 579 ! 580 ! Note that the "unclipped" top friction parameter is used even with explicit drag 581 DO jj = 2, jpjm1 582 DO ji = fs_2, fs_jpim1 ! vector opt. 583 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zwx(ji,jj) 584 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zwy(ji,jj) 585 END DO 586 END DO 587 ENDIF 588 ! 303 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 304 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 305 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 306 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 307 END DO 308 END DO 309 ENDIF 310 ENDIF 311 ! 312 ! != Add atmospheric pressure forcing =! 313 ! ! ---------------------------------- ! 589 314 IF( ln_bt_fw ) THEN ! Add wind forcing 590 315 DO jj = 2, jpjm1 … … 604 329 ENDIF 605 330 ! 606 IF( ln_apr_dyn ) THEN ! Add atm pressure forcing 607 IF( ln_bt_fw ) THEN 608 DO jj = 2, jpjm1 609 DO ji = fs_2, fs_jpim1 ! vector opt. 610 zu_spg = grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 611 zv_spg = grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 612 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 613 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 614 END DO 615 END DO 616 ELSE 617 zztmp = grav * r1_2 618 DO jj = 2, jpjm1 619 DO ji = fs_2, fs_jpim1 ! vector opt. 620 zu_spg = zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 621 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 622 zv_spg = zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 623 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 624 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 625 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 626 END DO 627 END DO 628 ENDIF 629 ENDIF 630 ! !* Right-Hand-Side of the barotropic ssh equation 631 ! ! ----------------------------------------------- 632 ! ! Surface net water flux, rivers and ice shelves 633 IF (ln_bt_fw) THEN 331 ! !----------------! 332 ! !== sssh_frc ==! Right-Hand-Side of the barotropic ssh equation (over the FULL domain) 333 ! !----------------! 334 ! != Net water flux forcing applied to a water column =! 335 ! ! --------------------------------------------------- ! 336 IF (ln_bt_fw) THEN ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 634 337 zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf_cav(:,:) + fwfisf_par(:,:) ) 635 ELSE 338 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 636 339 zztmp = r1_rau0 * r1_2 637 340 zssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) & … … 640 343 & + fwfisf_par(:,:) + fwfisf_par_b(:,:) ) 641 344 ENDIF 642 ! 643 IF( ln_sdw ) THEN ! Stokes drift divergence added if necessary345 ! != Add Stokes drift divergence =! (if exist) 346 IF( ln_sdw ) THEN ! ----------------------------- ! 644 347 zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) 645 348 ENDIF … … 661 364 ! 662 365 #if defined key_asminc 663 ! ! Include the IAU weighted SSH increment 366 ! != Add the IAU weighted SSH increment =! 367 ! ! ------------------------------------ ! 664 368 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 665 369 zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 666 370 ENDIF 667 371 #endif 668 ! ! *Fill boundary data arrays for AGRIF372 ! != Fill boundary data arrays for AGRIF 669 373 ! ! ------------------------------------ 670 374 #if defined key_agrif … … 688 392 vb_e (:,:) = 0._wp 689 393 ENDIF 690 394 ! 395 IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 396 zhup2_e(:,:) = hu_n(:,:) 397 zhvp2_e(:,:) = hv_n(:,:) 398 zhtp2_e(:,:) = ht_n(:,:) 399 ENDIF 691 400 ! 692 401 IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields … … 710 419 ENDIF 711 420 ! 712 !713 !714 421 ! Initialize sums: 715 422 ua_b (:,:) = 0._wp ! After barotropic velocities (or transport if flux form) … … 731 438 ! 732 439 l_full_nf_update = jn == icycle ! false: disable full North fold update (performances) for jn = 1 to icycle-1 733 ! ! ------------------ 734 ! !* Update the forcing (BDY and tides) 735 ! ! ------------------ 736 ! Update only tidal forcing at open boundaries 737 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset= noffset+1 ) 738 IF( ln_tide_pot .AND. ln_tide ) CALL upd_tide ( kt, kit=jn, time_offset= noffset ) 739 ! 740 ! Set extrapolation coefficients for predictor step: 440 ! 441 ! !== Update the forcing ==! (BDY and tides) 442 ! 443 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, kt_offset= noffset+1 ) 444 IF( ln_tide_pot .AND. ln_tide ) CALL upd_tide ( kt, kit=jn, kt_offset= noffset ) 445 ! 446 ! !== extrapolation at mid-step ==! (jn+1/2) 447 ! 448 ! !* Set extrapolation coefficients for predictor step: 741 449 IF ((jn<3).AND.ll_init) THEN ! Forward 742 450 za1 = 1._wp … … 748 456 za3 = 0.281105_wp ! za3 = bet 749 457 ENDIF 750 751 ! Extrapolate barotropic velocities at step jit+0.5: 458 ! 459 ! !* Extrapolate barotropic velocities at mid-step (jn+1/2) 460 !-- m+1/2 m m-1 m-2 --! 461 !-- u = (3/2+beta) u -(1/2+2beta) u + beta u --! 462 !-------------------------------------------------------------------------! 752 463 ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 753 464 va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) … … 756 467 ! ! ------------------ 757 468 ! Extrapolate Sea Level at step jit+0.5: 469 !-- m+1/2 m m-1 m-2 --! 470 !-- ssh = (3/2+beta) ssh -(1/2+2beta) ssh + beta ssh --! 471 !--------------------------------------------------------------------------------! 758 472 zsshp2_e(:,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 759 473 760 ! set wetting & drying mask at tracer points for this barotropic sub-step 761 IF ( ln_wd_dl ) THEN 762 ! 763 IF ( ln_wd_dl_rmp ) THEN 764 DO jj = 1, jpj 765 DO ji = 1, jpi ! vector opt. 766 IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 767 ! IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 768 ztwdmask(ji,jj) = 1._wp 769 ELSE IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 770 ztwdmask(ji,jj) = (tanh(50._wp*( ( zsshp2_e(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1)) ) 771 ELSE 772 ztwdmask(ji,jj) = 0._wp 773 END IF 774 END DO 775 END DO 776 ELSE 777 DO jj = 1, jpj 778 DO ji = 1, jpi ! vector opt. 779 IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 780 ztwdmask(ji,jj) = 1._wp 781 ELSE 782 ztwdmask(ji,jj) = 0._wp 783 ENDIF 784 END DO 785 END DO 786 ENDIF 787 ! 788 ENDIF 474 ! set wetting & drying mask at tracer points for this barotropic mid-step 475 IF( ln_wd_dl ) CALL wad_tmsk( zsshp2_e, ztwdmask ) 789 476 ! 790 DO jj = 2, jpjm1 ! Sea Surface Height at u- & v-points 791 DO ji = 2, fs_jpim1 ! Vector opt. 792 zwx(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 793 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 794 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 795 zwy(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 796 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 797 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 798 END DO 799 END DO 800 CALL lbc_lnk_multi( 'dynspg_ts', zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 477 ! ! ocean t-depth at mid-step 478 zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 801 479 ! 802 zhup2_e(:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points 803 zhvp2_e(:,:) = hv_0(:,:) + zwy(:,:) 804 zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 805 ELSE 806 zhup2_e(:,:) = hu_n(:,:) 807 zhvp2_e(:,:) = hv_n(:,:) 808 zhtp2_e(:,:) = ht_n(:,:) 809 ENDIF 810 ! !* after ssh 811 ! ! ----------- 812 ! 813 ! Enforce volume conservation at open boundaries: 480 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 481 DO jj = 1, jpj 482 DO ji = 1, jpim1 ! not jpi-column 483 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 484 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 485 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 486 END DO 487 END DO 488 DO jj = 1, jpjm1 ! not jpj-row 489 DO ji = 1, jpi 490 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 491 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 492 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 493 END DO 494 END DO 495 ! 496 ENDIF 497 ! 498 ! !== after SSH ==! (jn+1) 499 ! 500 ! ! update (ua_e,va_e) to enforce volume conservation at open boundaries 501 ! ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 814 502 IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) 815 503 ! 816 zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 817 zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 504 ! ! resulting flux at mid-step (not over the full domain) 505 zhU(1:jpim1,1:jpj ) = e2u(1:jpim1,1:jpj ) * ua_e(1:jpim1,1:jpj ) * zhup2_e(1:jpim1,1:jpj ) ! not jpi-column 506 zhV(1:jpi ,1:jpjm1) = e1v(1:jpi ,1:jpjm1) * va_e(1:jpi ,1:jpjm1) * zhvp2_e(1:jpi ,1:jpjm1) ! not jpj-row 818 507 ! 819 508 #if defined key_agrif … … 822 511 IF((nbondi == -1).OR.(nbondi == 2)) THEN 823 512 DO jj = 1, jpj 824 z wx(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj)825 z wy(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj)513 zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 514 zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 826 515 END DO 827 516 ENDIF 828 517 IF((nbondi == 1).OR.(nbondi == 2)) THEN 829 518 DO jj=1,jpj 830 z wx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj)831 z wy(nlci-nbghostcells :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells :nlci-1,jj)519 zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 520 zhV(nlci-nbghostcells :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells :nlci-1,jj) 832 521 END DO 833 522 ENDIF 834 523 IF((nbondj == -1).OR.(nbondj == 2)) THEN 835 524 DO ji=1,jpi 836 z wy(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1)837 z wx(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1)525 zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 526 zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 838 527 END DO 839 528 ENDIF 840 529 IF((nbondj == 1).OR.(nbondj == 2)) THEN 841 530 DO ji=1,jpi 842 z wy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2)843 z wx(ji,nlcj-nbghostcells :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells :nlcj-1)531 zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 532 zhU(ji,nlcj-nbghostcells :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells :nlcj-1) 844 533 END DO 845 534 ENDIF 846 535 ENDIF 847 536 #endif 848 IF( ln_wd_il ) CALL wad_lmt_bt(zwx, zwy, sshn_e, zssh_frc, rdtbt) 849 850 IF ( ln_wd_dl ) THEN 851 ! 852 ! un_e and vn_e are set to zero at faces where the direction of the flow is from dry cells 853 ! 854 DO jj = 1, jpjm1 855 DO ji = 1, jpim1 856 IF ( zwx(ji,jj) > 0.0 ) THEN 857 zuwdmask(ji, jj) = ztwdmask(ji ,jj) 858 ELSE 859 zuwdmask(ji, jj) = ztwdmask(ji+1,jj) 860 END IF 861 zwx(ji, jj) = zuwdmask(ji,jj)*zwx(ji, jj) 862 un_e(ji,jj) = zuwdmask(ji,jj)*un_e(ji,jj) 863 864 IF ( zwy(ji,jj) > 0.0 ) THEN 865 zvwdmask(ji, jj) = ztwdmask(ji, jj ) 866 ELSE 867 zvwdmask(ji, jj) = ztwdmask(ji, jj+1) 868 END IF 869 zwy(ji, jj) = zvwdmask(ji,jj)*zwy(ji,jj) 870 vn_e(ji,jj) = zvwdmask(ji,jj)*vn_e(ji,jj) 871 END DO 872 END DO 537 IF( ln_wd_il ) CALL wad_lmt_bt(zhU, zhV, sshn_e, zssh_frc, rdtbt) !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV 538 539 IF( ln_wd_dl ) THEN ! un_e and vn_e are set to zero at faces where 540 ! ! the direction of the flow is from dry cells 541 CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask ) ! not jpi colomn for U, not jpj row for V 873 542 ! 874 543 ENDIF 875 876 ! Sum over sub-time-steps to compute advective velocities 877 za2 = wgtbtp2(jn) 878 un_adv(:,:) = un_adv(:,:) + za2 * zwx(:,:) * r1_e2u(:,:) 879 vn_adv(:,:) = vn_adv(:,:) + za2 * zwy(:,:) * r1_e1v(:,:) 880 881 ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc = True) 544 ! 545 ! 546 ! Compute Sea Level at step jit+1 547 !-- m+1 m m+1/2 --! 548 !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! 549 !-------------------------------------------------------------------------! 550 DO jj = 2, jpjm1 ! INNER domain 551 DO ji = 2, jpim1 552 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) 553 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) 554 END DO 555 END DO 556 ! 557 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 558 ! 559 ! ! Sum over sub-time-steps to compute advective velocities 560 za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5 561 un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) 562 vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) 563 ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True) 882 564 IF ( ln_wd_dl_bc ) THEN 883 zuwdav2(:,:) = zuwdav2(:,:) + za2 * zuwdmask(:,:) 884 zvwdav2(:,:) = zvwdav2(:,:) + za2 * zvwdmask(:,:) 885 END IF 886 887 ! Set next sea level: 888 DO jj = 2, jpjm1 889 DO ji = fs_2, fs_jpim1 ! vector opt. 890 zhdiv(ji,jj) = ( zwx(ji,jj) - zwx(ji-1,jj) & 891 & + zwy(ji,jj) - zwy(ji,jj-1) ) * r1_e1e2t(ji,jj) 892 END DO 893 END DO 894 ssha_e(:,:) = ( sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) 895 896 CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._wp ) 897 565 zuwdav2(1:jpim1,1:jpj ) = zuwdav2(1:jpim1,1:jpj ) + za2 * zuwdmask(1:jpim1,1:jpj ) ! not jpi-column 566 zvwdav2(1:jpi ,1:jpjm1) = zvwdav2(1:jpi ,1:jpjm1) + za2 * zvwdmask(1:jpi ,1:jpjm1) ! not jpj-row 567 END IF 568 ! 898 569 ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 899 570 IF( ln_bdy ) CALL bdy_ssh( ssha_e ) … … 904 575 ! Sea Surface Height at u-,v-points (vvl case only) 905 576 IF( .NOT.ln_linssh ) THEN 906 DO jj = 2, jpjm1 577 DO jj = 2, jpjm1 ! INNER domain, will be extended to whole domain later 907 578 DO ji = 2, jpim1 ! NO Vector Opt. 908 579 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & … … 914 585 END DO 915 586 END DO 916 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp )917 587 ENDIF 918 ! 919 ! Half-step back interpolation of SSH for surface pressure computation: 920 !---------------------------------------------------------------------- 921 IF ((jn==1).AND.ll_init) THEN 922 za0=1._wp ! Forward-backward 923 za1=0._wp 924 za2=0._wp 925 za3=0._wp 926 ELSEIF ((jn==2).AND.ll_init) THEN ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 927 za0= 1.0833333333333_wp ! za0 = 1-gam-eps 928 za1=-0.1666666666666_wp ! za1 = gam 929 za2= 0.0833333333333_wp ! za2 = eps 930 za3= 0._wp 931 ELSE ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 932 IF (rn_bt_alpha==0._wp) THEN 933 za0=0.614_wp ! za0 = 1/2 + gam + 2*eps 934 za1=0.285_wp ! za1 = 1/2 - 2*gam - 3*eps 935 za2=0.088_wp ! za2 = gam 936 za3=0.013_wp ! za3 = eps 937 ELSE 938 zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 939 zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 940 za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 941 za1 = 1._wp - za0 - zgamma - zepsilon 942 za2 = zgamma 943 za3 = zepsilon 944 ENDIF 945 ENDIF 946 ! 588 ! 589 ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 590 !-- m+1/2 m+1 m m-1 m-2 --! 591 !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! 592 !------------------------------------------------------------------------------------------! 593 CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation 947 594 zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & 948 595 & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 949 950 IF( ln_wd_il ) THEN ! Calculating and applying W/D gravity filters 951 DO jj = 2, jpjm1 952 DO ji = 2, jpim1 953 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 954 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 955 & MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) ) & 956 & > rn_wdmin1 + rn_wdmin2 957 ll_tmp2 = (ABS(zsshp2_e(ji,jj) - zsshp2_e(ji+1,jj)) > 1.E-12 ).AND.( & 958 & MAX( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 959 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 960 961 IF(ll_tmp1) THEN 962 zcpx(ji,jj) = 1.0_wp 963 ELSE IF(ll_tmp2) THEN 964 ! no worries about zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj) = 0, it won't happen ! here 965 zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 966 & / (zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj)) ) 967 ELSE 968 zcpx(ji,jj) = 0._wp 969 ENDIF 970 ! 971 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 972 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 973 & MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) ) & 974 & > rn_wdmin1 + rn_wdmin2 975 ll_tmp2 = (ABS(zsshp2_e(ji,jj) - zsshp2_e(ji,jj+1)) > 1.E-12 ).AND.( & 976 & MAX( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 977 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 978 979 IF(ll_tmp1) THEN 980 zcpy(ji,jj) = 1.0_wp 981 ELSEIF(ll_tmp2) THEN 982 ! no worries about zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj ) = 0, it won't happen ! here 983 zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 984 & / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj )) ) 985 ELSE 986 zcpy(ji,jj) = 0._wp 987 ENDIF 988 END DO 989 END DO 990 ENDIF 991 ! 992 ! Compute associated depths at U and V points: 993 IF( .NOT.ln_linssh .AND. .NOT.ln_dynadv_vec ) THEN !* Vector form 994 ! 995 DO jj = 2, jpjm1 996 DO ji = 2, jpim1 997 zx1 = r1_2 * ssumask(ji ,jj) * r1_e1e2u(ji ,jj) & 998 & * ( e1e2t(ji ,jj ) * zsshp2_e(ji ,jj) & 999 & + e1e2t(ji+1,jj ) * zsshp2_e(ji+1,jj ) ) 1000 zy1 = r1_2 * ssvmask(ji ,jj) * r1_e1e2v(ji ,jj ) & 1001 & * ( e1e2t(ji ,jj ) * zsshp2_e(ji ,jj ) & 1002 & + e1e2t(ji ,jj+1) * zsshp2_e(ji ,jj+1) ) 1003 zhust_e(ji,jj) = hu_0(ji,jj) + zx1 1004 zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 1005 END DO 1006 END DO 1007 ! 596 ! 597 ! ! Surface pressure gradient 598 zldg = ( 1._wp - rn_scal_load ) * grav ! local factor 599 DO jj = 2, jpjm1 600 DO ji = 2, jpim1 601 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 602 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 603 END DO 604 END DO 605 IF( ln_wd_il ) THEN ! W/D : gravity filters applied on pressure gradient 606 CALL wad_spg( zsshp2_e, zcpx, zcpy ) ! Calculating W/D gravity filters 607 zu_spg(2:jpim1,2:jpjm1) = zu_spg(2:jpim1,2:jpjm1) * zcpx(2:jpim1,2:jpjm1) 608 zv_spg(2:jpim1,2:jpjm1) = zv_spg(2:jpim1,2:jpjm1) * zcpy(2:jpim1,2:jpjm1) 1008 609 ENDIF 1009 610 ! … … 1011 612 ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated 1012 613 ! at each time step. We however keep them constant here for optimization. 1013 ! Recall that zwx and zwy arrays hold fluxes at this stage: 1014 ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 1015 ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 1016 ! 1017 SELECT CASE( nvor_scheme ) 1018 CASE( np_ENT ) ! energy conserving scheme (t-point) 1019 DO jj = 2, jpjm1 1020 DO ji = 2, jpim1 ! vector opt. 1021 1022 z1_hu = ssumask(ji,jj) / ( zhup2_e(ji,jj) + 1._wp - ssumask(ji,jj) ) 1023 z1_hv = ssvmask(ji,jj) / ( zhvp2_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1024 1025 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1026 & * ( e1e2t(ji+1,jj)*zhtp2_e(ji+1,jj)*ff_t(ji+1,jj) * ( va_e(ji+1,jj) + va_e(ji+1,jj-1) ) & 1027 & + e1e2t(ji ,jj)*zhtp2_e(ji ,jj)*ff_t(ji ,jj) * ( va_e(ji ,jj) + va_e(ji ,jj-1) ) ) 1028 ! 1029 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1030 & * ( e1e2t(ji,jj+1)*zhtp2_e(ji,jj+1)*ff_t(ji,jj+1) * ( ua_e(ji,jj+1) + ua_e(ji-1,jj+1) ) & 1031 & + e1e2t(ji,jj )*zhtp2_e(ji,jj )*ff_t(ji,jj ) * ( ua_e(ji,jj ) + ua_e(ji-1,jj ) ) ) 1032 END DO 1033 END DO 1034 ! 1035 CASE( np_ENE, np_MIX ) ! energy conserving scheme (f-point) 1036 DO jj = 2, jpjm1 1037 DO ji = fs_2, fs_jpim1 ! vector opt. 1038 zy1 = ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 1039 zy2 = ( zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 1040 zx1 = ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 1041 zx2 = ( zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 1042 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1043 zv_trd(ji,jj) =-r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1044 END DO 1045 END DO 1046 ! 1047 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1048 DO jj = 2, jpjm1 1049 DO ji = fs_2, fs_jpim1 ! vector opt. 1050 zy1 = r1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 1051 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) * r1_e1u(ji,jj) 1052 zx1 = - r1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 1053 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) * r1_e2v(ji,jj) 1054 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1055 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1056 END DO 1057 END DO 1058 ! 1059 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1060 DO jj = 2, jpjm1 1061 DO ji = fs_2, fs_jpim1 ! vector opt. 1062 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 1063 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 1064 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 1065 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 1066 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 1067 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 1068 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 1069 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 1070 END DO 1071 END DO 1072 ! 1073 END SELECT 614 ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 615 CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) 1074 616 ! 1075 617 ! Add tidal astronomical forcing if defined … … 1077 619 DO jj = 2, jpjm1 1078 620 DO ji = fs_2, fs_jpim1 ! vector opt. 1079 zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 1080 zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 1081 zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 1082 zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 621 zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 622 zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 1083 623 END DO 1084 624 END DO … … 1094 634 END DO 1095 635 END DO 1096 ENDIF 1097 ! 1098 ! Surface pressure trend: 1099 IF( ln_wd_il ) THEN 1100 DO jj = 2, jpjm1 1101 DO ji = 2, jpim1 1102 ! Add surface pressure gradient 1103 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 1104 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 1105 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg * zcpx(ji,jj) 1106 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg * zcpy(ji,jj) 1107 END DO 1108 END DO 1109 ELSE 1110 DO jj = 2, jpjm1 1111 DO ji = fs_2, fs_jpim1 ! vector opt. 1112 ! Add surface pressure gradient 1113 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 1114 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 1115 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg 1116 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg 1117 END DO 1118 END DO 1119 END IF 1120 636 ENDIF 1121 637 ! 1122 638 ! Set next velocities: 639 ! Compute barotropic speeds at step jit+1 (h : total height of the water colomn) 640 !-- VECTOR FORM 641 !-- m+1 m / m+1/2 \ --! 642 !-- u = u + delta_t' * \ (1-r)*g * grad_x( ssh') - f * k vect u + frc / --! 643 !-- --! 644 !-- FLUX FORM --! 645 !-- m+1 __1__ / m m / m+1/2 m+1/2 m+1/2 n \ \ --! 646 !-- u = m+1 | h * u + delta_t' * \ h * (1-r)*g * grad_x( ssh') - h * f * k vect u + h * frc / | --! 647 !-- h \ / --! 648 !------------------------------------------------------------------------------------------------------------------------! 1123 649 IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form 1124 650 DO jj = 2, jpjm1 1125 651 DO ji = fs_2, fs_jpim1 ! vector opt. 1126 652 ua_e(ji,jj) = ( un_e(ji,jj) & 1127 & + rdtbt * ( zwx(ji,jj) &653 & + rdtbt * ( zu_spg(ji,jj) & 1128 654 & + zu_trd(ji,jj) & 1129 655 & + zu_frc(ji,jj) ) & … … 1131 657 1132 658 va_e(ji,jj) = ( vn_e(ji,jj) & 1133 & + rdtbt * ( zwy(ji,jj) &659 & + rdtbt * ( zv_spg(ji,jj) & 1134 660 & + zv_trd(ji,jj) & 1135 661 & + zv_frc(ji,jj) ) & 1136 662 & ) * ssvmask(ji,jj) 1137 1138 663 END DO 1139 664 END DO … … 1141 666 ELSE !* Flux form 1142 667 DO jj = 2, jpjm1 1143 DO ji = fs_2, fs_jpim1 ! vector opt. 1144 1145 zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 1146 zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 1147 1148 zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj)) 1149 zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj)) 1150 1151 ua_e(ji,jj) = ( hu_e(ji,jj) * un_e(ji,jj) & 1152 & + rdtbt * ( zhust_e(ji,jj) * zwx(ji,jj) & 1153 & + zhup2_e(ji,jj) * zu_trd(ji,jj) & 1154 & + hu_n(ji,jj) * zu_frc(ji,jj) ) & 1155 & ) * zhura 1156 1157 va_e(ji,jj) = ( hv_e(ji,jj) * vn_e(ji,jj) & 1158 & + rdtbt * ( zhvst_e(ji,jj) * zwy(ji,jj) & 1159 & + zhvp2_e(ji,jj) * zv_trd(ji,jj) & 1160 & + hv_n(ji,jj) * zv_frc(ji,jj) ) & 1161 & ) * zhvra 668 DO ji = 2, jpim1 669 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 670 ! ! backward interpolated depth used in spg terms at jn+1/2 671 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 672 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 673 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 674 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 675 ! ! inverse depth at jn+1 676 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 677 z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 678 ! 679 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & 680 & + rdtbt * ( zhu_bck * zu_spg (ji,jj) & ! 681 & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! 682 & + hu_n (ji,jj) * zu_frc (ji,jj) ) ) * z1_hu 683 ! 684 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & 685 & + rdtbt * ( zhv_bck * zv_spg (ji,jj) & ! 686 & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! 687 & + hv_n (ji,jj) * zv_frc (ji,jj) ) ) * z1_hv 1162 688 END DO 1163 689 END DO … … 1172 698 END DO 1173 699 ENDIF 1174 1175 1176 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 1177 hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 1178 hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 1179 hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 1180 hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) 1181 ! 1182 ENDIF 1183 ! !* domain lateral boundary 1184 CALL lbc_lnk_multi( 'dynspg_ts', ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 700 701 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 702 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 703 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 704 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 705 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 706 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & 707 & , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp & 708 & , hur_e, 'U', 1._wp, hvr_e, 'V', 1._wp ) 709 ELSE 710 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) 711 ENDIF 712 ! 1185 713 ! 1186 714 ! ! open boundaries … … 1230 758 ! Set advection velocity correction: 1231 759 IF (ln_bt_fw) THEN 1232 zwx(:,:) = un_adv(:,:)1233 zwy(:,:) = vn_adv(:,:)1234 760 IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 1235 un_adv(:,:) = r1_2 * ( ub2_b(:,:) + zwx(:,:) - atfp * un_bf(:,:) ) 1236 vn_adv(:,:) = r1_2 * ( vb2_b(:,:) + zwy(:,:) - atfp * vn_bf(:,:) ) 1237 ! 1238 ! Update corrective fluxes for next time step: 1239 un_bf(:,:) = atfp * un_bf(:,:) + (zwx(:,:) - ub2_b(:,:)) 1240 vn_bf(:,:) = atfp * vn_bf(:,:) + (zwy(:,:) - vb2_b(:,:)) 761 DO jj = 1, jpj 762 DO ji = 1, jpi 763 zun_save = un_adv(ji,jj) 764 zvn_save = vn_adv(ji,jj) 765 ! ! apply the previously computed correction 766 un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 767 vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 768 ! ! Update corrective fluxes for next time step 769 un_bf(ji,jj) = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 770 vn_bf(ji,jj) = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 771 ! ! Save integrated transport for next computation 772 ub2_b(ji,jj) = zun_save 773 vb2_b(ji,jj) = zvn_save 774 END DO 775 END DO 1241 776 ELSE 1242 un_bf(:,:) = 0._wp 1243 vn_bf(:,:) = 0._wp 1244 END IF 1245 ! Save integrated transport for next computation 1246 ub2_b(:,:) = zwx(:,:) 1247 vb2_b(:,:) = zwy(:,:) 777 un_bf(:,:) = 0._wp ! corrective fluxes for next time step set to zero 778 vn_bf(:,:) = 0._wp 779 ub2_b(:,:) = un_adv(:,:) ! Save integrated transport for next computation 780 vb2_b(:,:) = vn_adv(:,:) 781 END IF 1248 782 ENDIF 1249 783 … … 1287 821 1288 822 IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN 823 ! need to set lbc here because not done prior time averaging 824 CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) 1289 825 DO jk = 1, jpkm1 1290 826 un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) & … … 1490 1026 REAL(wp) :: zxr2, zyr2, zcmax ! local scalar 1491 1027 REAL(wp), DIMENSION(jpi,jpj) :: zcu 1028 INTEGER :: inum 1492 1029 !!---------------------------------------------------------------------- 1493 1030 ! … … 1596 1133 END SUBROUTINE dyn_spg_ts_init 1597 1134 1135 1136 SUBROUTINE dyn_cor_2d_init 1137 !!--------------------------------------------------------------------- 1138 !! *** ROUTINE dyn_cor_2d_init *** 1139 !! 1140 !! ** Purpose : Set time splitting options 1141 !! Set arrays to remove/compute coriolis trend. 1142 !! Do it once during initialization if volume is fixed, else at each long time step. 1143 !! Note that these arrays are also used during barotropic loop. These are however frozen 1144 !! although they should be updated in the variable volume case. Not a big approximation. 1145 !! To remove this approximation, copy lines below inside barotropic loop 1146 !! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 1147 !! 1148 !! Compute zwz = f / ( height of the water colomn ) 1149 !!---------------------------------------------------------------------- 1150 INTEGER :: ji ,jj, jk ! dummy loop indices 1151 REAL(wp) :: z1_ht 1152 REAL(wp), DIMENSION(jpi,jpj) :: zhf 1153 !!---------------------------------------------------------------------- 1154 ! 1155 SELECT CASE( nvor_scheme ) 1156 CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme) 1157 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point 1158 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1159 DO jj = 1, jpjm1 1160 DO ji = 1, jpim1 1161 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & 1162 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp 1163 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1164 END DO 1165 END DO 1166 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1167 DO jj = 1, jpjm1 1168 DO ji = 1, jpim1 1169 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & 1170 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & 1171 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & 1172 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) ) 1173 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1174 END DO 1175 END DO 1176 END SELECT 1177 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1178 ! 1179 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1180 DO jj = 2, jpj 1181 DO ji = 2, jpi 1182 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 1183 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) 1184 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) 1185 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) 1186 END DO 1187 END DO 1188 ! 1189 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme) 1190 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1191 DO jj = 2, jpj 1192 DO ji = 2, jpi 1193 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 1194 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht 1195 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht 1196 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 1197 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht 1198 END DO 1199 END DO 1200 ! 1201 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT ! 1202 ! 1203 zwz(:,:) = 0._wp 1204 zhf(:,:) = 0._wp 1205 1206 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed 1207 !!gm A priori a better value should be something like : 1208 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1) 1209 !!gm divided by the sum of the corresponding mask 1210 !!gm 1211 !! 1212 IF( .NOT.ln_sco ) THEN 1213 1214 !!gm agree the JC comment : this should be done in a much clear way 1215 1216 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 1217 ! Set it to zero for the time being 1218 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level 1219 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth 1220 ! ENDIF 1221 ! zhf(:,:) = gdepw_0(:,:,jk+1) 1222 ! 1223 ELSE 1224 ! 1225 !zhf(:,:) = hbatf(:,:) 1226 DO jj = 1, jpjm1 1227 DO ji = 1, jpim1 1228 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) & 1229 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) & 1230 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) & 1231 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp ) 1232 END DO 1233 END DO 1234 ENDIF 1235 ! 1236 DO jj = 1, jpjm1 1237 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 1238 END DO 1239 ! 1240 DO jk = 1, jpkm1 1241 DO jj = 1, jpjm1 1242 zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 1243 END DO 1244 END DO 1245 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 1246 ! JC: TBC. hf should be greater than 0 1247 DO jj = 1, jpj 1248 DO ji = 1, jpi 1249 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) 1250 END DO 1251 END DO 1252 zwz(:,:) = ff_f(:,:) * zwz(:,:) 1253 END SELECT 1254 1255 END SUBROUTINE dyn_cor_2d_init 1256 1257 1258 1259 SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, zu_trd, zv_trd ) 1260 !!--------------------------------------------------------------------- 1261 !! *** ROUTINE dyn_cor_2d *** 1262 !! 1263 !! ** Purpose : Compute u and v coriolis trends 1264 !!---------------------------------------------------------------------- 1265 INTEGER :: ji ,jj ! dummy loop indices 1266 REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - 1267 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV 1268 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd 1269 !!---------------------------------------------------------------------- 1270 SELECT CASE( nvor_scheme ) 1271 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 1272 DO jj = 2, jpjm1 1273 DO ji = 2, jpim1 1274 z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 1275 z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1276 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1277 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 1278 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 1279 ! 1280 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1281 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 1282 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 1283 END DO 1284 END DO 1285 ! 1286 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 1287 DO jj = 2, jpjm1 1288 DO ji = fs_2, fs_jpim1 ! vector opt. 1289 zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 1290 zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1291 zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 1292 zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1293 ! energy conserving formulation for planetary vorticity term 1294 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1295 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1296 END DO 1297 END DO 1298 ! 1299 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1300 DO jj = 2, jpjm1 1301 DO ji = fs_2, fs_jpim1 ! vector opt. 1302 zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & 1303 & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1304 zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & 1305 & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1306 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1307 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1308 END DO 1309 END DO 1310 ! 1311 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1312 DO jj = 2, jpjm1 1313 DO ji = fs_2, fs_jpim1 ! vector opt. 1314 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & 1315 & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & 1316 & + ftse(ji,jj ) * zhV(ji ,jj-1) & 1317 & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 1318 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 1319 & + ftse(ji,jj+1) * zhU(ji ,jj+1) & 1320 & + ftnw(ji,jj ) * zhU(ji-1,jj ) & 1321 & + ftne(ji,jj ) * zhU(ji ,jj ) ) 1322 END DO 1323 END DO 1324 ! 1325 END SELECT 1326 ! 1327 END SUBROUTINE dyn_cor_2D 1328 1329 1330 SUBROUTINE wad_tmsk( pssh, ptmsk ) 1331 !!---------------------------------------------------------------------- 1332 !! *** ROUTINE wad_lmt *** 1333 !! 1334 !! ** Purpose : set wetting & drying mask at tracer points 1335 !! for the current barotropic sub-step 1336 !! 1337 !! ** Method : ??? 1338 !! 1339 !! ** Action : ptmsk : wetting & drying t-mask 1340 !!---------------------------------------------------------------------- 1341 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! 1342 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! 1343 ! 1344 INTEGER :: ji, jj ! dummy loop indices 1345 !!---------------------------------------------------------------------- 1346 ! 1347 IF( ln_wd_dl_rmp ) THEN 1348 DO jj = 1, jpj 1349 DO ji = 1, jpi 1350 IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 1351 ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 1352 ptmsk(ji,jj) = 1._wp 1353 ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 1354 ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) 1355 ELSE 1356 ptmsk(ji,jj) = 0._wp 1357 ENDIF 1358 END DO 1359 END DO 1360 ELSE 1361 DO jj = 1, jpj 1362 DO ji = 1, jpi 1363 IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp 1364 ELSE ; ptmsk(ji,jj) = 0._wp 1365 ENDIF 1366 END DO 1367 END DO 1368 ENDIF 1369 ! 1370 END SUBROUTINE wad_tmsk 1371 1372 1373 SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) 1374 !!---------------------------------------------------------------------- 1375 !! *** ROUTINE wad_lmt *** 1376 !! 1377 !! ** Purpose : set wetting & drying mask at tracer points 1378 !! for the current barotropic sub-step 1379 !! 1380 !! ** Method : ??? 1381 !! 1382 !! ** Action : ptmsk : wetting & drying t-mask 1383 !!---------------------------------------------------------------------- 1384 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask 1385 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phU, phV, pu, pv ! ocean velocities and transports 1386 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask 1387 ! 1388 INTEGER :: ji, jj ! dummy loop indices 1389 !!---------------------------------------------------------------------- 1390 ! 1391 DO jj = 1, jpj 1392 DO ji = 1, jpim1 ! not jpi-column 1393 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1394 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) 1395 ENDIF 1396 phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 1397 pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 1398 END DO 1399 END DO 1400 ! 1401 DO jj = 1, jpjm1 ! not jpj-row 1402 DO ji = 1, jpi 1403 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1404 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) 1405 ENDIF 1406 phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) 1407 pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 1408 END DO 1409 END DO 1410 ! 1411 END SUBROUTINE wad_Umsk 1412 1413 1414 SUBROUTINE wad_spg( sshn, zcpx, zcpy ) 1415 !!--------------------------------------------------------------------- 1416 !! *** ROUTINE wad_sp *** 1417 !! 1418 !! ** Purpose : 1419 !!---------------------------------------------------------------------- 1420 INTEGER :: ji ,jj ! dummy loop indices 1421 LOGICAL :: ll_tmp1, ll_tmp2 1422 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: sshn 1423 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 1424 !!---------------------------------------------------------------------- 1425 DO jj = 2, jpjm1 1426 DO ji = 2, jpim1 1427 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1428 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 1429 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 1430 & > rn_wdmin1 + rn_wdmin2 1431 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 1432 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1433 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1434 IF(ll_tmp1) THEN 1435 zcpx(ji,jj) = 1.0_wp 1436 ELSEIF(ll_tmp2) THEN 1437 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 1438 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 1439 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 1440 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 1441 ELSE 1442 zcpx(ji,jj) = 0._wp 1443 ENDIF 1444 ! 1445 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1446 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 1447 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 1448 & > rn_wdmin1 + rn_wdmin2 1449 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 1450 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1451 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1452 1453 IF(ll_tmp1) THEN 1454 zcpy(ji,jj) = 1.0_wp 1455 ELSE IF(ll_tmp2) THEN 1456 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 1457 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 1458 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1459 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 1460 ELSE 1461 zcpy(ji,jj) = 0._wp 1462 ENDIF 1463 END DO 1464 END DO 1465 1466 END SUBROUTINE wad_spg 1467 1468 1469 1470 SUBROUTINE dyn_drg_init( pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 1471 !!---------------------------------------------------------------------- 1472 !! *** ROUTINE dyn_drg_init *** 1473 !! 1474 !! ** Purpose : - add the baroclinic top/bottom drag contribution to 1475 !! the baroclinic part of the barotropic RHS 1476 !! - compute the barotropic drag coefficients 1477 !! 1478 !! ** Method : computation done over the INNER domain only 1479 !!---------------------------------------------------------------------- 1480 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS 1481 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients 1482 ! 1483 INTEGER :: ji, jj ! dummy loop indices 1484 INTEGER :: ikbu, ikbv, iktu, iktv 1485 REAL(wp) :: zztmp 1486 REAL(wp), DIMENSION(jpi,jpj) :: zu_i, zv_i 1487 !!---------------------------------------------------------------------- 1488 ! 1489 ! !== Set the barotropic drag coef. ==! 1490 ! 1491 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities) 1492 1493 DO jj = 2, jpjm1 1494 DO ji = 2, jpim1 ! INNER domain 1495 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 1496 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 1497 END DO 1498 END DO 1499 ELSE ! bottom friction only 1500 DO jj = 2, jpjm1 1501 DO ji = 2, jpim1 ! INNER domain 1502 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 1503 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 1504 END DO 1505 END DO 1506 ENDIF 1507 ! 1508 ! !== BOTTOM stress contribution from baroclinic velocities ==! 1509 ! 1510 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities 1511 1512 DO jj = 2, jpjm1 1513 DO ji = 2, jpim1 ! INNER domain 1514 ikbu = mbku(ji,jj) 1515 ikbv = mbkv(ji,jj) 1516 zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 1517 zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 1518 END DO 1519 END DO 1520 ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities 1521 1522 DO jj = 2, jpjm1 1523 DO ji = 2, jpim1 ! INNER domain 1524 ikbu = mbku(ji,jj) 1525 ikbv = mbkv(ji,jj) 1526 zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 1527 zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 1528 END DO 1529 END DO 1530 ENDIF 1531 ! 1532 IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! 1533 zztmp = -1._wp / rdtbt 1534 DO jj = 2, jpjm1 1535 DO ji = 2, jpim1 ! INNER domain 1536 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & 1537 & r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) 1538 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & 1539 & r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) 1540 END DO 1541 END DO 1542 ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 1543 1544 DO jj = 2, jpjm1 1545 DO ji = 2, jpim1 ! INNER domain 1546 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 1547 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 1548 END DO 1549 END DO 1550 END IF 1551 ! 1552 ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) 1553 ! 1554 IF( ln_isfcav ) THEN 1555 ! 1556 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity 1557 1558 DO jj = 2, jpjm1 1559 DO ji = 2, jpim1 ! INNER domain 1560 iktu = miku(ji,jj) 1561 iktv = mikv(ji,jj) 1562 zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 1563 zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 1564 END DO 1565 END DO 1566 ELSE ! CENTRED integration: use BEFORE top baroclinic velocity 1567 1568 DO jj = 2, jpjm1 1569 DO ji = 2, jpim1 ! INNER domain 1570 iktu = miku(ji,jj) 1571 iktv = mikv(ji,jj) 1572 zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 1573 zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 1574 END DO 1575 END DO 1576 ENDIF 1577 ! 1578 ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 1579 1580 DO jj = 2, jpjm1 1581 DO ji = 2, jpim1 ! INNER domain 1582 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1583 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1584 END DO 1585 END DO 1586 ! 1587 ENDIF 1588 ! 1589 END SUBROUTINE dyn_drg_init 1590 1591 SUBROUTINE ts_bck_interp( jn, ll_init, & ! <== in 1592 & za0, za1, za2, za3 ) ! ==> out 1593 !!---------------------------------------------------------------------- 1594 INTEGER ,INTENT(in ) :: jn ! index of sub time step 1595 LOGICAL ,INTENT(in ) :: ll_init ! 1596 REAL(wp),INTENT( out) :: za0, za1, za2, za3 ! Half-step back interpolation coefficient 1597 ! 1598 REAL(wp) :: zepsilon, zgamma ! - - 1599 !!---------------------------------------------------------------------- 1600 ! ! set Half-step back interpolation coefficient 1601 IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward 1602 za0 = 1._wp 1603 za1 = 0._wp 1604 za2 = 0._wp 1605 za3 = 0._wp 1606 ELSEIF( jn==2 .AND. ll_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 1607 za0 = 1.0833333333333_wp ! za0 = 1-gam-eps 1608 za1 =-0.1666666666666_wp ! za1 = gam 1609 za2 = 0.0833333333333_wp ! za2 = eps 1610 za3 = 0._wp 1611 ELSE !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 1612 IF( rn_bt_alpha == 0._wp ) THEN ! Time diffusion 1613 za0 = 0.614_wp ! za0 = 1/2 + gam + 2*eps 1614 za1 = 0.285_wp ! za1 = 1/2 - 2*gam - 3*eps 1615 za2 = 0.088_wp ! za2 = gam 1616 za3 = 0.013_wp ! za3 = eps 1617 ELSE ! no time diffusion 1618 zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 1619 zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 1620 za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 1621 za1 = 1._wp - za0 - zgamma - zepsilon 1622 za2 = zgamma 1623 za3 = zepsilon 1624 ENDIF 1625 ENDIF 1626 END SUBROUTINE ts_bck_interp 1627 1628 1598 1629 !!====================================================================== 1599 1630 END MODULE dynspg_ts -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/dynvor.F90
r10425 r12143 851 851 REWIND( numnam_ref ) ! Namelist namdyn_vor in reference namelist : Vorticity scheme options 852 852 READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) 853 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' , lwp)853 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) 854 854 REWIND( numnam_cfg ) ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options 855 855 READ ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) 856 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' , lwp)856 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) 857 857 IF(lwm) WRITE ( numond, namdyn_vor ) 858 858 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/sshwzv.F90
r11987 r12143 9 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 11 12 !!---------------------------------------------------------------------- 12 13 … … 286 287 !! : wi : now vertical velocity (for implicit treatment) 287 288 !! 288 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 289 !! Reference : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent 290 !! implicit scheme for vertical advection in oceanic modeling. 291 !! Ocean Modelling, 91, 38-69. 289 292 !!---------------------------------------------------------------------- 290 293 INTEGER, INTENT(in) :: kt ! time step … … 293 296 REAL(wp) :: zCu, zcff, z1_e3t ! local scalars 294 297 REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters 295 REAL(wp) , PARAMETER :: Cu_max = 0. 27! local parameters298 REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters 296 299 REAL(wp) , PARAMETER :: Cu_cut = 2._wp*Cu_max - Cu_min ! local parameters 297 300 REAL(wp) , PARAMETER :: Fcu = 4._wp*Cu_max*(Cu_max-Cu_min) ! local parameters … … 307 310 ENDIF 308 311 ! 309 ! 310 DO jk = 1, jpkm1 ! calculate Courant numbers 311 DO jj = 2, jpjm1 312 DO ji = 2, fs_jpim1 ! vector opt. 313 z1_e3t = 1._wp / e3t_n(ji,jj,jk) 314 Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & ! 2*rdt and not r2dt (for restartability) 315 & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk), 0._wp ) - & 316 & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) ) & 317 & * r1_e1e2t(ji,jj) & 318 & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk), 0._wp ) - & 319 & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) ) & 320 & * r1_e1e2t(ji,jj) & 321 & ) * z1_e3t 312 ! Calculate Courant numbers 313 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 314 DO jk = 1, jpkm1 315 DO jj = 2, jpjm1 316 DO ji = 2, fs_jpim1 ! vector opt. 317 z1_e3t = 1._wp / e3t_n(ji,jj,jk) 318 ! 2*rdt and not r2dt (for restartability) 319 Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & 320 & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk) + un_td(ji ,jj,jk), 0._wp ) - & 321 & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk) + un_td(ji-1,jj,jk), 0._wp ) ) & 322 & * r1_e1e2t(ji,jj) & 323 & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk) + vn_td(ji,jj ,jk), 0._wp ) - & 324 & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk) + vn_td(ji,jj-1,jk), 0._wp ) ) & 325 & * r1_e1e2t(ji,jj) & 326 & ) * z1_e3t 327 END DO 322 328 END DO 323 329 END DO 324 END DO 330 ELSE 331 DO jk = 1, jpkm1 332 DO jj = 2, jpjm1 333 DO ji = 2, fs_jpim1 ! vector opt. 334 z1_e3t = 1._wp / e3t_n(ji,jj,jk) 335 ! 2*rdt and not r2dt (for restartability) 336 Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & 337 & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk), 0._wp ) - & 338 & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) ) & 339 & * r1_e1e2t(ji,jj) & 340 & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk), 0._wp ) - & 341 & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) ) & 342 & * r1_e1e2t(ji,jj) & 343 & ) * z1_e3t 344 END DO 345 END DO 346 END DO 347 ENDIF 325 348 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) 326 349 ! … … 353 376 wn(ji,jj,jk) = ( 1._wp - zcff ) * wn(ji,jj,jk) 354 377 ! 355 Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient 378 Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient below and in stp_ctl 356 379 END DO 357 380 END DO … … 360 383 ELSE 361 384 ! Fully explicit everywhere 362 Cu_adv(:,:,:) = 0._wp ! Reuse array to output coefficient 385 Cu_adv(:,:,:) = 0._wp ! Reuse array to output coefficient below and in stp_ctl 363 386 wi (:,:,:) = 0._wp 364 387 ENDIF -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/DYN/wet_dry.F90
r10499 r12143 81 81 REWIND( numnam_ref ) ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 82 82 READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 83 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' , .TRUE.)83 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' ) 84 84 REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 85 85 READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 86 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' , .TRUE.)86 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namwad ) 88 88 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/flo4rk.F90
r10068 r12143 4 4 !! Ocean floats : trajectory computation using a 4th order Runge-Kutta 5 5 !!====================================================================== 6 #if defined key_floats 7 !!---------------------------------------------------------------------- 8 !! 'key_floats' float trajectories 6 !! 9 7 !!---------------------------------------------------------------------- 10 8 !! flo_4rk : Compute the geographical position of floats … … 445 443 END SUBROUTINE flo_interp 446 444 447 # else448 !!----------------------------------------------------------------------449 !! No floats Dummy module450 !!----------------------------------------------------------------------451 #endif452 453 445 !!====================================================================== 454 446 END MODULE flo4rk -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/flo_oce.F90
r10425 r12143 6 6 !! History : OPA ! 1999-10 (CLIPPER projet) 7 7 !! NEMO 1.0 ! 2002-11 (G. Madec, A. Bozec) F90: Free form and module 8 !!----------------------------------------------------------------------9 #if defined key_floats10 !!----------------------------------------------------------------------11 !! 'key_floats' drifting floats12 8 !!---------------------------------------------------------------------- 13 9 USE par_oce ! ocean parameters … … 20 16 PUBLIC flo_oce_alloc ! Routine called in floats.F90 21 17 22 LOGICAL, PUBLIC, PARAMETER :: lk_floats = .TRUE. !: float flag23 24 18 !! float parameters 25 19 !! ---------------- 20 LOGICAL, PUBLIC :: ln_floats !: Activate floats or not 26 21 INTEGER, PUBLIC :: jpnfl !: total number of floats during the run 27 22 INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run … … 68 63 END FUNCTION flo_oce_alloc 69 64 70 #else71 !!----------------------------------------------------------------------72 !! Default option : NO drifting floats73 !!----------------------------------------------------------------------74 LOGICAL, PUBLIC, PARAMETER :: lk_floats = .FALSE. !: float flag75 #endif76 77 65 !!====================================================================== 78 66 END MODULE flo_oce -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/floats.F90
r10068 r12143 7 7 !! NEMO 1.0 ! 2002-06 (A. Bozec) F90, Free form and module 8 8 !!---------------------------------------------------------------------- 9 #if defined key_floats 10 !!---------------------------------------------------------------------- 11 !! 'key_floats' float trajectories 9 !! 12 10 !!---------------------------------------------------------------------- 13 11 !! flo_stp : float trajectories computation … … 30 28 31 29 PUBLIC flo_stp ! routine called by step.F90 32 PUBLIC flo_init ! routine called by opa.F9030 PUBLIC flo_init ! routine called by nemogcm.F90 33 31 34 32 !!---------------------------------------------------------------------- … … 81 79 INTEGER :: ios ! Local integer output status for namelist read 82 80 ! 83 NAMELIST/namflo/ jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii81 NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 84 82 !!--------------------------------------------------------------------- 85 83 ! … … 90 88 REWIND( numnam_ref ) ! Namelist namflo in reference namelist : Floats 91 89 READ ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) 92 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' , lwp)90 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' ) 93 91 94 92 REWIND( numnam_cfg ) ! Namelist namflo in configuration namelist : Floats 95 93 READ ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) 96 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' , lwp)94 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' ) 97 95 IF(lwm) WRITE ( numond, namflo ) 98 96 ! … … 100 98 WRITE(numout,*) 101 99 WRITE(numout,*) ' Namelist floats :' 102 WRITE(numout,*) ' number of floats jpnfl = ', jpnfl 103 WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo 104 WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo 105 WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl 106 WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl 107 WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo 108 WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 109 WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane 110 WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 100 WRITE(numout,*) ' Activate floats or not ln_floats = ', ln_floats 101 WRITE(numout,*) ' number of floats jpnfl = ', jpnfl 102 WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo 103 WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo 104 WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl 105 WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl 106 WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo 107 WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 108 WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane 109 WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 111 110 112 111 ENDIF 113 112 ! 114 ! ! allocate floats arrays 115 IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 116 ! 117 ! ! allocate flodom arrays 118 IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 119 ! 120 ! ! allocate flowri arrays 121 IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 122 ! 123 ! ! allocate florst arrays 124 IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 125 ! 126 jpnrstflo = jpnfl-jpnnewflo ! memory allocation 127 ! 128 DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput 129 nfloat(jfl) = jfl 130 END DO 131 ! 132 CALL flo_dom ! compute/read initial position of floats 133 ! 134 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step 113 IF( ln_floats ) THEN 114 ! ! allocate floats arrays 115 IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 116 ! 117 ! ! allocate flodom arrays 118 IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 119 ! 120 ! ! allocate flowri arrays 121 IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 122 ! 123 ! ! allocate florst arrays 124 IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 125 ! 126 jpnrstflo = jpnfl-jpnnewflo ! memory allocation 127 ! 128 DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput 129 nfloat(jfl) = jfl 130 END DO 131 ! 132 CALL flo_dom ! compute/read initial position of floats 133 ! 134 wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step 135 ! 136 ENDIF 135 137 ! 136 138 END SUBROUTINE flo_init 137 139 138 # else139 !!----------------------------------------------------------------------140 !! Default option : Empty module141 !!----------------------------------------------------------------------142 CONTAINS143 SUBROUTINE flo_stp( kt ) ! Empty routine144 IMPLICIT NONE145 INTEGER, INTENT( in ) :: kt146 WRITE(*,*) 'flo_stp: You should not have seen this print! error?', kt147 END SUBROUTINE flo_stp148 SUBROUTINE flo_init ! Empty routine149 IMPLICIT NONE150 END SUBROUTINE flo_init151 #endif152 153 140 !!====================================================================== 154 141 END MODULE floats -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/floblk.F90
r10425 r12143 4 4 !! Ocean floats : trajectory computation 5 5 !!====================================================================== 6 #if defined key_floats 7 !!---------------------------------------------------------------------- 8 !! 'key_floats' float trajectories 6 !! 9 7 !!---------------------------------------------------------------------- 10 8 !! flotblk : compute float trajectories with Blanke algorithme … … 369 367 END SUBROUTINE flo_blk 370 368 371 # else372 !!----------------------------------------------------------------------373 !! Default option Empty module374 !!----------------------------------------------------------------------375 CONTAINS376 SUBROUTINE flo_blk ! Empty routine377 END SUBROUTINE flo_blk378 #endif379 380 369 !!====================================================================== 381 370 END MODULE floblk -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/flodom.F90
r10425 r12143 6 6 !! History : OPA ! 1998-07 (Y.Drillet, CLIPPER) Original code 7 7 !! NEMO 3.3 ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes 8 !!----------------------------------------------------------------------9 #if defined key_floats10 !!----------------------------------------------------------------------11 !! 'key_floats' float trajectories12 8 !!---------------------------------------------------------------------- 13 9 !! flo_dom : initialization of floats … … 437 433 IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp 438 434 ! 439 dld = ATAN( DSQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls435 dld = ATAN(SQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls 440 436 flo_dstnce = dld * 1000._wp 441 437 ! … … 455 451 END FUNCTION flo_dom_alloc 456 452 457 458 #else459 !!----------------------------------------------------------------------460 !! Default option Empty module461 !!----------------------------------------------------------------------462 CONTAINS463 SUBROUTINE flo_dom ! Empty routine464 WRITE(*,*) 'flo_dom: : You should not have seen this print! error?'465 END SUBROUTINE flo_dom466 #endif467 468 453 !!====================================================================== 469 454 END MODULE flodom -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/florst.F90
r10425 r12143 8 8 !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module 9 9 !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others 10 !!----------------------------------------------------------------------11 #if defined key_floats12 !!----------------------------------------------------------------------13 !! 'key_floats' float trajectories14 10 !!---------------------------------------------------------------------- 15 11 USE flo_oce ! ocean drifting floats … … 125 121 END SUBROUTINE flo_rst 126 122 127 # else128 !!----------------------------------------------------------------------129 !! Default option Empty module130 !!----------------------------------------------------------------------131 CONTAINS132 SUBROUTINE flo_rst ! Empty routine133 END SUBROUTINE flo_rst134 #endif135 136 123 !!======================================================================= 137 124 END MODULE florst -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/FLO/flowri.F90
r10425 r12143 10 10 !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module 11 11 !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others 12 !!----------------------------------------------------------------------13 #if defined key_floats14 !!----------------------------------------------------------------------15 !! 'key_floats' float trajectories16 12 !!---------------------------------------------------------------------- 17 13 USE flo_oce ! ocean drifting floats … … 179 175 CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 180 176 irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) 181 WRITE(numflo,*) cexper,no,irecflo,jpnfl,nn_writefl177 WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl 182 178 ENDIF 183 179 … … 225 221 clname=TRIM(clname)//".nc" 226 222 227 CALL fliocrfd( clname , (/ 'ntraj' , 't' /), (/ jpnfl , -1/) , numflo )223 CALL fliocrfd( clname , (/'ntraj' , ' t' /), (/ jpnfl , -1/) , numflo ) 228 224 229 225 CALL fliodefv( numflo, 'traj_lon' , (/1,2/), v_t=flio_r8, long_name="Longitude" , units="degrees_east" ) … … 255 251 256 252 istart = (/jfl,irec/) 257 icfl = INT( tpkfl(jfl) ) ! K-index of the nearest point before 258 259 CALL flioputv( numflo , 'traj_lon' , zlon(jfl) , start=istart ) 260 CALL flioputv( numflo , 'traj_lat' , zlat(jfl) , start=istart ) 261 CALL flioputv( numflo , 'traj_depth' , zdep(jfl) , start=istart ) 262 CALL flioputv( numflo , 'traj_temp' , ztemp(icfl,jfl) , start=istart ) 263 CALL flioputv( numflo , 'traj_salt' , zsal(icfl,jfl) , start=istart ) 264 CALL flioputv( numflo , 'traj_dens' , zrho(icfl,jfl) , start=istart ) 253 254 CALL flioputv( numflo , 'traj_lon' , zlon(jfl), start=istart ) 255 CALL flioputv( numflo , 'traj_lat' , zlat(jfl), start=istart ) 256 CALL flioputv( numflo , 'traj_depth' , zdep(jfl), start=istart ) 257 CALL flioputv( numflo , 'traj_temp' , ztem(jfl), start=istart ) 258 CALL flioputv( numflo , 'traj_salt' , zsal(jfl), start=istart ) 259 CALL flioputv( numflo , 'traj_dens' , zrho(jfl), start=istart ) 265 260 266 261 ENDDO … … 277 272 END SUBROUTINE flo_wri 278 273 279 280 # else281 !!----------------------------------------------------------------------282 !! Default option Empty module283 !!----------------------------------------------------------------------284 CONTAINS285 SUBROUTINE flo_wri ! Empty routine286 END SUBROUTINE flo_wri287 #endif288 289 274 !!======================================================================= 290 275 END MODULE flowri -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ICB/icbini.F90
r10702 r12143 406 406 REWIND( numnam_ref ) ! Namelist namberg in reference namelist : Iceberg parameters 407 407 READ ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) 408 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' , lwp)408 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) 409 409 REWIND( numnam_cfg ) ! Namelist namberg in configuration namelist : Iceberg parameters 410 410 READ ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 ) 411 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' , lwp)411 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' ) 412 412 IF(lwm) WRITE ( numond, namberg ) 413 413 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ICB/icblbc.F90
r10570 r12143 278 278 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 279 279 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 280 IF( l_isend )CALL mpi_wait( iml_req1, iml_stat, iml_err )280 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 281 281 ibergs_rcvd_from_e = INT( zewbergs(2) ) 282 282 CASE( 0 ) … … 287 287 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 288 288 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 289 IF( l_isend )CALL mpi_wait( iml_req2, iml_stat, iml_err )290 IF( l_isend )CALL mpi_wait( iml_req3, iml_stat, iml_err )289 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 290 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 291 291 ibergs_rcvd_from_e = INT( zewbergs(2) ) 292 292 ibergs_rcvd_from_w = INT( zwebergs(2) ) … … 295 295 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 296 296 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 297 IF( l_isend )CALL mpi_wait( iml_req4, iml_stat, iml_err )297 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 298 298 ibergs_rcvd_from_w = INT( zwebergs(2) ) 299 299 END SELECT … … 310 310 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 311 311 ENDIF 312 IF( ibergs_to_send_e > 0 .AND. l_isend) CALL mpi_wait( iml_req1, iml_stat, iml_err )312 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 313 313 DO i = 1, ibergs_rcvd_from_e 314 314 IF( nn_verbose_level >= 4 ) THEN … … 329 329 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 330 330 ENDIF 331 IF( ibergs_to_send_w > 0 .AND. l_isend) CALL mpi_wait( iml_req2, iml_stat, iml_err )332 IF( ibergs_to_send_e > 0 .AND. l_isend) CALL mpi_wait( iml_req3, iml_stat, iml_err )331 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 332 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 333 333 DO i = 1, ibergs_rcvd_from_e 334 334 IF( nn_verbose_level >= 4 ) THEN … … 351 351 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 352 352 ENDIF 353 IF( ibergs_to_send_w > 0 .AND. l_isend) CALL mpi_wait( iml_req4, iml_stat, iml_err )353 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 354 354 DO i = 1, ibergs_rcvd_from_w 355 355 IF( nn_verbose_level >= 4 ) THEN … … 409 409 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 410 410 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 411 IF( l_isend )CALL mpi_wait( iml_req1, iml_stat, iml_err )411 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 412 412 ibergs_rcvd_from_n = INT( znsbergs(2) ) 413 413 CASE( 0 ) … … 418 418 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 419 419 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 420 IF( l_isend )CALL mpi_wait( iml_req2, iml_stat, iml_err )421 IF( l_isend )CALL mpi_wait( iml_req3, iml_stat, iml_err )420 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 421 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 422 422 ibergs_rcvd_from_n = INT( znsbergs(2) ) 423 423 ibergs_rcvd_from_s = INT( zsnbergs(2) ) … … 426 426 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 427 427 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 428 IF( l_isend )CALL mpi_wait( iml_req4, iml_stat, iml_err )428 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 429 429 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 430 430 END SELECT … … 441 441 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 442 442 ENDIF 443 IF( ibergs_to_send_n > 0 .AND. l_isend) CALL mpi_wait( iml_req1, iml_stat, iml_err )443 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 444 444 DO i = 1, ibergs_rcvd_from_n 445 445 IF( nn_verbose_level >= 4 ) THEN … … 460 460 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 461 461 ENDIF 462 IF( ibergs_to_send_s > 0 .AND. l_isend) CALL mpi_wait( iml_req2, iml_stat, iml_err )463 IF( ibergs_to_send_n > 0 .AND. l_isend) CALL mpi_wait( iml_req3, iml_stat, iml_err )462 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 463 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 464 464 DO i = 1, ibergs_rcvd_from_n 465 465 IF( nn_verbose_level >= 4 ) THEN … … 482 482 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 483 483 ENDIF 484 IF( ibergs_to_send_s > 0 .AND. l_isend) CALL mpi_wait( iml_req4, iml_stat, iml_err )484 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 485 485 DO i = 1, ibergs_rcvd_from_s 486 486 IF( nn_verbose_level >= 4 ) THEN … … 669 669 ifldproc = nicbfldproc(jn) 670 670 IF( ifldproc == narea ) CYCLE 671 672 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 671 CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 673 672 ENDIF 674 673 ! … … 770 769 ifldproc = nicbfldproc(jn) 771 770 IF( ifldproc == narea ) CYCLE 772 773 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 771 CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 774 772 ENDIF 775 773 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ICB/icbrst.F90
r10425 r12143 131 131 CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) 132 132 num_bergs(:) = INT(zdata(:)) 133 ! Close file134 CALL iom_close( ncid )135 133 ! 136 134 … … 146 144 IF( lwp ) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_read: there were',ibergs_in_file, & 147 145 & ' bergs in the restart file and', jn,' bergs have been read' 146 ! Close file 147 CALL iom_close( ncid ) 148 148 ! 149 149 ! Confirm that all areas have a suitable base for assigning new iceberg -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ICB/icbstp.F90
r10570 r12143 86 86 ! !* write out time 87 87 ll_verbose = .FALSE. 88 IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > =0 )88 IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > 0 ) 89 89 ! 90 90 IF( ll_verbose ) WRITE(numicb,9100) nktberg, ndastp, nsec_day -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/IOM/in_out_manager.F90
r10817 r12143 80 80 INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) 81 81 INTEGER :: ninist !: initial state output flag (0/1) 82 INTEGER :: nwrite !: model standard output frequency83 INTEGER :: nstock !: restart file frequency84 INTEGER, DIMENSION(10) :: nstocklist !: restart dump times85 82 86 83 !!---------------------------------------------------------------------- … … 167 164 CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 168 165 CHARACTER(lc) :: ctmp10 !: temporary character 10 169 CHARACTER(lc) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !:170 CHARACTER(lc) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !:171 166 LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) 172 167 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/IOM/iom.F90
r11521 r12143 58 58 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 59 59 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 60 PUBLIC iom_use, iom_context_finalize 60 PUBLIC iom_use, iom_context_finalize, iom_miss_val 61 61 62 62 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d … … 212 212 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 213 213 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 214 !215 # if defined key_floats216 214 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 217 # endif218 215 # if defined key_si3 219 216 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 686 683 clname = trim(cdname) 687 684 IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN 688 iln = INDEX(clname,'/') 685 !FUS iln = INDEX(clname,'/') 686 iln = INDEX(clname,'/',BACK=.true.) ! FUS: to insert the nest index at the right location within the string, the last / has to be found (search from the right to left) 689 687 cltmpn = clname(1:iln) 690 688 clname = clname(iln+1:LEN_TRIM(clname)) … … 824 822 825 823 826 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ld stop )824 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) 827 825 !!----------------------------------------------------------------------- 828 826 !! *** FUNCTION iom_varid *** … … 833 831 CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable 834 832 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension 835 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 833 INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions 834 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 836 835 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) 837 836 ! … … 863 862 iiv = iiv + 1 864 863 IF( iiv <= jpmax_vars ) THEN 865 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims )864 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) 866 865 ELSE 867 866 CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & … … 881 880 ENDIF 882 881 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) 882 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) 883 883 ENDIF 884 884 ENDIF … … 1259 1259 !--- overlap areas and extra hallows (mpp) 1260 1260 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1261 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.,'no0')1261 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 1262 1262 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1263 1263 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1264 1264 IF( icnt(3) == inlev ) THEN 1265 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.,'no0')1265 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 1266 1266 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1267 1267 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO … … 1288 1288 CALL xios_recv_field( trim(cdvar), pv_r3d) 1289 1289 IF(idom /= jpdom_unknown ) then 1290 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.,'no0')1290 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1291 1291 ENDIF 1292 1292 ELSEIF( PRESENT(pv_r2d) ) THEN … … 1295 1295 CALL xios_recv_field( trim(cdvar), pv_r2d) 1296 1296 IF(idom /= jpdom_unknown ) THEN 1297 CALL lbc_lnk('iom', pv_r2d,'Z',-999., 'no0')1297 CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1298 1298 ENDIF 1299 1299 ELSEIF( PRESENT(pv_r1d) ) THEN … … 1658 1658 CHARACTER(LEN=*), INTENT(in) :: cdname 1659 1659 REAL(wp) , INTENT(in) :: pfield0d 1660 REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1660 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1661 1661 #if defined key_iomput 1662 zz(:,:)=pfield0d1663 CALL xios_send_field(cdname, zz)1664 !CALL xios_send_field(cdname, (/pfield0d/))1662 !!clem zz(:,:)=pfield0d 1663 !!clem CALL xios_send_field(cdname, zz) 1664 CALL xios_send_field(cdname, (/pfield0d/)) 1665 1665 #else 1666 1666 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings … … 1968 1968 ! Cell vertices on boundries 1969 1969 DO jn = 1, 4 1970 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., p val=999._wp )1971 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., p val=999._wp )1970 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) 1971 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) 1972 1972 END DO 1973 1973 ! … … 2228 2228 CHARACTER(LEN=20) :: clfreq 2229 2229 CHARACTER(LEN=20) :: cldate 2230 CHARACTER(LEN=256) :: cltmpn !FUS needed for correct path with AGRIF 2231 INTEGER :: iln !FUS needed for correct path with AGRIF 2230 2232 INTEGER :: idx 2231 2233 INTEGER :: jn … … 2310 2312 END DO 2311 2313 ! 2312 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 2314 !FUS IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 2315 !FUS see comment line 700 2316 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) THEN 2317 iln = INDEX(clname,'/',BACK=.true.) 2318 cltmpn = clname(1:iln) 2319 clname = clname(iln+1:LEN_TRIM(clname)) 2320 clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) 2321 ENDIF 2322 !FUS 2313 2323 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 2314 2324 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) … … 2378 2388 !! NOT 'key_iomput' a few dummy routines 2379 2389 !!---------------------------------------------------------------------- 2380 2381 2390 SUBROUTINE iom_setkt( kt, cdname ) 2382 2391 INTEGER , INTENT(in):: kt … … 2393 2402 2394 2403 LOGICAL FUNCTION iom_use( cdname ) 2395 !!----------------------------------------------------------------------2396 !!----------------------------------------------------------------------2397 2404 CHARACTER(LEN=*), INTENT(in) :: cdname 2398 !!----------------------------------------------------------------------2399 2405 #if defined key_iomput 2400 2406 iom_use = xios_field_is_active( cdname ) … … 2403 2409 #endif 2404 2410 END FUNCTION iom_use 2405 2411 2412 SUBROUTINE iom_miss_val( cdname, pmiss_val ) 2413 CHARACTER(LEN=*), INTENT(in ) :: cdname 2414 REAL(wp) , INTENT(out) :: pmiss_val 2415 #if defined key_iomput 2416 ! get missing value 2417 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2418 #else 2419 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings 2420 #endif 2421 END SUBROUTINE iom_miss_val 2422 2406 2423 !!====================================================================== 2407 2424 END MODULE iom -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/IOM/iom_nf90.F90
r10522 r12143 187 187 188 188 189 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims )189 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld ) 190 190 !!----------------------------------------------------------------------- 191 191 !! *** FUNCTION iom_varid *** … … 198 198 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of the dimensions 199 199 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 200 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 200 201 ! 201 202 INTEGER :: iom_nf90_varid ! iom variable Id … … 251 252 ENDIF 252 253 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(kiv) 254 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld(kiv) 253 255 ELSE 254 256 iom_nf90_varid = -1 ! variable not found, return error code: -1 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/IOM/restart.F90
r11823 r12143 70 70 IF( ln_rst_list ) THEN 71 71 nrst_lst = 1 72 nitrst = n stocklist( nrst_lst )72 nitrst = nn_stocklist( nrst_lst ) 73 73 ELSE 74 74 nitrst = nitend 75 75 ENDIF 76 76 ENDIF 77 78 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 77 79 78 80 ! frequency-based restart dumping (nn_stock) 79 IF( .NOT. ln_rst_list .AND. MOD( kt - 1, n stock ) == 0 ) THEN81 IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nn_stock ) == 0 ) THEN 80 82 ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 81 nitrst = kt + n stock - 1 ! define the next value of nitrst for restart writing83 nitrst = kt + nn_stock - 1 ! define the next value of nitrst for restart writing 82 84 IF( nitrst > nitend ) nitrst = nitend ! make sure we write a restart at the end of the run 83 85 ENDIF … … 85 87 ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1) 86 88 ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 87 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN89 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 88 90 IF( nitrst <= nitend .AND. nitrst > 0 ) THEN 89 91 ! beware of the format used to write kt (default is i8.8, that should be large enough...) … … 173 175 lrst_oce = .FALSE. 174 176 IF( ln_rst_list ) THEN 175 nrst_lst = MIN(nrst_lst + 1, SIZE(n stocklist,1))176 nitrst = n stocklist( nrst_lst )177 nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 178 nitrst = nn_stocklist( nrst_lst ) 177 179 ENDIF 178 180 ENDIF -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ISF/isfstp.F90
r12062 r12143 291 291 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs 292 292 READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901) 293 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' , lwp)293 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' ) 294 294 ! 295 295 REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs 296 296 READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 ) 297 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' , lwp)297 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' ) 298 298 IF(lwm) WRITE ( numond, namisf ) 299 299 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbc_lnk_multi_generic.h90
r10425 r12143 14 14 # define PTR_ptab pt4d 15 15 #endif 16 SUBROUTINE ROUTINE_MULTI( cdname & 17 & , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3 & 18 & , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6 & 19 & , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 16 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 19 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 20 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 21 & , kfillmode, pfillval, lsend, lrecv, ihlcom ) 20 22 !!--------------------------------------------------------------------- 21 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 22 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 23 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 24 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 25 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 26 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 27 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9 28 CHARACTER(len=3) , OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 29 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 23 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 24 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 25 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 26 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 27 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 28 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 29 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 30 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 31 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 32 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 33 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 30 34 !! 31 INTEGER :: kfld ! number of elements that will be attributed32 PTR_TYPE , DIMENSION( 9) :: ptab_ptr ! pointer array33 CHARACTER(len=1) , DIMENSION( 9) :: cdna_ptr ! nature of ptab_ptr grid-points34 REAL(wp) , DIMENSION( 9) :: psgn_ptr ! sign used across the north fold boundary35 INTEGER :: kfld ! number of elements that will be attributed 36 PTR_TYPE , DIMENSION(11) :: ptab_ptr ! pointer array 37 CHARACTER(len=1) , DIMENSION(11) :: cdna_ptr ! nature of ptab_ptr grid-points 38 REAL(wp) , DIMENSION(11) :: psgn_ptr ! sign used across the north fold boundary 35 39 !!--------------------------------------------------------------------- 36 40 ! … … 41 45 ! 42 46 ! ! Look if more arrays are added 43 IF( PRESENT(psgn2) ) CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 44 IF( PRESENT(psgn3) ) CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 45 IF( PRESENT(psgn4) ) CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 46 IF( PRESENT(psgn5) ) CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn6) ) CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn7) ) CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn8) ) CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn9) ) CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 52 IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 53 IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 54 IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 55 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 57 ! 52 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval)58 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 53 59 ! 54 60 END SUBROUTINE ROUTINE_MULTI … … 72 78 ! 73 79 END SUBROUTINE ROUTINE_LOAD 80 74 81 #undef ARRAY_TYPE 75 82 #undef PTR_TYPE -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r10425 r12143 74 74 ! 75 75 ! Security check for further developments 76 IF ( ipf > 1 ) THEN 77 write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation' 78 write(6,*) 'You should not be there...' 79 STOP 80 ENDIF 76 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 81 77 ! 82 78 ijpj = 1 ! index of first modified line -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbclnk.F90
r10425 r12143 14 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 15 15 !!---------------------------------------------------------------------- 16 #if defined key_mpp_mpi17 !!----------------------------------------------------------------------18 !! 'key_mpp_mpi' MPI massively parallel processing library19 !!----------------------------------------------------------------------20 16 !! define the generic interfaces of lib_mpp routines 21 17 !!---------------------------------------------------------------------- … … 23 19 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 24 20 !!---------------------------------------------------------------------- 25 USE par_oce ! ocean dynamics and tracers21 USE dom_oce ! ocean space and time domain 26 22 USE lib_mpp ! distributed memory computing library 27 23 USE lbcnfd ! north fold 24 USE in_out_manager ! I/O manager 25 26 IMPLICIT NONE 27 PRIVATE 28 28 29 29 INTERFACE lbc_lnk … … 37 37 END INTERFACE 38 38 ! 39 INTERFACE lbc_bdy_lnk40 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d41 END INTERFACE42 !43 39 INTERFACE lbc_lnk_icb 44 40 MODULE PROCEDURE mpp_lnk_2d_icb 45 41 END INTERFACE 46 42 43 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 46 END INTERFACE 47 47 48 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 48 49 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions50 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 51 52 #if defined key_mpp_mpi 53 !$AGRIF_DO_NOT_TREAT 54 INCLUDE 'mpif.h' 55 !$AGRIF_END_DO_NOT_TREAT 56 #endif 57 58 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 59 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 60 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 61 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 62 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 51 63 52 64 !!---------------------------------------------------------------------- … … 56 68 !!---------------------------------------------------------------------- 57 69 CONTAINS 58 59 #else60 !!----------------------------------------------------------------------61 !! Default option shared memory computing62 !!----------------------------------------------------------------------63 !! routines setting the appropriate values64 !! on first and last row and column of the global domain65 !!----------------------------------------------------------------------66 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh67 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh68 !! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d69 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh70 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh71 !! lbc_bdy_lnk : set the lateral BDY boundary condition72 !!----------------------------------------------------------------------73 USE oce ! ocean dynamics and tracers74 USE dom_oce ! ocean space and time domain75 USE in_out_manager ! I/O manager76 USE lbcnfd ! north fold77 78 IMPLICIT NONE79 PRIVATE80 81 INTERFACE lbc_lnk82 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d83 END INTERFACE84 INTERFACE lbc_lnk_ptr85 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr86 END INTERFACE87 INTERFACE lbc_lnk_multi88 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi89 END INTERFACE90 !91 INTERFACE lbc_bdy_lnk92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d93 END INTERFACE94 !95 INTERFACE lbc_lnk_icb96 MODULE PROCEDURE lbc_lnk_2d_icb97 END INTERFACE98 99 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions100 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions101 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions102 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions103 104 !!----------------------------------------------------------------------105 !! NEMO/OCE 4.0 , NEMO Consortium (2018)106 !! $Id$107 !! Software governed by the CeCILL license (see ./LICENSE)108 !!----------------------------------------------------------------------109 CONTAINS110 111 !!======================================================================112 !! Default option 3D shared memory computing113 !!======================================================================114 !! routines setting land point, or east-west cyclic,115 !! or north-south cyclic, or north fold values116 !! on first and last row and column of the global domain117 !!----------------------------------------------------------------------118 119 !!----------------------------------------------------------------------120 !! *** routine lbc_lnk_(2,3,4)d ***121 !!122 !! * Argument : dummy argument use in lbc_lnk_... routines123 !! ptab : array or pointer of arrays on which the boundary condition is applied124 !! cd_nat : nature of array grid-points125 !! psgn : sign used across the north fold boundary126 !! kfld : optional, number of pt3d arrays127 !! cd_mpp : optional, fill the overlap area only128 !! pval : optional, background value (used at closed boundaries)129 !!----------------------------------------------------------------------130 !131 ! !== 2D array and array of 2D pointer ==!132 !133 # define DIM_2d134 # define ROUTINE_LNK lbc_lnk_2d135 # include "lbc_lnk_generic.h90"136 # undef ROUTINE_LNK137 # define MULTI138 # define ROUTINE_LNK lbc_lnk_2d_ptr139 # include "lbc_lnk_generic.h90"140 # undef ROUTINE_LNK141 # undef MULTI142 # undef DIM_2d143 !144 ! !== 3D array and array of 3D pointer ==!145 !146 # define DIM_3d147 # define ROUTINE_LNK lbc_lnk_3d148 # include "lbc_lnk_generic.h90"149 # undef ROUTINE_LNK150 # define MULTI151 # define ROUTINE_LNK lbc_lnk_3d_ptr152 # include "lbc_lnk_generic.h90"153 # undef ROUTINE_LNK154 # undef MULTI155 # undef DIM_3d156 !157 ! !== 4D array and array of 4D pointer ==!158 !159 # define DIM_4d160 # define ROUTINE_LNK lbc_lnk_4d161 # include "lbc_lnk_generic.h90"162 # undef ROUTINE_LNK163 # define MULTI164 # define ROUTINE_LNK lbc_lnk_4d_ptr165 # include "lbc_lnk_generic.h90"166 # undef ROUTINE_LNK167 # undef MULTI168 # undef DIM_4d169 170 !!======================================================================171 !! identical routines in both C1D and shared memory computing172 !!======================================================================173 174 !!----------------------------------------------------------------------175 !! *** routine lbc_bdy_lnk_(2,3,4)d ***176 !!177 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used178 !! to maintain the same interface with regards to the mpp case179 !!----------------------------------------------------------------------180 181 SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy )182 !!----------------------------------------------------------------------183 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine184 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt4d ! 3D array on which the lbc is applied185 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points186 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold187 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set188 !!----------------------------------------------------------------------189 CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn)190 END SUBROUTINE lbc_bdy_lnk_4d191 192 SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy )193 !!----------------------------------------------------------------------194 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine195 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied196 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points197 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold198 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set199 !!----------------------------------------------------------------------200 CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn)201 END SUBROUTINE lbc_bdy_lnk_3d202 203 204 SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy )205 !!----------------------------------------------------------------------206 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine207 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points209 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold210 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set211 !!----------------------------------------------------------------------212 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn)213 END SUBROUTINE lbc_bdy_lnk_2d214 215 216 !!gm This routine should be removed with an optional halos size added in argument of generic routines217 218 SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj )219 !!----------------------------------------------------------------------220 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine221 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied222 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points223 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold224 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp)225 !!----------------------------------------------------------------------226 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn )227 END SUBROUTINE lbc_lnk_2d_icb228 !!gm end229 230 #endif231 232 !!======================================================================233 !! identical routines in both distributed and shared memory computing234 !!======================================================================235 70 236 71 !!---------------------------------------------------------------------- … … 256 91 257 92 # define DIM_2d 93 # define ROUTINE_LOAD load_ptr_2d 258 94 # define ROUTINE_MULTI lbc_lnk_2d_multi 259 # define ROUTINE_LOAD load_ptr_2d260 95 # include "lbc_lnk_multi_generic.h90" 261 96 # undef ROUTINE_MULTI … … 263 98 # undef DIM_2d 264 99 265 266 100 # define DIM_3d 101 # define ROUTINE_LOAD load_ptr_3d 267 102 # define ROUTINE_MULTI lbc_lnk_3d_multi 268 # define ROUTINE_LOAD load_ptr_3d269 103 # include "lbc_lnk_multi_generic.h90" 270 104 # undef ROUTINE_MULTI … … 272 106 # undef DIM_3d 273 107 274 275 108 # define DIM_4d 109 # define ROUTINE_LOAD load_ptr_4d 276 110 # define ROUTINE_MULTI lbc_lnk_4d_multi 277 # define ROUTINE_LOAD load_ptr_4d278 111 # include "lbc_lnk_multi_generic.h90" 279 112 # undef ROUTINE_MULTI … … 281 114 # undef DIM_4d 282 115 116 !!---------------------------------------------------------------------- 117 !! *** routine mpp_lnk_(2,3,4)d *** 118 !! 119 !! * Argument : dummy argument use in mpp_lnk_... routines 120 !! ptab : array or pointer of arrays on which the boundary condition is applied 121 !! cd_nat : nature of array grid-points 122 !! psgn : sign used across the north fold boundary 123 !! kfld : optional, number of pt3d arrays 124 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 125 !! pfillval : optional, background value (used with jpfillcopy) 126 !!---------------------------------------------------------------------- 127 ! 128 ! !== 2D array and array of 2D pointer ==! 129 ! 130 # define DIM_2d 131 # define ROUTINE_LNK mpp_lnk_2d 132 # include "mpp_lnk_generic.h90" 133 # undef ROUTINE_LNK 134 # define MULTI 135 # define ROUTINE_LNK mpp_lnk_2d_ptr 136 # include "mpp_lnk_generic.h90" 137 # undef ROUTINE_LNK 138 # undef MULTI 139 # undef DIM_2d 140 ! 141 ! !== 3D array and array of 3D pointer ==! 142 ! 143 # define DIM_3d 144 # define ROUTINE_LNK mpp_lnk_3d 145 # include "mpp_lnk_generic.h90" 146 # undef ROUTINE_LNK 147 # define MULTI 148 # define ROUTINE_LNK mpp_lnk_3d_ptr 149 # include "mpp_lnk_generic.h90" 150 # undef ROUTINE_LNK 151 # undef MULTI 152 # undef DIM_3d 153 ! 154 ! !== 4D array and array of 4D pointer ==! 155 ! 156 # define DIM_4d 157 # define ROUTINE_LNK mpp_lnk_4d 158 # include "mpp_lnk_generic.h90" 159 # undef ROUTINE_LNK 160 # define MULTI 161 # define ROUTINE_LNK mpp_lnk_4d_ptr 162 # include "mpp_lnk_generic.h90" 163 # undef ROUTINE_LNK 164 # undef MULTI 165 # undef DIM_4d 166 167 !!---------------------------------------------------------------------- 168 !! *** routine mpp_nfd_(2,3,4)d *** 169 !! 170 !! * Argument : dummy argument use in mpp_nfd_... routines 171 !! ptab : array or pointer of arrays on which the boundary condition is applied 172 !! cd_nat : nature of array grid-points 173 !! psgn : sign used across the north fold boundary 174 !! kfld : optional, number of pt3d arrays 175 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 176 !! pfillval : optional, background value (used with jpfillcopy) 177 !!---------------------------------------------------------------------- 178 ! 179 ! !== 2D array and array of 2D pointer ==! 180 ! 181 # define DIM_2d 182 # define ROUTINE_NFD mpp_nfd_2d 183 # include "mpp_nfd_generic.h90" 184 # undef ROUTINE_NFD 185 # define MULTI 186 # define ROUTINE_NFD mpp_nfd_2d_ptr 187 # include "mpp_nfd_generic.h90" 188 # undef ROUTINE_NFD 189 # undef MULTI 190 # undef DIM_2d 191 ! 192 ! !== 3D array and array of 3D pointer ==! 193 ! 194 # define DIM_3d 195 # define ROUTINE_NFD mpp_nfd_3d 196 # include "mpp_nfd_generic.h90" 197 # undef ROUTINE_NFD 198 # define MULTI 199 # define ROUTINE_NFD mpp_nfd_3d_ptr 200 # include "mpp_nfd_generic.h90" 201 # undef ROUTINE_NFD 202 # undef MULTI 203 # undef DIM_3d 204 ! 205 ! !== 4D array and array of 4D pointer ==! 206 ! 207 # define DIM_4d 208 # define ROUTINE_NFD mpp_nfd_4d 209 # include "mpp_nfd_generic.h90" 210 # undef ROUTINE_NFD 211 # define MULTI 212 # define ROUTINE_NFD mpp_nfd_4d_ptr 213 # include "mpp_nfd_generic.h90" 214 # undef ROUTINE_NFD 215 # undef MULTI 216 # undef DIM_4d 217 218 283 219 !!====================================================================== 220 221 222 223 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 224 !!--------------------------------------------------------------------- 225 !! *** routine mpp_lbc_north_icb *** 226 !! 227 !! ** Purpose : Ensure proper north fold horizontal bondary condition 228 !! in mpp configuration in case of jpn1 > 1 and for 2d 229 !! array with outer extra halo 230 !! 231 !! ** Method : North fold condition and mpp with more than one proc 232 !! in i-direction require a specific treatment. We gather 233 !! the 4+kextj northern lines of the global domain on 1 234 !! processor and apply lbc north-fold on this sub array. 235 !! Then we scatter the north fold array back to the processors. 236 !! This routine accounts for an extra halo with icebergs 237 !! and assumes ghost rows and columns have been suppressed. 238 !! 239 !!---------------------------------------------------------------------- 240 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 241 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 242 ! ! = T , U , V , F or W -points 243 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 244 !! ! north fold, = 1. otherwise 245 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 246 ! 247 INTEGER :: ji, jj, jr 248 INTEGER :: ierr, itaille, ildi, ilei, iilb 249 INTEGER :: ipj, ij, iproc 250 ! 251 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 252 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 253 !!---------------------------------------------------------------------- 254 #if defined key_mpp_mpi 255 ! 256 ipj=4 257 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 258 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 259 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 260 ! 261 ztab_e(:,:) = 0._wp 262 znorthloc_e(:,:) = 0._wp 263 ! 264 ij = 1 - kextj 265 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 266 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 267 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 268 ij = ij + 1 269 END DO 270 ! 271 itaille = jpimax * ( ipj + 2*kextj ) 272 ! 273 IF( ln_timing ) CALL tic_tac(.TRUE.) 274 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 275 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 276 & ncomm_north, ierr ) 277 ! 278 IF( ln_timing ) CALL tic_tac(.FALSE.) 279 ! 280 DO jr = 1, ndim_rank_north ! recover the global north array 281 iproc = nrank_north(jr) + 1 282 ildi = nldit (iproc) 283 ilei = nleit (iproc) 284 iilb = nimppt(iproc) 285 DO jj = 1-kextj, ipj+kextj 286 DO ji = ildi, ilei 287 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 288 END DO 289 END DO 290 END DO 291 292 ! 2. North-Fold boundary conditions 293 ! ---------------------------------- 294 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 295 296 ij = 1 - kextj 297 !! Scatter back to pt2d 298 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 299 DO ji= 1, jpi 300 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 301 END DO 302 ij = ij +1 303 END DO 304 ! 305 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 306 ! 307 #endif 308 END SUBROUTINE mpp_lbc_north_icb 309 310 311 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 312 !!---------------------------------------------------------------------- 313 !! *** routine mpp_lnk_2d_icb *** 314 !! 315 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 316 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 317 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 318 !! 319 !! ** Method : Use mppsend and mpprecv function for passing mask 320 !! between processors following neighboring subdomains. 321 !! domain parameters 322 !! jpi : first dimension of the local subdomain 323 !! jpj : second dimension of the local subdomain 324 !! kexti : number of columns for extra outer halo 325 !! kextj : number of rows for extra outer halo 326 !! nbondi : mark for "east-west local boundary" 327 !! nbondj : mark for "north-south local boundary" 328 !! noea : number for local neighboring processors 329 !! nowe : number for local neighboring processors 330 !! noso : number for local neighboring processors 331 !! nono : number for local neighboring processors 332 !!---------------------------------------------------------------------- 333 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 334 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 335 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 336 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 337 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 338 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 339 ! 340 INTEGER :: jl ! dummy loop indices 341 INTEGER :: imigr, iihom, ijhom ! local integers 342 INTEGER :: ipreci, iprecj ! - - 343 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 344 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 345 !! 346 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 347 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 348 !!---------------------------------------------------------------------- 349 350 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 351 iprecj = nn_hls + kextj 352 353 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 354 355 ! 1. standard boundary treatment 356 ! ------------------------------ 357 ! Order matters Here !!!! 358 ! 359 ! ! East-West boundaries 360 ! !* Cyclic east-west 361 IF( l_Iperio ) THEN 362 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 363 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 364 ! 365 ELSE !* closed 366 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 367 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 368 ENDIF 369 ! ! North-South boundaries 370 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 371 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 372 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 373 ELSE !* closed 374 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 375 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 376 ENDIF 377 ! 378 379 ! north fold treatment 380 ! ----------------------- 381 IF( npolj /= 0 ) THEN 382 ! 383 SELECT CASE ( jpni ) 384 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 385 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 386 END SELECT 387 ! 388 ENDIF 389 390 ! 2. East and west directions exchange 391 ! ------------------------------------ 392 ! we play with the neigbours AND the row number because of the periodicity 393 ! 394 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 395 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 396 iihom = jpi-nreci-kexti 397 DO jl = 1, ipreci 398 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 399 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 400 END DO 401 END SELECT 402 ! 403 ! ! Migrations 404 imigr = ipreci * ( jpj + 2*kextj ) 405 ! 406 IF( ln_timing ) CALL tic_tac(.TRUE.) 407 ! 408 SELECT CASE ( nbondi ) 409 CASE ( -1 ) 410 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 411 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 412 CALL mpi_wait(ml_req1,ml_stat,ml_err) 413 CASE ( 0 ) 414 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 415 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 416 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 417 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 418 CALL mpi_wait(ml_req1,ml_stat,ml_err) 419 CALL mpi_wait(ml_req2,ml_stat,ml_err) 420 CASE ( 1 ) 421 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 422 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 423 CALL mpi_wait(ml_req1,ml_stat,ml_err) 424 END SELECT 425 ! 426 IF( ln_timing ) CALL tic_tac(.FALSE.) 427 ! 428 ! ! Write Dirichlet lateral conditions 429 iihom = jpi - nn_hls 430 ! 431 SELECT CASE ( nbondi ) 432 CASE ( -1 ) 433 DO jl = 1, ipreci 434 pt2d(iihom+jl,:) = r2dew(:,jl,2) 435 END DO 436 CASE ( 0 ) 437 DO jl = 1, ipreci 438 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 439 pt2d(iihom+jl,:) = r2dew(:,jl,2) 440 END DO 441 CASE ( 1 ) 442 DO jl = 1, ipreci 443 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 444 END DO 445 END SELECT 446 447 448 ! 3. North and south directions 449 ! ----------------------------- 450 ! always closed : we play only with the neigbours 451 ! 452 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 453 ijhom = jpj-nrecj-kextj 454 DO jl = 1, iprecj 455 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 456 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 457 END DO 458 ENDIF 459 ! 460 ! ! Migrations 461 imigr = iprecj * ( jpi + 2*kexti ) 462 ! 463 IF( ln_timing ) CALL tic_tac(.TRUE.) 464 ! 465 SELECT CASE ( nbondj ) 466 CASE ( -1 ) 467 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 468 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 469 CALL mpi_wait(ml_req1,ml_stat,ml_err) 470 CASE ( 0 ) 471 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 472 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 473 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 474 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 475 CALL mpi_wait(ml_req1,ml_stat,ml_err) 476 CALL mpi_wait(ml_req2,ml_stat,ml_err) 477 CASE ( 1 ) 478 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 479 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 480 CALL mpi_wait(ml_req1,ml_stat,ml_err) 481 END SELECT 482 ! 483 IF( ln_timing ) CALL tic_tac(.FALSE.) 484 ! 485 ! ! Write Dirichlet lateral conditions 486 ijhom = jpj - nn_hls 487 ! 488 SELECT CASE ( nbondj ) 489 CASE ( -1 ) 490 DO jl = 1, iprecj 491 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 492 END DO 493 CASE ( 0 ) 494 DO jl = 1, iprecj 495 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 496 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 497 END DO 498 CASE ( 1 ) 499 DO jl = 1, iprecj 500 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 501 END DO 502 END SELECT 503 ! 504 END SUBROUTINE mpp_lnk_2d_icb 505 284 506 END MODULE lbclnk 285 507 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lbcnfd.F90
r10425 r12143 20 20 USE dom_oce ! ocean space and time domain 21 21 USE in_out_manager ! I/O manager 22 USE lib_mpp ! MPP library 22 23 23 24 IMPLICIT NONE -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/lib_mpp.F90
r10982 r12143 32 32 !! ctl_opn : Open file and check if required file is available. 33 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 34 !! get_unit : give the index of an unused logical unit 35 !!---------------------------------------------------------------------- 36 #if defined key_mpp_mpi 37 !!---------------------------------------------------------------------- 38 !! 'key_mpp_mpi' MPI massively parallel processing library 39 !!---------------------------------------------------------------------- 40 !! lib_mpp_alloc : allocate mpp arrays 41 !! mynode : indentify the processor unit 34 !!---------------------------------------------------------------------- 35 !!---------------------------------------------------------------------- 36 !! mpp_start : get local communicator its size and rank 42 37 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 38 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 52 !!---------------------------------------------------------------------- 58 53 USE dom_oce ! ocean space and time domain 59 USE lbcnfd ! north fold treatment60 54 USE in_out_manager ! I/O manager 61 55 62 56 IMPLICIT NONE 63 57 PRIVATE 64 65 INTERFACE mpp_nfd66 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d67 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr68 END INTERFACE69 70 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk71 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d72 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr73 58 ! 74 !!gm this should be useless 75 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 76 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 77 !!gm end 78 ! 79 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 80 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 59 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam 60 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 81 61 PUBLIC mpp_ini_north 82 PUBLIC mpp_lnk_2d_icb83 PUBLIC mpp_lbc_north_icb84 62 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 63 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 87 65 PUBLIC mpp_ini_znl 88 66 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 89 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 67 PUBLIC mpp_report 68 PUBLIC tic_tac 69 #if ! defined key_mpp_mpi 70 PUBLIC MPI_Wtime 71 #endif 90 72 91 73 !! * Interfaces … … 113 95 !! MPI variable definition !! 114 96 !! ========================= !! 97 #if defined key_mpp_mpi 115 98 !$AGRIF_DO_NOT_TREAT 116 99 INCLUDE 'mpif.h' 117 100 !$AGRIF_END_DO_NOT_TREAT 118 119 101 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 102 #else 103 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 104 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 105 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 106 #endif 120 107 121 108 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) … … 145 132 INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm 146 133 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 147 148 ! Type of send : standard, buffered, immediate149 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)150 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')151 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend152 134 153 135 ! Communications summary report … … 187 169 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 188 170 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 189 171 190 172 !!---------------------------------------------------------------------- 191 173 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 195 177 CONTAINS 196 178 197 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 198 !!---------------------------------------------------------------------- 199 !! *** routine mynode *** 200 !! 201 !! ** Purpose : Find processor unit 202 !!---------------------------------------------------------------------- 203 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 204 CHARACTER(len=*) , INTENT(in ) :: ldname ! 205 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 206 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 207 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 208 INTEGER , INTENT(inout) :: kstop ! stop indicator 179 SUBROUTINE mpp_start( localComm ) 180 !!---------------------------------------------------------------------- 181 !! *** routine mpp_start *** 182 !! 183 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 184 !!---------------------------------------------------------------------- 209 185 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 210 186 ! 211 INTEGER :: mynode, ierr, code, ji, ii, ios 212 LOGICAL :: mpi_was_called 213 ! 214 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 215 !!---------------------------------------------------------------------- 216 ! 217 ii = 1 218 WRITE(ldtxt(ii),*) ; ii = ii + 1 219 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 220 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 221 ! 222 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 223 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 224 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 225 ! 226 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 227 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 229 ! 230 ! ! control print 231 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 232 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 233 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 234 ! 235 IF( jpni < 1 .OR. jpnj < 1 ) THEN 236 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 237 ELSE 238 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 240 ENDIF 241 242 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 243 244 CALL mpi_initialized ( mpi_was_called, code ) 245 IF( code /= MPI_SUCCESS ) THEN 246 DO ji = 1, SIZE(ldtxt) 247 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 248 END DO 249 WRITE(*, cform_err) 250 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 251 CALL mpi_abort( mpi_comm_world, code, ierr ) 252 ENDIF 253 254 IF( mpi_was_called ) THEN 255 ! 256 SELECT CASE ( cn_mpi_send ) 257 CASE ( 'S' ) ! Standard mpi send (blocking) 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 259 CASE ( 'B' ) ! Buffer mpi send (blocking) 260 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 261 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 262 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 263 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 264 l_isend = .TRUE. 265 CASE DEFAULT 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 268 kstop = kstop + 1 269 END SELECT 270 ! 271 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 272 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 273 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 274 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 275 kstop = kstop + 1 276 ELSE 277 SELECT CASE ( cn_mpi_send ) 278 CASE ( 'S' ) ! Standard mpi send (blocking) 279 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 280 CALL mpi_init( ierr ) 281 CASE ( 'B' ) ! Buffer mpi send (blocking) 282 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 283 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 284 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 285 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 286 l_isend = .TRUE. 287 CALL mpi_init( ierr ) 288 CASE DEFAULT 289 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 290 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 291 kstop = kstop + 1 292 END SELECT 293 ! 294 ENDIF 295 187 INTEGER :: ierr 188 LOGICAL :: llmpi_init 189 !!---------------------------------------------------------------------- 190 #if defined key_mpp_mpi 191 ! 192 CALL mpi_initialized ( llmpi_init, ierr ) 193 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 194 195 IF( .NOT. llmpi_init ) THEN 196 IF( PRESENT(localComm) ) THEN 197 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 198 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 199 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 200 ENDIF 201 CALL mpi_init( ierr ) 202 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 203 ENDIF 204 296 205 IF( PRESENT(localComm) ) THEN 297 206 IF( Agrif_Root() ) THEN … … 299 208 ENDIF 300 209 ELSE 301 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 302 IF( code /= MPI_SUCCESS ) THEN 303 DO ji = 1, SIZE(ldtxt) 304 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 305 END DO 306 WRITE(*, cform_err) 307 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 308 CALL mpi_abort( mpi_comm_world, code, ierr ) 309 ENDIF 310 ENDIF 311 312 #if defined key_agrif 210 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 211 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 212 ENDIF 213 214 # if defined key_agrif 313 215 IF( Agrif_Root() ) THEN 314 216 CALL Agrif_MPI_Init(mpi_comm_oce) … … 316 218 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 317 219 ENDIF 318 # endif220 # endif 319 221 320 222 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 321 223 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 322 mynode = mpprank323 324 IF( mynode == 0 ) THEN325 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )326 WRITE(kumond, nammpp)327 ENDIF328 224 ! 329 225 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 330 226 ! 331 END FUNCTION mynode 332 333 !!---------------------------------------------------------------------- 334 !! *** routine mpp_lnk_(2,3,4)d *** 335 !! 336 !! * Argument : dummy argument use in mpp_lnk_... routines 337 !! ptab : array or pointer of arrays on which the boundary condition is applied 338 !! cd_nat : nature of array grid-points 339 !! psgn : sign used across the north fold boundary 340 !! kfld : optional, number of pt3d arrays 341 !! cd_mpp : optional, fill the overlap area only 342 !! pval : optional, background value (used at closed boundaries) 343 !!---------------------------------------------------------------------- 344 ! 345 ! !== 2D array and array of 2D pointer ==! 346 ! 347 # define DIM_2d 348 # define ROUTINE_LNK mpp_lnk_2d 349 # include "mpp_lnk_generic.h90" 350 # undef ROUTINE_LNK 351 # define MULTI 352 # define ROUTINE_LNK mpp_lnk_2d_ptr 353 # include "mpp_lnk_generic.h90" 354 # undef ROUTINE_LNK 355 # undef MULTI 356 # undef DIM_2d 357 ! 358 ! !== 3D array and array of 3D pointer ==! 359 ! 360 # define DIM_3d 361 # define ROUTINE_LNK mpp_lnk_3d 362 # include "mpp_lnk_generic.h90" 363 # undef ROUTINE_LNK 364 # define MULTI 365 # define ROUTINE_LNK mpp_lnk_3d_ptr 366 # include "mpp_lnk_generic.h90" 367 # undef ROUTINE_LNK 368 # undef MULTI 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_LNK mpp_lnk_4d 375 # include "mpp_lnk_generic.h90" 376 # undef ROUTINE_LNK 377 # define MULTI 378 # define ROUTINE_LNK mpp_lnk_4d_ptr 379 # include "mpp_lnk_generic.h90" 380 # undef ROUTINE_LNK 381 # undef MULTI 382 # undef DIM_4d 383 384 !!---------------------------------------------------------------------- 385 !! *** routine mpp_nfd_(2,3,4)d *** 386 !! 387 !! * Argument : dummy argument use in mpp_nfd_... routines 388 !! ptab : array or pointer of arrays on which the boundary condition is applied 389 !! cd_nat : nature of array grid-points 390 !! psgn : sign used across the north fold boundary 391 !! kfld : optional, number of pt3d arrays 392 !! cd_mpp : optional, fill the overlap area only 393 !! pval : optional, background value (used at closed boundaries) 394 !!---------------------------------------------------------------------- 395 ! 396 ! !== 2D array and array of 2D pointer ==! 397 ! 398 # define DIM_2d 399 # define ROUTINE_NFD mpp_nfd_2d 400 # include "mpp_nfd_generic.h90" 401 # undef ROUTINE_NFD 402 # define MULTI 403 # define ROUTINE_NFD mpp_nfd_2d_ptr 404 # include "mpp_nfd_generic.h90" 405 # undef ROUTINE_NFD 406 # undef MULTI 407 # undef DIM_2d 408 ! 409 ! !== 3D array and array of 3D pointer ==! 410 ! 411 # define DIM_3d 412 # define ROUTINE_NFD mpp_nfd_3d 413 # include "mpp_nfd_generic.h90" 414 # undef ROUTINE_NFD 415 # define MULTI 416 # define ROUTINE_NFD mpp_nfd_3d_ptr 417 # include "mpp_nfd_generic.h90" 418 # undef ROUTINE_NFD 419 # undef MULTI 420 # undef DIM_3d 421 ! 422 ! !== 4D array and array of 4D pointer ==! 423 ! 424 # define DIM_4d 425 # define ROUTINE_NFD mpp_nfd_4d 426 # include "mpp_nfd_generic.h90" 427 # undef ROUTINE_NFD 428 # define MULTI 429 # define ROUTINE_NFD mpp_nfd_4d_ptr 430 # include "mpp_nfd_generic.h90" 431 # undef ROUTINE_NFD 432 # undef MULTI 433 # undef DIM_4d 434 435 436 !!---------------------------------------------------------------------- 437 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 438 !! 439 !! * Argument : dummy argument use in mpp_lnk_... routines 440 !! ptab : array or pointer of arrays on which the boundary condition is applied 441 !! cd_nat : nature of array grid-points 442 !! psgn : sign used across the north fold boundary 443 !! kb_bdy : BDY boundary set 444 !! kfld : optional, number of pt3d arrays 445 !!---------------------------------------------------------------------- 446 ! 447 ! !== 2D array and array of 2D pointer ==! 448 ! 449 # define DIM_2d 450 # define ROUTINE_BDY mpp_lnk_bdy_2d 451 # include "mpp_bdy_generic.h90" 452 # undef ROUTINE_BDY 453 # undef DIM_2d 454 ! 455 ! !== 3D array and array of 3D pointer ==! 456 ! 457 # define DIM_3d 458 # define ROUTINE_BDY mpp_lnk_bdy_3d 459 # include "mpp_bdy_generic.h90" 460 # undef ROUTINE_BDY 461 # undef DIM_3d 462 ! 463 ! !== 4D array and array of 4D pointer ==! 464 ! 465 # define DIM_4d 466 # define ROUTINE_BDY mpp_lnk_bdy_4d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # undef DIM_4d 470 471 !!---------------------------------------------------------------------- 472 !! 473 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 474 475 476 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 477 478 479 !!---------------------------------------------------------------------- 480 227 #else 228 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 229 mppsize = 1 230 mpprank = 0 231 #endif 232 END SUBROUTINE mpp_start 481 233 482 234 … … 497 249 !!---------------------------------------------------------------------- 498 250 ! 499 SELECT CASE ( cn_mpi_send ) 500 CASE ( 'S' ) ! Standard mpi send (blocking) 501 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 502 CASE ( 'B' ) ! Buffer mpi send (blocking) 503 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 504 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 505 ! be carefull, one more argument here : the mpi request identifier.. 506 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 507 END SELECT 251 #if defined key_mpp_mpi 252 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 253 #endif 508 254 ! 509 255 END SUBROUTINE mppsend … … 527 273 !!---------------------------------------------------------------------- 528 274 ! 275 #if defined key_mpp_mpi 529 276 ! If a specific process number has been passed to the receive call, 530 277 ! use that one. Default is to use mpi_any_source … … 533 280 ! 534 281 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 282 #endif 535 283 ! 536 284 END SUBROUTINE mpprecv … … 553 301 ! 554 302 itaille = jpi * jpj 303 #if defined key_mpp_mpi 555 304 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 556 305 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 306 #else 307 pio(:,:,1) = ptab(:,:) 308 #endif 557 309 ! 558 310 END SUBROUTINE mppgather … … 576 328 itaille = jpi * jpj 577 329 ! 330 #if defined key_mpp_mpi 578 331 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 579 332 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 333 #else 334 ptab(:,:) = pio(:,:,1) 335 #endif 580 336 ! 581 337 END SUBROUTINE mppscatter … … 601 357 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 602 358 !!---------------------------------------------------------------------- 359 #if defined key_mpp_mpi 603 360 ilocalcomm = mpi_comm_oce 604 361 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 639 396 640 397 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 641 # if defined key_mpi2398 # if defined key_mpi2 642 399 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 643 400 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 644 401 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 402 # else 403 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 404 # endif 645 405 #else 646 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)406 pout(:) = REAL(y_in(:), wp) 647 407 #endif 648 408 … … 668 428 INTEGER :: ierr, ilocalcomm 669 429 !!---------------------------------------------------------------------- 430 #if defined key_mpp_mpi 670 431 ilocalcomm = mpi_comm_oce 671 432 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 702 463 703 464 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 704 # if defined key_mpi2465 # if defined key_mpi2 705 466 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 706 467 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 707 468 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 469 # else 470 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 471 # endif 708 472 #else 709 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)473 pout(:) = p_in(:) 710 474 #endif 711 475 … … 723 487 INTEGER :: ierr 724 488 !!---------------------------------------------------------------------- 489 #if defined key_mpp_mpi 725 490 IF( ndelayid(kid) /= -2 ) THEN 726 491 #if ! defined key_mpi2 … … 732 497 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 733 498 ENDIF 499 #endif 734 500 END SUBROUTINE mpp_delay_rcv 735 501 … … 890 656 !!----------------------------------------------------------------------- 891 657 ! 658 #if defined key_mpp_mpi 892 659 CALL mpi_barrier( mpi_comm_oce, ierror ) 660 #endif 893 661 ! 894 662 END SUBROUTINE mppsync 895 663 896 664 897 SUBROUTINE mppstop( ld final, ld_force_abort )665 SUBROUTINE mppstop( ld_abort ) 898 666 !!---------------------------------------------------------------------- 899 667 !! *** routine mppstop *** … … 902 670 !! 903 671 !!---------------------------------------------------------------------- 904 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 905 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 906 LOGICAL :: llfinal, ll_force_abort 672 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 673 LOGICAL :: ll_abort 907 674 INTEGER :: info 908 675 !!---------------------------------------------------------------------- 909 llfinal = .FALSE. 910 IF( PRESENT(ldfinal) ) llfinal = ldfinal 911 ll_force_abort = .FALSE. 912 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 913 ! 914 IF(ll_force_abort) THEN 676 ll_abort = .FALSE. 677 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 678 ! 679 #if defined key_mpp_mpi 680 IF(ll_abort) THEN 915 681 CALL mpi_abort( MPI_COMM_WORLD ) 916 682 ELSE … … 918 684 CALL mpi_finalize( info ) 919 685 ENDIF 920 IF( .NOT. llfinal ) STOP 123 686 #endif 687 IF( ll_abort ) STOP 123 921 688 ! 922 689 END SUBROUTINE mppstop … … 930 697 !!---------------------------------------------------------------------- 931 698 ! 699 #if defined key_mpp_mpi 932 700 CALL MPI_COMM_FREE(kcom, ierr) 701 #endif 933 702 ! 934 703 END SUBROUTINE mpp_comm_free … … 960 729 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 961 730 !!---------------------------------------------------------------------- 731 #if defined key_mpp_mpi 962 732 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 963 733 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 965 735 ! 966 736 ALLOCATE( kwork(jpnij), STAT=ierr ) 967 IF( ierr /= 0 ) THEN 968 WRITE(kumout, cform_err) 969 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 970 CALL mppstop 971 ENDIF 737 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 972 738 973 739 IF( jpnj == 1 ) THEN … … 1031 797 1032 798 DEALLOCATE(kwork) 799 #endif 1033 800 1034 801 END SUBROUTINE mpp_ini_znl … … 1062 829 !!---------------------------------------------------------------------- 1063 830 ! 831 #if defined key_mpp_mpi 1064 832 njmppmax = MAXVAL( njmppt ) 1065 833 ! … … 1093 861 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1094 862 ! 863 #endif 1095 864 END SUBROUTINE mpp_ini_north 1096 1097 1098 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1099 !!---------------------------------------------------------------------1100 !! *** routine mpp_init.opa ***1101 !!1102 !! ** Purpose :: export and attach a MPI buffer for bsend1103 !!1104 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1105 !! but classical mpi_init1106 !!1107 !! History :: 01/11 :: IDRIS initial version for IBM only1108 !! 08/04 :: R. Benshila, generalisation1109 !!---------------------------------------------------------------------1110 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1111 INTEGER , INTENT(inout) :: ksft1112 INTEGER , INTENT( out) :: code1113 INTEGER :: ierr, ji1114 LOGICAL :: mpi_was_called1115 !!---------------------------------------------------------------------1116 !1117 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1118 IF ( code /= MPI_SUCCESS ) THEN1119 DO ji = 1, SIZE(ldtxt)1120 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1121 END DO1122 WRITE(*, cform_err)1123 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1124 CALL mpi_abort( mpi_comm_world, code, ierr )1125 ENDIF1126 !1127 IF( .NOT. mpi_was_called ) THEN1128 CALL mpi_init( code )1129 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1130 IF ( code /= MPI_SUCCESS ) THEN1131 DO ji = 1, SIZE(ldtxt)1132 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1133 END DO1134 WRITE(*, cform_err)1135 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1136 CALL mpi_abort( mpi_comm_world, code, ierr )1137 ENDIF1138 ENDIF1139 !1140 IF( nn_buffer > 0 ) THEN1141 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11142 ! Buffer allocation and attachment1143 ALLOCATE( tampon(nn_buffer), stat = ierr )1144 IF( ierr /= 0 ) THEN1145 DO ji = 1, SIZE(ldtxt)1146 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1147 END DO1148 WRITE(*, cform_err)1149 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1150 CALL mpi_abort( mpi_comm_world, code, ierr )1151 END IF1152 CALL mpi_buffer_attach( tampon, nn_buffer, code )1153 ENDIF1154 !1155 END SUBROUTINE mpi_init_oce1156 865 1157 866 … … 1187 896 1188 897 1189 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1190 !!---------------------------------------------------------------------1191 !! *** routine mpp_lbc_north_icb ***1192 !!1193 !! ** Purpose : Ensure proper north fold horizontal bondary condition1194 !! in mpp configuration in case of jpn1 > 1 and for 2d1195 !! array with outer extra halo1196 !!1197 !! ** Method : North fold condition and mpp with more than one proc1198 !! in i-direction require a specific treatment. We gather1199 !! the 4+kextj northern lines of the global domain on 11200 !! processor and apply lbc north-fold on this sub array.1201 !! Then we scatter the north fold array back to the processors.1202 !! This routine accounts for an extra halo with icebergs1203 !! and assumes ghost rows and columns have been suppressed.1204 !!1205 !!----------------------------------------------------------------------1206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1208 ! ! = T , U , V , F or W -points1209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1210 !! ! north fold, = 1. otherwise1211 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1212 !1213 INTEGER :: ji, jj, jr1214 INTEGER :: ierr, itaille, ildi, ilei, iilb1215 INTEGER :: ipj, ij, iproc1216 !1217 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1218 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1219 !!----------------------------------------------------------------------1220 !1221 ipj=41222 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1223 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1224 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1225 !1226 ztab_e(:,:) = 0._wp1227 znorthloc_e(:,:) = 0._wp1228 !1229 ij = 1 - kextj1230 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1231 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1232 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1233 ij = ij + 11234 END DO1235 !1236 itaille = jpimax * ( ipj + 2*kextj )1237 !1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1240 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1241 & ncomm_north, ierr )1242 !1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 !1245 DO jr = 1, ndim_rank_north ! recover the global north array1246 iproc = nrank_north(jr) + 11247 ildi = nldit (iproc)1248 ilei = nleit (iproc)1249 iilb = nimppt(iproc)1250 DO jj = 1-kextj, ipj+kextj1251 DO ji = ildi, ilei1252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1253 END DO1254 END DO1255 END DO1256 1257 ! 2. North-Fold boundary conditions1258 ! ----------------------------------1259 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1260 1261 ij = 1 - kextj1262 !! Scatter back to pt2d1263 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1264 DO ji= 1, jpi1265 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1266 END DO1267 ij = ij +11268 END DO1269 !1270 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1271 !1272 END SUBROUTINE mpp_lbc_north_icb1273 1274 1275 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1276 !!----------------------------------------------------------------------1277 !! *** routine mpp_lnk_2d_icb ***1278 !!1279 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1280 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1281 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1282 !!1283 !! ** Method : Use mppsend and mpprecv function for passing mask1284 !! between processors following neighboring subdomains.1285 !! domain parameters1286 !! jpi : first dimension of the local subdomain1287 !! jpj : second dimension of the local subdomain1288 !! kexti : number of columns for extra outer halo1289 !! kextj : number of rows for extra outer halo1290 !! nbondi : mark for "east-west local boundary"1291 !! nbondj : mark for "north-south local boundary"1292 !! noea : number for local neighboring processors1293 !! nowe : number for local neighboring processors1294 !! noso : number for local neighboring processors1295 !! nono : number for local neighboring processors1296 !!----------------------------------------------------------------------1297 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1298 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1300 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1301 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1302 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1303 !1304 INTEGER :: jl ! dummy loop indices1305 INTEGER :: imigr, iihom, ijhom ! local integers1306 INTEGER :: ipreci, iprecj ! - -1307 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1308 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1309 !!1310 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1311 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1312 !!----------------------------------------------------------------------1313 1314 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1315 iprecj = nn_hls + kextj1316 1317 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1318 1319 ! 1. standard boundary treatment1320 ! ------------------------------1321 ! Order matters Here !!!!1322 !1323 ! ! East-West boundaries1324 ! !* Cyclic east-west1325 IF( l_Iperio ) THEN1326 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1327 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1328 !1329 ELSE !* closed1330 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1331 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1332 ENDIF1333 ! ! North-South boundaries1334 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1335 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1336 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1337 ELSE !* closed1338 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1339 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1340 ENDIF1341 !1342 1343 ! north fold treatment1344 ! -----------------------1345 IF( npolj /= 0 ) THEN1346 !1347 SELECT CASE ( jpni )1348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1350 END SELECT1351 !1352 ENDIF1353 1354 ! 2. East and west directions exchange1355 ! ------------------------------------1356 ! we play with the neigbours AND the row number because of the periodicity1357 !1358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1360 iihom = jpi-nreci-kexti1361 DO jl = 1, ipreci1362 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1363 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1364 END DO1365 END SELECT1366 !1367 ! ! Migrations1368 imigr = ipreci * ( jpj + 2*kextj )1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 !1372 SELECT CASE ( nbondi )1373 CASE ( -1 )1374 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1375 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1376 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1377 CASE ( 0 )1378 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1379 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1380 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1381 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1382 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1383 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1384 CASE ( 1 )1385 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1386 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1387 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1388 END SELECT1389 !1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 ! ! Write Dirichlet lateral conditions1393 iihom = jpi - nn_hls1394 !1395 SELECT CASE ( nbondi )1396 CASE ( -1 )1397 DO jl = 1, ipreci1398 pt2d(iihom+jl,:) = r2dew(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, ipreci1402 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1403 pt2d(iihom+jl,:) = r2dew(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, ipreci1407 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1408 END DO1409 END SELECT1410 1411 1412 ! 3. North and south directions1413 ! -----------------------------1414 ! always closed : we play only with the neigbours1415 !1416 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1417 ijhom = jpj-nrecj-kextj1418 DO jl = 1, iprecj1419 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1420 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1421 END DO1422 ENDIF1423 !1424 ! ! Migrations1425 imigr = iprecj * ( jpi + 2*kexti )1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 !1429 SELECT CASE ( nbondj )1430 CASE ( -1 )1431 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1432 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1434 CASE ( 0 )1435 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1436 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1437 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1438 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1439 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1440 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1441 CASE ( 1 )1442 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1443 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1444 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1445 END SELECT1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 !1449 ! ! Write Dirichlet lateral conditions1450 ijhom = jpj - nn_hls1451 !1452 SELECT CASE ( nbondj )1453 CASE ( -1 )1454 DO jl = 1, iprecj1455 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1456 END DO1457 CASE ( 0 )1458 DO jl = 1, iprecj1459 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1460 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1461 END DO1462 CASE ( 1 )1463 DO jl = 1, iprecj1464 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1465 END DO1466 END SELECT1467 !1468 END SUBROUTINE mpp_lnk_2d_icb1469 1470 1471 898 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1472 899 !!---------------------------------------------------------------------- … … 1484 911 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 1485 912 !!---------------------------------------------------------------------- 913 #if defined key_mpp_mpi 1486 914 ! 1487 915 ll_lbc = .FALSE. … … 1594 1022 DEALLOCATE(crname_lbc) 1595 1023 ENDIF 1024 #endif 1596 1025 END SUBROUTINE mpp_report 1597 1026 … … 1604 1033 REAL(wp), SAVE :: tic_ct = 0._wp 1605 1034 INTEGER :: ii 1035 #if defined key_mpp_mpi 1606 1036 1607 1037 IF( ncom_stp <= nit000 ) RETURN … … 1619 1049 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1620 1050 ENDIF 1051 #endif 1621 1052 1622 1053 END SUBROUTINE tic_tac 1623 1054 1055 #if ! defined key_mpp_mpi 1056 SUBROUTINE mpi_wait(request, status, ierror) 1057 INTEGER , INTENT(in ) :: request 1058 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1059 INTEGER , INTENT( out) :: ierror 1060 END SUBROUTINE mpi_wait 1061 1624 1062 1625 #else 1626 !!---------------------------------------------------------------------- 1627 !! Default case: Dummy module share memory computing 1628 !!---------------------------------------------------------------------- 1629 USE in_out_manager 1630 1631 INTERFACE mpp_sum 1632 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1633 END INTERFACE 1634 INTERFACE mpp_max 1635 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1636 END INTERFACE 1637 INTERFACE mpp_min 1638 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1639 END INTERFACE 1640 INTERFACE mpp_minloc 1641 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1642 END INTERFACE 1643 INTERFACE mpp_maxloc 1644 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1645 END INTERFACE 1646 1647 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1648 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1649 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1650 1651 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1652 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1653 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1654 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1655 TYPE :: DELAYARR 1656 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1657 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1658 END TYPE DELAYARR 1659 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1660 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1661 !!---------------------------------------------------------------------- 1662 CONTAINS 1663 1664 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1665 INTEGER, INTENT(in) :: kumout 1666 lib_mpp_alloc = 0 1667 END FUNCTION lib_mpp_alloc 1668 1669 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1670 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1671 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1672 CHARACTER(len=*) :: ldname 1673 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1674 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1675 function_value = 0 1676 IF( .FALSE. ) ldtxt(:) = 'never done' 1677 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1678 END FUNCTION mynode 1679 1680 SUBROUTINE mppsync ! Dummy routine 1681 END SUBROUTINE mppsync 1682 1683 !!---------------------------------------------------------------------- 1684 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1685 !! 1686 !!---------------------------------------------------------------------- 1687 !! 1688 # define OPERATION_MAX 1689 # define INTEGER_TYPE 1690 # define DIM_0d 1691 # define ROUTINE_ALLREDUCE mppmax_int 1692 # include "mpp_allreduce_generic.h90" 1693 # undef ROUTINE_ALLREDUCE 1694 # undef DIM_0d 1695 # define DIM_1d 1696 # define ROUTINE_ALLREDUCE mppmax_a_int 1697 # include "mpp_allreduce_generic.h90" 1698 # undef ROUTINE_ALLREDUCE 1699 # undef DIM_1d 1700 # undef INTEGER_TYPE 1701 ! 1702 # define REAL_TYPE 1703 # define DIM_0d 1704 # define ROUTINE_ALLREDUCE mppmax_real 1705 # include "mpp_allreduce_generic.h90" 1706 # undef ROUTINE_ALLREDUCE 1707 # undef DIM_0d 1708 # define DIM_1d 1709 # define ROUTINE_ALLREDUCE mppmax_a_real 1710 # include "mpp_allreduce_generic.h90" 1711 # undef ROUTINE_ALLREDUCE 1712 # undef DIM_1d 1713 # undef REAL_TYPE 1714 # undef OPERATION_MAX 1715 !!---------------------------------------------------------------------- 1716 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1717 !! 1718 !!---------------------------------------------------------------------- 1719 !! 1720 # define OPERATION_MIN 1721 # define INTEGER_TYPE 1722 # define DIM_0d 1723 # define ROUTINE_ALLREDUCE mppmin_int 1724 # include "mpp_allreduce_generic.h90" 1725 # undef ROUTINE_ALLREDUCE 1726 # undef DIM_0d 1727 # define DIM_1d 1728 # define ROUTINE_ALLREDUCE mppmin_a_int 1729 # include "mpp_allreduce_generic.h90" 1730 # undef ROUTINE_ALLREDUCE 1731 # undef DIM_1d 1732 # undef INTEGER_TYPE 1733 ! 1734 # define REAL_TYPE 1735 # define DIM_0d 1736 # define ROUTINE_ALLREDUCE mppmin_real 1737 # include "mpp_allreduce_generic.h90" 1738 # undef ROUTINE_ALLREDUCE 1739 # undef DIM_0d 1740 # define DIM_1d 1741 # define ROUTINE_ALLREDUCE mppmin_a_real 1742 # include "mpp_allreduce_generic.h90" 1743 # undef ROUTINE_ALLREDUCE 1744 # undef DIM_1d 1745 # undef REAL_TYPE 1746 # undef OPERATION_MIN 1747 1748 !!---------------------------------------------------------------------- 1749 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1750 !! 1751 !! Global sum of 1D array or a variable (integer, real or complex) 1752 !!---------------------------------------------------------------------- 1753 !! 1754 # define OPERATION_SUM 1755 # define INTEGER_TYPE 1756 # define DIM_0d 1757 # define ROUTINE_ALLREDUCE mppsum_int 1758 # include "mpp_allreduce_generic.h90" 1759 # undef ROUTINE_ALLREDUCE 1760 # undef DIM_0d 1761 # define DIM_1d 1762 # define ROUTINE_ALLREDUCE mppsum_a_int 1763 # include "mpp_allreduce_generic.h90" 1764 # undef ROUTINE_ALLREDUCE 1765 # undef DIM_1d 1766 # undef INTEGER_TYPE 1767 ! 1768 # define REAL_TYPE 1769 # define DIM_0d 1770 # define ROUTINE_ALLREDUCE mppsum_real 1771 # include "mpp_allreduce_generic.h90" 1772 # undef ROUTINE_ALLREDUCE 1773 # undef DIM_0d 1774 # define DIM_1d 1775 # define ROUTINE_ALLREDUCE mppsum_a_real 1776 # include "mpp_allreduce_generic.h90" 1777 # undef ROUTINE_ALLREDUCE 1778 # undef DIM_1d 1779 # undef REAL_TYPE 1780 # undef OPERATION_SUM 1781 1782 # define OPERATION_SUM_DD 1783 # define COMPLEX_TYPE 1784 # define DIM_0d 1785 # define ROUTINE_ALLREDUCE mppsum_realdd 1786 # include "mpp_allreduce_generic.h90" 1787 # undef ROUTINE_ALLREDUCE 1788 # undef DIM_0d 1789 # define DIM_1d 1790 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1791 # include "mpp_allreduce_generic.h90" 1792 # undef ROUTINE_ALLREDUCE 1793 # undef DIM_1d 1794 # undef COMPLEX_TYPE 1795 # undef OPERATION_SUM_DD 1796 1797 !!---------------------------------------------------------------------- 1798 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1799 !! 1800 !!---------------------------------------------------------------------- 1801 !! 1802 # define OPERATION_MINLOC 1803 # define DIM_2d 1804 # define ROUTINE_LOC mpp_minloc2d 1805 # include "mpp_loc_generic.h90" 1806 # undef ROUTINE_LOC 1807 # undef DIM_2d 1808 # define DIM_3d 1809 # define ROUTINE_LOC mpp_minloc3d 1810 # include "mpp_loc_generic.h90" 1811 # undef ROUTINE_LOC 1812 # undef DIM_3d 1813 # undef OPERATION_MINLOC 1814 1815 # define OPERATION_MAXLOC 1816 # define DIM_2d 1817 # define ROUTINE_LOC mpp_maxloc2d 1818 # include "mpp_loc_generic.h90" 1819 # undef ROUTINE_LOC 1820 # undef DIM_2d 1821 # define DIM_3d 1822 # define ROUTINE_LOC mpp_maxloc3d 1823 # include "mpp_loc_generic.h90" 1824 # undef ROUTINE_LOC 1825 # undef DIM_3d 1826 # undef OPERATION_MAXLOC 1827 1828 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1829 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1830 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1831 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1832 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1833 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1834 INTEGER, INTENT(in ), OPTIONAL :: kcom 1835 ! 1836 pout(:) = REAL(y_in(:), wp) 1837 END SUBROUTINE mpp_delay_sum 1838 1839 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1840 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1841 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1842 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1843 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1844 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1845 INTEGER, INTENT(in ), OPTIONAL :: kcom 1846 ! 1847 pout(:) = p_in(:) 1848 END SUBROUTINE mpp_delay_max 1849 1850 SUBROUTINE mpp_delay_rcv( kid ) 1851 INTEGER,INTENT(in ) :: kid 1852 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1853 END SUBROUTINE mpp_delay_rcv 1854 1855 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1856 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1857 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1858 STOP ! non MPP case, just stop the run 1859 END SUBROUTINE mppstop 1860 1861 SUBROUTINE mpp_ini_znl( knum ) 1862 INTEGER :: knum 1863 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1864 END SUBROUTINE mpp_ini_znl 1865 1866 SUBROUTINE mpp_comm_free( kcom ) 1867 INTEGER :: kcom 1868 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1869 END SUBROUTINE mpp_comm_free 1870 1871 #endif 1872 1873 !!---------------------------------------------------------------------- 1874 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1063 FUNCTION MPI_Wtime() 1064 REAL(wp) :: MPI_Wtime 1065 MPI_Wtime = -1. 1066 END FUNCTION MPI_Wtime 1067 #endif 1068 1069 !!---------------------------------------------------------------------- 1070 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1875 1071 !!---------------------------------------------------------------------- 1876 1072 … … 1883 1079 !! increment the error number (nstop) by one. 1884 1080 !!---------------------------------------------------------------------- 1885 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1886 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1081 CHARACTER(len=*), INTENT(in ) :: cd1 1082 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1083 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1887 1084 !!---------------------------------------------------------------------- 1888 1085 ! 1889 1086 nstop = nstop + 1 1890 1891 ! force to open ocean.output file 1087 ! 1088 ! force to open ocean.output file if not already opened 1892 1089 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1893 1894 WRITE(numout,cform_err) 1895 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1090 ! 1091 WRITE(numout,*) 1092 WRITE(numout,*) ' ===>>> : E R R O R' 1093 WRITE(numout,*) 1094 WRITE(numout,*) ' ===========' 1095 WRITE(numout,*) 1096 WRITE(numout,*) TRIM(cd1) 1896 1097 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1897 1098 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1903 1104 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1904 1105 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1905 1106 WRITE(numout,*) 1107 ! 1906 1108 CALL FLUSH(numout ) 1907 1109 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1910 1112 ! 1911 1113 IF( cd1 == 'STOP' ) THEN 1114 WRITE(numout,*) 1912 1115 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1913 CALL mppstop(ld_force_abort = .true.) 1116 WRITE(numout,*) 1117 CALL mppstop( ld_abort = .true. ) 1914 1118 ENDIF 1915 1119 ! … … 1930 1134 ! 1931 1135 nwarn = nwarn + 1 1136 ! 1932 1137 IF(lwp) THEN 1933 WRITE(numout,cform_war) 1934 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1935 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1936 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1937 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1938 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1939 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1940 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1941 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1942 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1943 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1138 WRITE(numout,*) 1139 WRITE(numout,*) ' ===>>> : W A R N I N G' 1140 WRITE(numout,*) 1141 WRITE(numout,*) ' ===============' 1142 WRITE(numout,*) 1143 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1144 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1145 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1146 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1147 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1148 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1149 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1150 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1151 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1152 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1153 WRITE(numout,*) 1944 1154 ENDIF 1945 1155 CALL FLUSH(numout) … … 1984 1194 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1985 1195 ! 1986 iost=0 1987 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1196 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1988 1197 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1989 1198 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 2006 1215 100 CONTINUE 2007 1216 IF( iost /= 0 ) THEN 2008 IF(ldwp) THEN 2009 WRITE(kout,*) 2010 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2011 WRITE(kout,*) ' ======= === ' 2012 WRITE(kout,*) ' unit = ', knum 2013 WRITE(kout,*) ' status = ', cdstat 2014 WRITE(kout,*) ' form = ', cdform 2015 WRITE(kout,*) ' access = ', cdacce 2016 WRITE(kout,*) ' iostat = ', iost 2017 WRITE(kout,*) ' we stop. verify the file ' 2018 WRITE(kout,*) 2019 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 2020 WRITE(*,*) 2021 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2022 WRITE(*,*) ' ======= === ' 2023 WRITE(*,*) ' unit = ', knum 2024 WRITE(*,*) ' status = ', cdstat 2025 WRITE(*,*) ' form = ', cdform 2026 WRITE(*,*) ' access = ', cdacce 2027 WRITE(*,*) ' iostat = ', iost 2028 WRITE(*,*) ' we stop. verify the file ' 2029 WRITE(*,*) 2030 ENDIF 2031 CALL FLUSH( kout ) 2032 STOP 'ctl_opn bad opening' 1217 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1218 WRITE(ctmp2,*) ' ======= === ' 1219 WRITE(ctmp3,*) ' unit = ', knum 1220 WRITE(ctmp4,*) ' status = ', cdstat 1221 WRITE(ctmp5,*) ' form = ', cdform 1222 WRITE(ctmp6,*) ' access = ', cdacce 1223 WRITE(ctmp7,*) ' iostat = ', iost 1224 WRITE(ctmp8,*) ' we stop. verify the file ' 1225 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 2033 1226 ENDIF 2034 1227 ! … … 2036 1229 2037 1230 2038 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1231 SUBROUTINE ctl_nam ( kios, cdnam ) 2039 1232 !!---------------------------------------------------------------------- 2040 1233 !! *** ROUTINE ctl_nam *** … … 2044 1237 !! ** Method : Fortan open 2045 1238 !!---------------------------------------------------------------------- 2046 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist2047 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs2048 CHARACTER(len=5) :: clios ! string to convert iostat in character for print2049 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1239 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1240 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1241 ! 1242 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 2050 1243 !!---------------------------------------------------------------------- 2051 1244 ! … … 2061 1254 ENDIF 2062 1255 kios = 0 2063 RETURN2064 1256 ! 2065 1257 END SUBROUTINE ctl_nam … … 2082 1274 END DO 2083 1275 IF( (get_unit == 999) .AND. llopn ) THEN 2084 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2085 get_unit = -1 1276 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 2086 1277 ENDIF 2087 1278 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/mpp_lnk_generic.h90
r10542 r12143 46 46 47 47 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval)49 INTEGER 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 49 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 50 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval)51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom ) 52 52 #endif 53 53 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 58 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 60 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated 61 ! 62 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 63 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 62 INTEGER :: i migr, iihom, ijhom! local integers63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend64 INTEGER :: isize, ishift, ishift2 ! local integers 65 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 66 INTEGER :: ierr 67 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 INTEGER :: ihl ! number of ranks and rows to be communicated 65 69 REAL(wp) :: zland 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 67 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos 68 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos 70 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 72 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 75 LOGICAL :: lldo_nfd ! do north pole folding 69 76 !!---------------------------------------------------------------------- 77 ! 78 ! ----------------------------------------- ! 79 ! 0. local variables initialization ! 80 ! ----------------------------------------- ! 70 81 ! 71 82 ipk = K_SIZE(ptab) ! 3rd dimension … … 73 84 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 74 85 ! 86 IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom 87 ELSE ; ihl = 1 88 END IF 89 ! 75 90 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 91 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 80 81 ! ------------------------------- ! 82 ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible 83 ! ------------------------------- ! 84 ! 85 IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==! 86 ! 87 DO jf = 1, ipf ! number of arrays to be treated 88 ! 89 ! ! East-West boundaries 90 IF( l_Iperio ) THEN !* cyclic 91 ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 92 ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) 93 ELSE !* closed 94 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point 95 ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west 96 ENDIF 97 ! ! North-South boundaries 98 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 99 ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 100 ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) 101 ELSE !* closed 102 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point 103 ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north 92 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 93 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 94 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 95 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 96 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 97 WRITE(ctmp2,*) ' ========== ' 98 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 99 ELSE ! send and receive with every neighbour 100 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 101 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 102 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 103 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 104 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 105 END IF 106 107 108 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 109 110 zland = 0._wp ! land filling value: zero by default 111 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 112 113 ! define the method we will use to fill the halos in each direction 114 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 115 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 116 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 117 ELSE ; ifill_we = jpfillcst 118 END IF 119 ! 120 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 121 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 122 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 123 ELSE ; ifill_ea = jpfillcst 124 END IF 125 ! 126 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 127 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 128 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 129 ELSE ; ifill_so = jpfillcst 130 END IF 131 ! 132 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 133 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 134 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 135 ELSE ; ifill_no = jpfillcst 136 END IF 137 ! 138 #if defined PRINT_CAUTION 139 ! 140 ! ================================================================================== ! 141 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 142 ! ================================================================================== ! 143 ! 144 #endif 145 ! 146 ! -------------------------------------------------- ! 147 ! 1. Do east and west MPI exchange if needed ! 148 ! -------------------------------------------------- ! 149 ! 150 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 151 isize = ihl * jpj * ipk * ipl * ipf 152 ! 153 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 155 IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 156 IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 157 IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 158 ! 159 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 160 ishift = ihl 161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 162 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl 163 END DO ; END DO ; END DO ; END DO ; END DO 164 ENDIF 165 ! 166 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 167 ishift = jpi - 2 * ihl 168 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 169 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl 170 END DO ; END DO ; END DO ; END DO ; END DO 171 ENDIF 172 ! 173 IF( ln_timing ) CALL tic_tac(.TRUE.) 174 ! 175 ! non-blocking send of the western/eastern side using local temporary arrays 176 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 177 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 178 ! blocking receive of the western/eastern halo in local temporary arrays 179 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 180 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 181 ! 182 IF( ln_timing ) CALL tic_tac(.FALSE.) 183 ! 184 ! 185 ! ----------------------------------- ! 186 ! 2. Fill east and west halos ! 187 ! ----------------------------------- ! 188 ! 189 ! 2.1 fill weastern halo 190 ! ---------------------- 191 ! ishift = 0 ! fill halo from ji = 1 to ihl 192 SELECT CASE ( ifill_we ) 193 CASE ( jpfillnothing ) ! no filling 194 CASE ( jpfillmpi ) ! use data received by MPI 195 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 196 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl 197 END DO; END DO ; END DO ; END DO ; END DO 198 CASE ( jpfillperio ) ! use east-weast periodicity 199 ishift2 = jpi - 2 * ihl 200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 201 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 202 END DO; END DO ; END DO ; END DO ; END DO 203 CASE ( jpfillcopy ) ! filling with inner domain values 204 DO jf = 1, ipf ! number of arrays to be treated 205 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 206 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 207 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 208 END DO ; END DO ; END DO ; END DO 104 209 ENDIF 105 210 END DO 106 ! 107 ENDIF 108 109 ! ------------------------------- ! 110 ! East and west exchange ! 111 ! ------------------------------- ! 112 ! we play with the neigbours AND the row number because of the periodicity 113 ! 114 IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 115 IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 116 ! 117 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 118 CASE ( -1 ) 119 iihom = nlci-nreci 120 DO jf = 1, ipf 121 DO jl = 1, ipl 122 DO jk = 1, ipk 123 DO jh = 1, nn_hls 124 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 125 END DO 126 END DO 127 END DO 128 END DO 129 CASE ( 0 ) 130 iihom = nlci-nreci 131 DO jf = 1, ipf 132 DO jl = 1, ipl 133 DO jk = 1, ipk 134 DO jh = 1, nn_hls 135 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 136 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 137 END DO 138 END DO 139 END DO 140 END DO 141 CASE ( 1 ) 142 iihom = nlci-nreci 143 DO jf = 1, ipf 144 DO jl = 1, ipl 145 DO jk = 1, ipk 146 DO jh = 1, nn_hls 147 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 148 END DO 149 END DO 150 END DO 211 CASE ( jpfillcst ) ! filling with constant value 212 DO jf = 1, ipf ! number of arrays to be treated 213 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 214 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 215 ARRAY_IN(ji,jj,jk,jl,jf) = zland 216 END DO; END DO ; END DO ; END DO 217 ENDIF 151 218 END DO 152 219 END SELECT 153 ! ! Migrations 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 ! 156 IF( ln_timing ) CALL tic_tac(.TRUE.) 157 ! 158 SELECT CASE ( nbondi ) 159 CASE ( -1 ) 160 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 161 CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 162 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 163 CASE ( 0 ) 164 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 165 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 166 CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 167 CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 168 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 169 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 170 CASE ( 1 ) 171 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 172 CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 173 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 220 ! 221 ! 2.2 fill eastern halo 222 ! --------------------- 223 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi 224 SELECT CASE ( ifill_ea ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillmpi ) ! use data received by MPI 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 228 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi 229 END DO ; END DO ; END DO ; END DO ; END DO 230 CASE ( jpfillperio ) ! use east-weast periodicity 231 ishift2 = ihl 232 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 233 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 234 END DO ; END DO ; END DO ; END DO ; END DO 235 CASE ( jpfillcopy ) ! filling with inner domain values 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 237 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 238 END DO ; END DO ; END DO ; END DO ; END DO 239 CASE ( jpfillcst ) ! filling with constant value 240 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl 241 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 242 END DO; END DO ; END DO ; END DO ; END DO 174 243 END SELECT 175 !176 IF( ln_timing ) CALL tic_tac(.FALSE.)177 !178 ! ! Write Dirichlet lateral conditions179 iihom = nlci-nn_hls180 !181 SELECT CASE ( nbondi )182 CASE ( -1 )183 DO jf = 1, ipf184 DO jl = 1, ipl185 DO jk = 1, ipk186 DO jh = 1, nn_hls187 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)188 END DO189 END DO190 END DO191 END DO192 CASE ( 0 )193 DO jf = 1, ipf194 DO jl = 1, ipl195 DO jk = 1, ipk196 DO jh = 1, nn_hls197 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)198 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)199 END DO200 END DO201 END DO202 END DO203 CASE ( 1 )204 DO jf = 1, ipf205 DO jl = 1, ipl206 DO jk = 1, ipk207 DO jh = 1, nn_hls208 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)209 END DO210 END DO211 END DO212 END DO213 END SELECT214 !215 IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )216 244 ! 217 245 ! ------------------------------- ! 218 246 ! 3. north fold treatment ! 219 247 ! ------------------------------- ! 248 ! 220 249 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 221 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 250 ! 251 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 222 252 ! 223 253 SELECT CASE ( jpni ) … … 226 256 END SELECT 227 257 ! 228 ENDIF 229 ! 230 ! ------------------------------- ! 231 ! 4. North and south directions ! 232 ! ------------------------------- ! 233 ! always closed : we play only with the neigbours 234 ! 235 IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 236 IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 237 ! 238 SELECT CASE ( nbondj ) 239 CASE ( -1 ) 240 ijhom = nlcj-nrecj 241 DO jf = 1, ipf 242 DO jl = 1, ipl 243 DO jk = 1, ipk 244 DO jh = 1, nn_hls 245 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 246 END DO 247 END DO 248 END DO 258 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 259 ! 260 ENDIF 261 ! 262 ! ---------------------------------------------------- ! 263 ! 4. Do north and south MPI exchange if needed ! 264 ! ---------------------------------------------------- ! 265 ! 266 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 267 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 268 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 269 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 270 ! 271 isize = jpi * ihl * ipk * ipl * ipf 272 273 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 274 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 275 ishift = ihl 276 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 277 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl 278 END DO ; END DO ; END DO ; END DO ; END DO 279 ENDIF 280 ! 281 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 282 ishift = jpj - 2 * ihl 283 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 284 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl 285 END DO ; END DO ; END DO ; END DO ; END DO 286 ENDIF 287 ! 288 IF( ln_timing ) CALL tic_tac(.TRUE.) 289 ! 290 ! non-blocking send of the southern/northern side 291 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 292 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 293 ! blocking receive of the southern/northern halo 294 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 295 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 296 ! 297 IF( ln_timing ) CALL tic_tac(.FALSE.) 298 ! 299 ! ------------------------------------- ! 300 ! 5. Fill south and north halos ! 301 ! ------------------------------------- ! 302 ! 303 ! 5.1 fill southern halo 304 ! ---------------------- 305 ! ishift = 0 ! fill halo from jj = 1 to ihl 306 SELECT CASE ( ifill_so ) 307 CASE ( jpfillnothing ) ! no filling 308 CASE ( jpfillmpi ) ! use data received by MPI 309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 310 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl 311 END DO; END DO ; END DO ; END DO ; END DO 312 CASE ( jpfillperio ) ! use north-south periodicity 313 ishift2 = jpj - 2 * ihl 314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 315 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 316 END DO; END DO ; END DO ; END DO ; END DO 317 CASE ( jpfillcopy ) ! filling with inner domain values 318 DO jf = 1, ipf ! number of arrays to be treated 319 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 320 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 321 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 322 END DO ; END DO ; END DO ; END DO 323 ENDIF 249 324 END DO 250 CASE ( 0 ) 251 ijhom = nlcj-nrecj 252 DO jf = 1, ipf 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jh = 1, nn_hls 256 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 257 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 258 END DO 259 END DO 260 END DO 261 END DO 262 CASE ( 1 ) 263 ijhom = nlcj-nrecj 264 DO jf = 1, ipf 265 DO jl = 1, ipl 266 DO jk = 1, ipk 267 DO jh = 1, nn_hls 268 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 269 END DO 270 END DO 271 END DO 325 CASE ( jpfillcst ) ! filling with constant value 326 DO jf = 1, ipf ! number of arrays to be treated 327 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 328 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 329 ARRAY_IN(ji,jj,jk,jl,jf) = zland 330 END DO; END DO ; END DO ; END DO 331 ENDIF 272 332 END DO 273 333 END SELECT 274 334 ! 275 ! ! Migrations 276 imigr = nn_hls * jpi * ipk * ipl * ipf 277 ! 278 IF( ln_timing ) CALL tic_tac(.TRUE.) 279 ! 280 SELECT CASE ( nbondj ) 281 CASE ( -1 ) 282 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 283 CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 284 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 285 CASE ( 0 ) 286 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 287 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 288 CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 289 CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 290 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 291 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 292 CASE ( 1 ) 293 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 294 CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 295 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 335 ! 5.2 fill northern halo 336 ! ---------------------- 337 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj 338 SELECT CASE ( ifill_no ) 339 CASE ( jpfillnothing ) ! no filling 340 CASE ( jpfillmpi ) ! use data received by MPI 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 342 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj 343 END DO ; END DO ; END DO ; END DO ; END DO 344 CASE ( jpfillperio ) ! use north-south periodicity 345 ishift2 = ihl 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 347 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 348 END DO; END DO ; END DO ; END DO ; END DO 349 CASE ( jpfillcopy ) ! filling with inner domain values 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 352 END DO; END DO ; END DO ; END DO ; END DO 353 CASE ( jpfillcst ) ! filling with constant value 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 356 END DO; END DO ; END DO ; END DO ; END DO 296 357 END SELECT 297 358 ! 298 IF( ln_timing ) CALL tic_tac(.FALSE.) 299 ! ! Write Dirichlet lateral conditions 300 ijhom = nlcj-nn_hls 301 ! 302 SELECT CASE ( nbondj ) 303 CASE ( -1 ) 304 DO jf = 1, ipf 305 DO jl = 1, ipl 306 DO jk = 1, ipk 307 DO jh = 1, nn_hls 308 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 309 END DO 310 END DO 311 END DO 312 END DO 313 CASE ( 0 ) 314 DO jf = 1, ipf 315 DO jl = 1, ipl 316 DO jk = 1, ipk 317 DO jh = 1, nn_hls 318 ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 319 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 320 END DO 321 END DO 322 END DO 323 END DO 324 CASE ( 1 ) 325 DO jf = 1, ipf 326 DO jl = 1, ipl 327 DO jk = 1, ipk 328 DO jh = 1, nn_hls 329 ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 330 END DO 331 END DO 332 END DO 333 END DO 334 END SELECT 335 ! 336 IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 359 ! -------------------------------------------- ! 360 ! 6. deallocate local temporary arrays ! 361 ! -------------------------------------------- ! 362 ! 363 IF( llsend_we ) THEN 364 CALL mpi_wait(ireq_we, istat, ierr ) 365 DEALLOCATE( zsnd_we ) 366 ENDIF 367 IF( llsend_ea ) THEN 368 CALL mpi_wait(ireq_ea, istat, ierr ) 369 DEALLOCATE( zsnd_ea ) 370 ENDIF 371 IF( llsend_so ) THEN 372 CALL mpi_wait(ireq_so, istat, ierr ) 373 DEALLOCATE( zsnd_so ) 374 ENDIF 375 IF( llsend_no ) THEN 376 CALL mpi_wait(ireq_no, istat, ierr ) 377 DEALLOCATE( zsnd_no ) 378 ENDIF 379 ! 380 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 381 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 382 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 383 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 337 384 ! 338 385 END SUBROUTINE ROUTINE_LNK -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/mpp_nfd_generic.h90
r10440 r12143 76 76 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 77 77 ! 78 IF( l_north_nogather ) THEN !== ????==!78 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 79 80 80 ALLOCATE(ipj_s(ipf)) … … 200 200 ENDIF 201 201 END DO 202 IF( l_isend ) THEN 203 DO jr = 1,nsndto 204 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 205 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 206 ENDIF 207 END DO 208 ENDIF 202 DO jr = 1,nsndto 203 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 204 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 205 ENDIF 206 END DO 209 207 ! 210 208 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 213 211 ! 214 212 DO jf = 1, ipf 215 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 216 END DO 217 ! 218 DEALLOCATE( zfoldwk ) 219 DEALLOCATE( ztabr ) 220 DEALLOCATE( jj_s ) 221 DEALLOCATE( ipj_s ) 222 ELSE !== ???? ==! 213 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 214 END DO 215 ! 216 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 217 ! 218 ELSE !== allgather exchanges ==! 223 219 ! 224 220 ipj = 4 ! 2nd dimension of message transfers (last j-lines) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LBC/mppini.F90
r11242 r12143 84 84 nbondj = 2 85 85 nidom = FLIO_DOM_NONE 86 npolj = jperio 86 npolj = 0 87 IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 88 IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 87 89 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 88 90 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) … … 152 154 LOGICAL :: llbest, llauto 153 155 LOGICAL :: llwrtlay 156 LOGICAL :: ln_listonly 154 157 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 158 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - … … 164 167 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 165 168 & cn_ice, nn_ice_dta, & 166 & rn_ice_tem, rn_ice_sal, rn_ice_age, &167 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy168 !!---------------------------------------------------------------------- 169 169 & ln_vol, nn_volctl, nn_rimwidth 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly 171 !!---------------------------------------------------------------------- 172 ! 170 173 llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 174 ! 175 ! 0. read namelists parameters 176 ! ----------------------------------- 177 ! 178 REWIND( numnam_ref ) ! Namelist nammpp in reference namelist 179 READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 180 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 181 REWIND( numnam_cfg ) ! Namelist nammpp in confguration namelist 182 READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 183 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 184 ! 185 IF(lwp) THEN 186 WRITE(numout,*) ' Namelist nammpp' 187 IF( jpni < 1 .OR. jpnj < 1 ) THEN 188 WRITE(numout,*) ' jpni and jpnj will be calculated automatically' 189 ELSE 190 WRITE(numout,*) ' processor grid extent in i jpni = ', jpni 191 WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj 192 ENDIF 193 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 194 ENDIF 195 ! 196 IF(lwm) WRITE( numond, nammpp ) 197 171 198 ! do we need to take into account bdy_msk? 172 199 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY 173 200 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 174 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' , lwp)201 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 175 202 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY 176 203 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 177 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' , lwp)204 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 178 205 ! 179 206 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 180 207 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 208 ! 209 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 181 210 ! 182 211 ! 1. Dimension arrays for subdomains … … 241 270 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 242 271 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 243 CALL ctl_stop( 'STOP' )244 272 ENDIF 245 273 … … 266 294 ENDIF 267 295 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 268 CALL ctl_stop( 'STOP' )269 296 ENDIF 270 297 … … 511 538 9401 FORMAT(' ' ,20(' ',i3,' ') ) 512 539 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) 513 9404 FORMAT(' * ' ,20(' ',i3,' * ') )540 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 514 541 ENDIF 515 542 … … 816 843 INTEGER :: isziref, iszjref 817 844 INTEGER :: inbij, iszij 818 INTEGER :: inbimax, inbjmax, inbijmax 845 INTEGER :: inbimax, inbjmax, inbijmax, inbijold 819 846 INTEGER :: isz0, isz1 820 847 INTEGER, DIMENSION( :), ALLOCATABLE :: indexok … … 941 968 DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 942 969 943 IF( llist ) THEN ! we print about 21 best partitions970 IF( llist ) THEN 944 971 IF(lwp) THEN 945 972 WRITE(numout,*) 946 WRITE(numout, 947 WRITE(numout, '(a,i5,a)') ' list of the best partitions around ', knbij, ' mpi processes'948 WRITE(numout, *) ' --------------------------------------', '-----', '--------------'973 WRITE(numout,*) ' For your information:' 974 WRITE(numout,*) ' list of the best partitions including land supression' 975 WRITE(numout,*) ' -----------------------------------------------------' 949 976 WRITE(numout,*) 950 977 END IF 951 iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 952 DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 978 ji = isz0 ! initialization with the largest value 979 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 980 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 981 inbijold = COUNT(llisoce) 982 DEALLOCATE( llisoce ) 983 DO ji =isz0-1,1,-1 953 984 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 954 985 CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 955 986 inbij = COUNT(llisoce) 956 987 DEALLOCATE( llisoce ) 957 IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)') & 958 & 'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij & 959 & , ' land ( ', inbi0(ji),' x ', inbj0(ji), & 960 & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 988 IF(lwp .AND. inbij < inbijold) THEN 989 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & 990 & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & 991 & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & 992 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 993 inbijold = inbij 994 END IF 961 995 END DO 962 996 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 963 RETURN 997 IF(lwp) THEN 998 WRITE(numout,*) 999 WRITE(numout,*) ' -----------------------------------------------------------' 1000 ENDIF 1001 CALL mppsync 1002 CALL mppstop( ld_abort = .TRUE. ) 964 1003 ENDIF 965 1004 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LDF/ldfdyn.F90
r10784 r12143 117 117 REWIND( numnam_ref ) ! Namelist namdyn_ldf in reference namelist : Lateral physics 118 118 READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) 119 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' , lwp)119 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) 120 120 121 121 REWIND( numnam_cfg ) ! Namelist namdyn_ldf in configuration namelist : Lateral physics 122 122 READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) 123 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' , lwp)123 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) 124 124 IF(lwm) WRITE ( numond, namdyn_ldf ) 125 125 … … 315 315 DO jj = 1, jpj ! Set local gridscale values 316 316 DO ji = 1, jpi 317 esqt(ji,jj) = ( e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2318 esqf(ji,jj) = ( e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2317 esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 318 esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 319 319 END DO 320 320 END DO -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/LDF/ldftra.F90
r11987 r12143 154 154 REWIND( numnam_ref ) ! Namelist namtra_ldf in reference namelist : Lateral physics on tracers 155 155 READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) 156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' , lwp)156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) 157 157 REWIND( numnam_cfg ) ! Namelist namtra_ldf in configuration namelist : Lateral physics on tracers 158 158 READ ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) 159 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' , lwp)159 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) 160 160 IF(lwm) WRITE( numond, namtra_ldf ) 161 161 ! … … 512 512 REWIND( numnam_ref ) ! Namelist namtra_eiv in reference namelist : eddy induced velocity param. 513 513 READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) 514 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' , lwp)514 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) 515 515 ! 516 516 REWIND( numnam_cfg ) ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param. 517 517 READ ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) 518 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' , lwp)518 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) 519 519 IF(lwm) WRITE ( numond, namtra_eiv ) 520 520 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/OBS/diaobs.F90
r10068 r12143 203 203 REWIND( numnam_ref ) ! Namelist namobs in reference namelist 204 204 READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 205 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' , lwp)205 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' ) 206 206 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist 207 207 READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' , lwp)208 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' ) 209 209 IF(lwm) WRITE ( numond, namobs ) 210 210 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/fldread.F90
r10425 r12143 48 48 TYPE, PUBLIC :: FLD_N !: Namelist field informations 49 49 CHARACTER(len = 256) :: clname ! generic name of the NetCDF flux file 50 REAL(wp) :: nfreqh! frequency of each flux file50 REAL(wp) :: freqh ! frequency of each flux file 51 51 CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file 52 52 LOGICAL :: ln_tint ! time interpolation or not (T/F) … … 64 64 CHARACTER(len = 256) :: clrootname ! generic name of the NetCDF file 65 65 CHARACTER(len = 256) :: clname ! current name of the NetCDF file 66 REAL(wp) :: nfreqh! frequency of each flux file66 REAL(wp) :: freqh ! frequency of each flux file 67 67 CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file 68 68 LOGICAL :: ln_tint ! time interpolation or not (T/F) … … 80 80 INTEGER :: nreclast ! last record to be read in the current file 81 81 CHARACTER(len = 256) :: lsmname ! current name of the NetCDF mask file acting as a key 82 INTEGER :: igrd ! grid type for bdy data 83 INTEGER :: ibdy ! bdy set id number 82 ! ! 83 ! ! Variables related to BDY 84 INTEGER :: igrd ! grid type for bdy data 85 INTEGER :: ibdy ! bdy set id number 86 INTEGER, POINTER, DIMENSION(:) :: imap ! Array of integer pointers to 1D arrays 87 LOGICAL :: ltotvel ! total velocity or not (T/F) 88 LOGICAL :: lzint ! T if it requires a vertical interpolation 84 89 END TYPE FLD 85 86 TYPE, PUBLIC :: MAP_POINTER !: Map from input data file to local domain87 INTEGER, POINTER, DIMENSION(:) :: ptr ! Array of integer pointers to 1D arrays88 LOGICAL :: ll_unstruc ! Unstructured (T) or structured (F) boundary data file89 END TYPE MAP_POINTER90 90 91 91 !$AGRIF_DO_NOT_TREAT … … 129 129 CONTAINS 130 130 131 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl)131 SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, kt_offset ) 132 132 !!--------------------------------------------------------------------- 133 133 !! *** ROUTINE fld_read *** … … 144 144 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 145 145 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 146 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices147 146 INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option 148 147 INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! provide fields at time other than "now" … … 150 149 ! ! kt_offset = +1 => fields at "after" time level 151 150 ! ! etc. 152 INTEGER , INTENT(in ), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data153 LOGICAL , INTENT(in ), OPTIONAL :: fvl ! number of vertical levels in the BDY data154 151 !! 155 152 INTEGER :: itmp ! local variable … … 166 163 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 167 164 CHARACTER(LEN=1000) :: clfmt ! write format 168 TYPE(MAP_POINTER) :: imap ! global-to-local mapping indices169 165 !!--------------------------------------------------------------------- 170 166 ll_firstcall = kt == nit000 … … 175 171 ENDIF 176 172 IF( PRESENT(kt_offset) ) it_offset = kt_offset 177 178 imap%ptr => NULL()179 173 180 174 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar … … 188 182 IF( ll_firstcall ) THEN ! initialization 189 183 DO jf = 1, imf 190 IF( PRESENT(map) ) imap = map(jf) 191 IF( PRESENT(jpk_bdy) ) THEN 192 CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl ) ! read each before field (put them in after as they will be swapped) 193 ELSE 194 CALL fld_init( kn_fsbc, sd(jf), imap ) ! read each before field (put them in after as they will be swapped) 195 ENDIF 184 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 185 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 196 186 END DO 197 187 IF( lwp ) CALL wgt_print() ! control print … … 202 192 ! 203 193 DO jf = 1, imf ! --- loop over field --- ! 204 194 195 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 196 205 197 IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? 206 207 IF( PRESENT(map) ) imap = map(jf) ! temporary definition of map208 198 209 199 sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:) ! swap before record informations … … 213 203 CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit ) ! update after record informations 214 204 215 ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),205 ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 216 206 ! it is possible that the before value is no more the good one... we have to re-read it 217 207 ! if before is not the last record of the file currently opened and after is the first record to be read … … 222 212 itmp = sd(jf)%nrec_a(1) ! temporary storage 223 213 sd(jf)%nrec_a(1) = sd(jf)%nreclast ! read the last record of the file currently opened 224 CALL fld_get( sd(jf) , imap )! read after data214 CALL fld_get( sd(jf) ) ! read after data 225 215 sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field 226 216 sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations 227 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)% nfreqh * 3600) ! assume freq to be in hours in this case217 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case 228 218 sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations 229 219 sd(jf)%nrec_a(1) = itmp ! move back to after record … … 234 224 IF( sd(jf)%ln_tint ) THEN 235 225 236 ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),226 ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 237 227 ! it is possible that the before value is no more the good one... we have to re-read it 238 228 ! if before record is not just just before the after record... … … 240 230 & .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN 241 231 sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1 ! move back to before record 242 CALL fld_get( sd(jf) , imap )! read after data232 CALL fld_get( sd(jf) ) ! read after data 243 233 sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field 244 234 sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations 245 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)% nfreqh * 3600) ! assume freq to be in hours in this case235 sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case 246 236 sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations 247 237 sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1 ! move back to after record … … 268 258 ! year/month/week/day, next year/month/week/day file must exist 269 259 isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt) ! second at the end of the run 270 llstop = isecend > sd(jf)%nrec_a(2) 260 llstop = isecend > sd(jf)%nrec_a(2) ! read more than 1 record of next year 271 261 ! we suppose that the date of next file is next day (should be ok even for weekly files...) 272 262 CALL fld_clopn( sd(jf), nyear + COUNT((/llnxtyr /)) , & … … 277 267 CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)// & 278 268 & ' not present -> back to current year/month/day') 279 CALL fld_clopn( sd(jf) ) ! back to the current year/month/day269 CALL fld_clopn( sd(jf) ) ! back to the current year/month/day 280 270 sd(jf)%nrec_a(1) = sd(jf)%nreclast ! force to read the last record in the current year file 281 271 ENDIF … … 285 275 286 276 ! read after data 287 IF( PRESENT(jpk_bdy) ) THEN 288 CALL fld_get( sd(jf), imap, jpk_bdy, fvl) 289 ELSE 290 CALL fld_get( sd(jf), imap ) 291 ENDIF 277 CALL fld_get( sd(jf) ) 278 292 279 ENDIF ! read new data? 293 280 END DO ! --- end loop over field --- ! … … 296 283 297 284 DO jf = 1, imf ! --- loop over field --- ! 285 ! 286 IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE 298 287 ! 299 288 IF( sd(jf)%ln_tint ) THEN ! temporal interpolation … … 327 316 328 317 329 SUBROUTINE fld_init( kn_fsbc, sdjf , map , jpk_bdy, fvl)318 SUBROUTINE fld_init( kn_fsbc, sdjf ) 330 319 !!--------------------------------------------------------------------- 331 320 !! *** ROUTINE fld_init *** … … 336 325 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 337 326 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 338 TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices339 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data340 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the BDY data341 327 !! 342 328 LOGICAL :: llprevyr ! are we reading previous year file? … … 351 337 CHARACTER(LEN=1000) :: clfmt ! write format 352 338 !!--------------------------------------------------------------------- 339 ! 353 340 llprevyr = .FALSE. 354 341 llprevmth = .FALSE. … … 365 352 ! 366 353 IF( sdjf%nrec_a(1) == 0 ) THEN ! we redefine record sdjf%nrec_a(1) with the last record of previous year file 367 IF ( sdjf%nfreqh== -12 ) THEN ! yearly mean354 IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean 368 355 IF( sdjf%cltype == 'yearly' ) THEN ! yearly file 369 356 sdjf%nrec_a(1) = 1 ! force to read the unique record … … 372 359 CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) ) 373 360 ENDIF 374 ELSEIF( sdjf%nfreqh== -1 ) THEN ! monthly mean361 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean 375 362 IF( sdjf%cltype == 'monthly' ) THEN ! monthly file 376 363 sdjf%nrec_a(1) = 1 ! force to read the unique record … … 381 368 llprevyr = .NOT. sdjf%ln_clim ! use previous year file? 382 369 ENDIF 383 ELSE ! higher frequency mean (in hours)370 ELSE ! higher frequency mean (in hours) 384 371 IF ( sdjf%cltype == 'monthly' ) THEN ! monthly file 385 sdjf%nrec_a(1) = NINT( 24 * nmonth_len(nmonth-1) / sdjf%nfreqh )! last record of previous month372 sdjf%nrec_a(1) = NINT( 24. * REAL(nmonth_len(nmonth-1),wp) / sdjf%freqh )! last record of previous month 386 373 llprevmth = .TRUE. ! use previous month file? 387 374 llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? 388 375 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ! weekly file 389 376 llprevweek = .TRUE. ! use previous week file? 390 sdjf%nrec_a(1) = NINT( 24 * 7 / sdjf%nfreqh )! last record of previous week377 sdjf%nrec_a(1) = NINT( 24. * 7. / sdjf%freqh ) ! last record of previous week 391 378 isec_week = NINT(rday) * 7 ! add a shift toward previous week 392 379 ELSEIF( sdjf%cltype == 'daily' ) THEN ! daily file 393 sdjf%nrec_a(1) = NINT( 24 / sdjf%nfreqh ) ! last record of previous day380 sdjf%nrec_a(1) = NINT( 24. / sdjf%freqh ) ! last record of previous day 394 381 llprevday = .TRUE. ! use previous day file? 395 382 llprevmth = llprevday .AND. nday == 1 ! use previous month file? 396 383 llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? 397 384 ELSE ! yearly file 398 sdjf%nrec_a(1) = NINT( 24 * nyear_len(0) / sdjf%nfreqh )! last record of previous year385 sdjf%nrec_a(1) = NINT( 24. * REAL(nyear_len(0),wp) / sdjf%freqh ) ! last record of previous year 399 386 llprevyr = .NOT. sdjf%ln_clim ! use previous year file? 400 387 ENDIF … … 433 420 ! 434 421 ! read before data in after arrays(as we will swap it later) 435 IF( PRESENT(jpk_bdy) ) THEN 436 CALL fld_get( sdjf, map, jpk_bdy, fvl ) 437 ELSE 438 CALL fld_get( sdjf, map ) 439 ENDIF 422 CALL fld_get( sdjf ) 440 423 ! 441 424 clfmt = "(' fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" … … 456 439 !! if sdjf%ln_tint = .FALSE. 457 440 !! nrec_a(1): record number 458 !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only)441 !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record 459 442 !!---------------------------------------------------------------------- 460 443 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) … … 484 467 ELSE ; it_offset = 0 485 468 ENDIF 486 IF( PRESENT(kt_offset) ) it_offset = kt_offset469 IF( PRESENT(kt_offset) ) it_offset = kt_offset 487 470 IF( PRESENT(kit) ) THEN ; it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 488 471 ELSE ; it_offset = it_offset * NINT( rdt ) 489 472 ENDIF 490 473 ! 491 ! ! =========== !492 IF ( sdjf%nfreqh== -12 ) THEN ! yearly mean493 ! ! =========== !494 ! 495 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record474 ! ! =========== ! 475 IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean 476 ! ! =========== ! 477 ! 478 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 496 479 ! 497 480 ! INT( ztmp ) … … 505 488 ! forcing record : 1 506 489 ! 507 ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 &508 &+ REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday )490 ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 491 & + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 509 492 sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 510 493 ! swap at the middle of the year … … 514 497 & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2) 515 498 ENDIF 516 ELSE ! no time interpolation499 ELSE ! no time interpolation 517 500 sdjf%nrec_a(1) = 1 518 501 sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000 ! swap at the end of the year … … 520 503 ENDIF 521 504 ! 522 ! ! ============ !523 ELSEIF( sdjf%nfreqh== -1 ) THEN ! monthly mean !524 ! ! ============ !525 ! 526 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record505 ! ! ============ ! 506 ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean ! 507 ! ! ============ ! 508 ! 509 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 527 510 ! 528 511 ! INT( ztmp ) … … 536 519 ! forcing record : nmonth 537 520 ! 538 ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 &539 & + REAL(it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday )521 ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 522 & + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 540 523 imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 541 524 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) … … 551 534 ENDIF 552 535 ! 553 ! ! ================================ !554 ELSE ! higher frequency mean (in hours)555 ! ! ================================ !556 ! 557 ifreq_sec = NINT( sdjf% nfreqh * 3600) ! frequency mean (in seconds)536 ! ! ================================ ! 537 ELSE ! higher frequency mean (in hours) 538 ! ! ================================ ! 539 ! 540 ifreq_sec = NINT( sdjf%freqh * 3600. ) ! frequency mean (in seconds) 558 541 IF( sdjf%cltype(1:4) == 'week' ) isec_week = ksec_week( sdjf%cltype(6:8) ) ! since the first day of the current week 559 542 ! number of second since the beginning of the file … … 565 548 ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp ) ! centrered in the middle of sbc time step 566 549 ztmp = ztmp + 0.01 * rdt ! avoid truncation error 567 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record550 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 568 551 ! 569 552 ! INT( ztmp/ifreq_sec + 0.5 ) … … 579 562 ! 580 563 ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5 581 ELSE ! no time interpolation564 ELSE ! no time interpolation 582 565 ! 583 566 ! INT( ztmp/ifreq_sec ) … … 610 593 ENDIF 611 594 ! 595 IF( .NOT. sdjf%ln_tint ) sdjf%nrec_a(2) = sdjf%nrec_a(2) - 1 ! last second belongs to bext record : *----( 596 ! 612 597 END SUBROUTINE fld_rec 613 598 614 599 615 SUBROUTINE fld_get( sdjf , map, jpk_bdy, fvl)600 SUBROUTINE fld_get( sdjf ) 616 601 !!--------------------------------------------------------------------- 617 602 !! *** ROUTINE fld_get *** … … 620 605 !!---------------------------------------------------------------------- 621 606 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables 622 TYPE(MAP_POINTER), INTENT(in ) :: map ! global-to-local mapping indices623 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the bdy data624 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the bdy data625 607 ! 626 608 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 634 616 ipk = SIZE( sdjf%fnow, 3 ) 635 617 ! 636 IF( ASSOCIATED(map%ptr) ) THEN 637 IF( PRESENT(jpk_bdy) ) THEN 638 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), & 639 sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 640 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), & 641 sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 642 ENDIF 643 ELSE 644 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 645 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 646 ENDIF 647 ENDIF 618 IF( ASSOCIATED(sdjf%imap) ) THEN 619 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), & 620 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 621 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), & 622 & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 623 ENDIF 648 624 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 649 625 CALL wgt_list( sdjf, iw ) … … 700 676 END SUBROUTINE fld_get 701 677 702 SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl ) 678 679 SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint ) 703 680 !!--------------------------------------------------------------------- 704 681 !! *** ROUTINE fld_map *** … … 707 684 !! using a general mapping (for open boundaries) 708 685 !!---------------------------------------------------------------------- 709 710 USE bdy_oce, ONLY: ln_bdy, idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz ! workspace to read in global data arrays 711 712 INTEGER , INTENT(in ) :: num ! stream number 713 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 714 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 715 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 716 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 717 INTEGER , INTENT(in), OPTIONAL :: igrd, ibdy, jpk_bdy ! grid type, set number and number of vertical levels in the bdy data 718 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 719 INTEGER :: jpkm1_bdy! number of vertical levels in the bdy data minus 1 720 !! 721 INTEGER :: ipi ! length of boundary data on local process 722 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 723 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 724 INTEGER :: ilendta ! length of data in file 725 INTEGER :: idvar ! variable ID 726 INTEGER :: ib, ik, ji, jj ! loop counters 727 INTEGER :: ierr 728 REAL(wp) :: fv ! fillvalue 729 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 730 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_z ! work space for global data 731 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_dz ! work space for global data 732 !!--------------------------------------------------------------------- 733 ! 734 ipi = SIZE( dta, 1 ) 735 ipj = 1 736 ipk = SIZE( dta, 3 ) 737 ! 738 idvar = iom_varid( num, clvar ) 739 ilendta = iom_file(num)%dimsz(1,idvar) 740 741 IF ( ln_bdy ) THEN 742 ipj = iom_file(num)%dimsz(2,idvar) 743 IF( map%ll_unstruc) THEN ! unstructured open boundary data file 744 dta_read => dta_global 745 IF( PRESENT(jpk_bdy) ) THEN 746 IF( jpk_bdy>0 ) THEN 747 dta_read_z => dta_global_z 748 dta_read_dz => dta_global_dz 749 jpkm1_bdy = jpk_bdy-1 750 ENDIF 751 ENDIF 752 ELSE ! structured open boundary file 753 dta_read => dta_global2 754 IF( PRESENT(jpk_bdy) ) THEN 755 IF( jpk_bdy>0 ) THEN 756 dta_read_z => dta_global2_z 757 dta_read_dz => dta_global2_dz 758 jpkm1_bdy = jpk_bdy-1 759 ENDIF 760 ENDIF 761 ENDIF 762 ENDIF 763 764 IF(lwp) WRITE(numout,*) 'Dim size for ', TRIM(clvar),' is ', ilendta 765 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 766 ! 767 SELECT CASE( ipk ) 768 CASE(1) ; 769 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) 770 IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 771 DO ib = 1, ipi 772 DO ik = 1, ipk 773 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ik) 774 END DO 775 END DO 776 ELSE ! we assume that this is a structured open boundary file 777 DO ib = 1, ipi 778 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 779 ji=map%ptr(ib)-(jj-1)*ilendta 780 DO ik = 1, ipk 781 dta(ib,1,ik) = dta_read(ji,jj,ik) 782 END DO 783 END DO 784 ENDIF 686 INTEGER , INTENT(in ) :: knum ! stream number 687 CHARACTER(LEN=*) , INTENT(in ) :: cdvar ! variable name 688 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid 689 INTEGER , INTENT(in ) :: krec ! record number to read (ie time slice) 690 INTEGER , DIMENSION(:) , INTENT(in ) :: kmap ! global-to-local bdy mapping indices 691 ! optional variables used for vertical interpolation: 692 INTEGER, OPTIONAL , INTENT(in ) :: kgrd ! grid type (t, u, v) 693 INTEGER, OPTIONAL , INTENT(in ) :: kbdy ! bdy number 694 LOGICAL, OPTIONAL , INTENT(in ) :: ldtotvel ! true if total ( = barotrop + barocline) velocity 695 LOGICAL, OPTIONAL , INTENT(in ) :: ldzint ! true if 3D variable requires a vertical interpolation 696 !! 697 INTEGER :: ipi ! length of boundary data on local process 698 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 699 INTEGER :: ipk ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 700 INTEGER :: ipkb ! number of vertical levels in boundary data file 701 INTEGER :: idvar ! variable ID 702 INTEGER :: indims ! number of dimensions of the variable 703 INTEGER, DIMENSION(4) :: idimsz ! size of variable dimensions 704 REAL(wp) :: zfv ! fillvalue 705 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data 706 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation 707 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation 708 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation 709 CHARACTER(LEN=1),DIMENSION(3) :: clgrid 710 LOGICAL :: lluld ! is the variable using the unlimited dimension 711 LOGICAL :: llzint ! local value of ldzint 712 !!--------------------------------------------------------------------- 713 ! 714 clgrid = (/'t','u','v'/) 715 ! 716 ipi = SIZE( pdta, 1 ) 717 ipj = SIZE( pdta, 2 ) ! must be equal to 1 718 ipk = SIZE( pdta, 3 ) 719 ! 720 llzint = .FALSE. 721 IF( PRESENT(ldzint) ) llzint = ldzint 722 ! 723 idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld ) 724 IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipkb = idimsz(3) ! xy(zl)t or xy(zl) 725 ELSE ; ipkb = 1 ! xy or xyt 726 ENDIF 727 ! 728 ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) ) ! ++++++++ !!! this can be very big... 729 ! 730 IF( ipk == 1 ) THEN 731 732 IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) 733 CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec ) ! call iom_get with a 2D file 734 CALL fld_map_core( zz_read, kmap, pdta ) 785 735 786 736 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 787 737 ! Do we include something here to adjust barotropic velocities ! 788 738 ! in case of a depth difference between bdy files and ! 789 ! bathymetry in the case ln_ full_vel = .false. and jpk_bdy>0?!739 ! bathymetry in the case ln_totvel = .false. and ipkb>0? ! 790 740 ! [as the enveloping and parital cells could change H] ! 791 741 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 792 742 793 CASE DEFAULT ; 794 795 IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN ! boundary data not on model grid: vertical interpolation 796 CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 797 dta_read(:,:,:) = -ABS(fv) 798 dta_read_z(:,:,:) = 0._wp 799 dta_read_dz(:,:,:) = 0._wp 800 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) 801 SELECT CASE( igrd ) 802 CASE(1) 803 CALL iom_get ( num, jpdom_unknown, 'gdept', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 804 CALL iom_get ( num, jpdom_unknown, 'e3t', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 805 CASE(2) 806 CALL iom_get ( num, jpdom_unknown, 'gdepu', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 807 CALL iom_get ( num, jpdom_unknown, 'e3u', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 808 CASE(3) 809 CALL iom_get ( num, jpdom_unknown, 'gdepv', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 810 CALL iom_get ( num, jpdom_unknown, 'e3v', dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 811 END SELECT 812 813 IF ( ln_bdy ) & 814 CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta) 815 816 ELSE ! boundary data assumed to be on model grid 817 818 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec ) 819 IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 820 DO ib = 1, ipi 821 DO ik = 1, ipk 822 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ik) 823 END DO 743 ELSE 744 ! 745 CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec ) ! call iom_get with a 3D file 746 ! 747 IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation 748 ! 749 IF( ipk == jpk .AND. iom_varid(knum,'gdep'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN 750 751 ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) 752 753 CALL fld_map_core( zz_read, kmap, zdta_read ) 754 CALL iom_get ( knum, jpdom_unknown, 'gdep'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution? 755 CALL fld_map_core( zz_read, kmap, zdta_read_z ) 756 CALL iom_get ( knum, jpdom_unknown, 'e3'//clgrid(kgrd), zz_read ) ! read only once? Potential temporal evolution? 757 CALL fld_map_core( zz_read, kmap, zdta_read_dz ) 758 759 CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) 760 CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel) 761 DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) 762 763 ELSE 764 IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) 765 WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires ' 766 IF( iom_varid(knum, 'gdep'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' ) 767 IF( iom_varid(knum, 'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//clgrid(kgrd)//' variable' ) 768 769 ENDIF 770 ! 771 ELSE ! bdy data assumed to be the same levels as bdy variables 772 ! 773 CALL fld_map_core( zz_read, kmap, pdta ) 774 ! 775 ENDIF ! ipkb /= ipk 776 ENDIF ! ipk == 1 777 778 DEALLOCATE( zz_read ) 779 780 END SUBROUTINE fld_map 781 782 783 SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) 784 !!--------------------------------------------------------------------- 785 !! *** ROUTINE fld_map_core *** 786 !! 787 !! ** Purpose : inner core of fld_map 788 !!---------------------------------------------------------------------- 789 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data 790 INTEGER, DIMENSION(: ), INTENT(in ) :: kmap ! global-to-local bdy mapping indices 791 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid 792 !! 793 INTEGER, DIMENSION(3) :: idim_read, idim_bdy ! arrays dimensions 794 INTEGER :: ji, jj, jk, jb ! loop counters 795 INTEGER :: im1 796 !!--------------------------------------------------------------------- 797 ! 798 idim_read = SHAPE( pdta_read ) 799 idim_bdy = SHAPE( pdta_bdy ) 800 ! 801 ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) 802 ! structured BDY with rimwidth > 1 : idim_read(2) == rimwidth /= 1 803 ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 804 ! 805 IF( idim_read(2) > 1 ) THEN ! structured BDY with rimwidth > 1 806 DO jk = 1, idim_bdy(3) 807 DO jb = 1, idim_bdy(1) 808 im1 = kmap(jb) - 1 809 jj = im1 / idim_read(1) + 1 810 ji = MOD( im1, idim_read(1) ) + 1 811 pdta_bdy(jb,1,jk) = pdta_read(ji,jj,jk) 824 812 END DO 825 ELSE ! we assume that this is a structured open boundary file 826 DO ib = 1, ipi 827 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 828 ji=map%ptr(ib)-(jj-1)*ilendta 829 DO ik = 1, ipk 830 dta(ib,1,ik) = dta_read(ji,jj,ik) 831 END DO 813 END DO 814 ELSE 815 DO jk = 1, idim_bdy(3) 816 DO jb = 1, idim_bdy(1) ! horizontal remap of bdy data on the local bdy 817 pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) 832 818 END DO 833 ENDIF 834 ENDIF ! PRESENT(jpk_bdy) 835 END SELECT 836 837 END SUBROUTINE fld_map 819 END DO 820 ENDIF 821 822 END SUBROUTINE fld_map_core 838 823 839 SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta)840 824 825 SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel) 841 826 !!--------------------------------------------------------------------- 842 827 !! *** ROUTINE fld_bdy_interp *** … … 847 832 USE bdy_oce, ONLY: idx_bdy ! indexing for map <-> ij transformation 848 833 849 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read ! work space for global data 850 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_z ! work space for global data 851 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_dz ! work space for global data 852 REAL(wp) , INTENT(in) :: fv ! fillvalue and alternative -ABS(fv) 853 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 854 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 855 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 856 INTEGER , INTENT(in) :: igrd, ibdy, jpk_bdy ! number of levels in bdy data 857 INTEGER , INTENT(in) :: ilendta ! length of data in file 858 !! 859 INTEGER :: ipi ! length of boundary data on local process 860 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 861 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 862 INTEGER :: jpkm1_bdy ! number of levels in bdy data minus 1 863 INTEGER :: ib, ik, ikk ! loop counters 864 INTEGER :: ji, jj, zij, zjj ! temporary indices 865 REAL(wp) :: zl, zi, zh ! tmp variable for current depth and interpolation factor 866 REAL(wp) :: fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 867 CHARACTER (LEN=10) :: ibstr 834 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file 835 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdta_read_z ! depth of the data read in bdy file 836 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdta_read_dz ! thickness of the levels in bdy file 837 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) 838 REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file 839 LOGICAL , INTENT(in ) :: ldtotvel ! true if toal ( = barotrop + barocline) velocity 840 INTEGER , INTENT(in ) :: kgrd ! grid type (t, u, v) 841 INTEGER , INTENT(in ) :: kbdy ! bdy number 842 !! 843 INTEGER :: ipi ! length of boundary data on local process 844 INTEGER :: ipkb ! number of vertical levels in boundary data file 845 INTEGER :: jb, ji, jj, jk, jkb ! loop counters 846 REAL(wp) :: zcoef 847 REAL(wp) :: zl, zi, zh ! tmp variable for current depth and interpolation factor 848 REAL(wp) :: zfv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(pfv) 849 REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth 868 850 !!--------------------------------------------------------------------- 869 851 870 871 ipi = SIZE( dta, 1 ) 872 ipj = SIZE( dta_read, 2 ) 873 ipk = SIZE( dta, 3 ) 874 jpkm1_bdy = jpk_bdy-1 852 ipi = SIZE( pdta, 1 ) 853 ipkb = SIZE( pdta_read, 3 ) 875 854 876 fv_alt = -ABS(fv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 877 DO ib = 1, ipi 878 zij = idx_bdy(ibdy)%nbi(ib,igrd) 879 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 880 IF(narea==2) WRITE(*,*) 'MAPI', ib, igrd, map%ptr(ib), narea-1, zij, zjj 881 ENDDO 882 ! 883 IF ( map%ll_unstruc ) THEN ! unstructured open boundary data file 884 885 DO ib = 1, ipi 886 DO ik = 1, jpk_bdy 887 IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 888 dta_read_z(map%ptr(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 889 dta_read_dz(map%ptr(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 855 zfv_alt = -ABS(pfv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 856 ! 857 WHERE( pdta_read == pfv ) 858 pdta_read_z = zfv_alt ! safety: put fillvalue into external depth field so consistent with data 859 pdta_read_dz = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 860 ENDWHERE 861 862 DO jb = 1, ipi 863 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 864 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 865 zh = SUM(pdta_read_dz(jb,1,:) ) 866 ! 867 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 868 SELECT CASE( kgrd ) 869 CASE(1) 870 IF( ABS( (zh - ht_n(ji,jj)) / ht_n(ji,jj)) * tmask(ji,jj,1) > 0.01_wp ) THEN 871 WRITE(ctmp1,"(I10.10)") jb 872 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 873 ! IF(lwp) WRITE(numout,*) 'DEPTHT', zh, sum(e3t_n(ji,jj,:), mask=tmask(ji,jj,:)==1), ht_n(ji,jj), jb, jb, ji, jj 874 ENDIF 875 CASE(2) 876 IF( ABS( (zh - hu_n(ji,jj)) * r1_hu_n(ji,jj)) * umask(ji,jj,1) > 0.01_wp ) THEN 877 WRITE(ctmp1,"(I10.10)") jb 878 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 879 ! IF(lwp) WRITE(numout,*) 'DEPTHU', zh, SUM(e3u_n(ji,jj,:), mask=umask(ji,jj,:)==1), SUM(umask(ji,jj,:)), & 880 ! & hu_n(ji,jj), jb, jb, ji, jj, narea-1, pdta_read(jb,1,:) 881 ENDIF 882 CASE(3) 883 IF( ABS( (zh - hv_n(ji,jj)) * r1_hv_n(ji,jj)) * vmask(ji,jj,1) > 0.01_wp ) THEN 884 WRITE(ctmp1,"(I10.10)") jb 885 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 886 ENDIF 887 END SELECT 888 ! 889 SELECT CASE( kgrd ) 890 CASE(1) 891 ! depth of T points: 892 zdepth(:) = gdept_n(ji,jj,:) 893 CASE(2) 894 ! depth of U points: we must not use gdept_n as we don't want to do a communication 895 ! --> copy what is done for gdept_n in domvvl... 896 zdhalf(1) = 0.0_wp 897 zdepth(1) = 0.5_wp * e3uw_n(ji,jj,1) 898 DO jk = 2, jpk ! vertical sum 899 ! zcoef = umask - wumask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 900 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 901 ! ! 0.5 where jk = mikt 902 !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? 903 zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 904 zdhalf(jk) = zdhalf(jk-1) + e3u_n(ji,jj,jk-1) 905 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3uw_n(ji,jj,jk)) & 906 & + (1-zcoef) * ( zdepth(jk-1) + e3uw_n(ji,jj,jk)) 907 END DO 908 CASE(3) 909 ! depth of V points: we must not use gdept_n as we don't want to do a communication 910 ! --> copy what is done for gdept_n in domvvl... 911 zdhalf(1) = 0.0_wp 912 zdepth(1) = 0.5_wp * e3vw_n(ji,jj,1) 913 DO jk = 2, jpk ! vertical sum 914 ! zcoef = vmask - wvmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 915 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 916 ! ! 0.5 where jk = mikt 917 !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? 918 zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 919 zdhalf(jk) = zdhalf(jk-1) + e3v_n(ji,jj,jk-1) 920 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3vw_n(ji,jj,jk)) & 921 & + (1-zcoef) * ( zdepth(jk-1) + e3vw_n(ji,jj,jk)) 922 END DO 923 END SELECT 924 ! 925 DO jk = 1, jpk 926 IF( zdepth(jk) < pdta_read_z(jb,1, 1) ) THEN ! above the first level of external data 927 pdta(jb,1,jk) = pdta_read(jb,1,1) 928 ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkb) ) THEN ! below the last level of external data 929 pdta(jb,1,jk) = pdta_read(jb,1,MAXLOC(pdta_read_z(jb,1,:),1)) 930 ELSE ! inbetween: vertical interpolation between jkb & jkb+1 931 DO jkb = 1, ipkb-1 ! when gdept_n(jkb) < zdepth(jk) < gdept_n(jkb+1) 932 IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) <= 0._wp ) & 933 & .AND. ( pdta_read_z(jb,1,jkb+1) /= zfv_alt) ) THEN ! linear interpolation between 2 levels 934 zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) 935 pdta(jb,1,jk) = pdta_read(jb,1,jkb) + ( pdta_read (jb,1,jkb+1) - pdta_read (jb,1,jkb) ) * zi 936 ENDIF 937 END DO 938 ENDIF 939 END DO ! jpk 940 ! 941 END DO ! ipi 942 943 IF(kgrd == 2) THEN ! do we need to adjust the transport term? 944 DO jb = 1, ipi 945 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 946 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 947 zh = SUM(pdta_read_dz(jb,1,:) ) 948 ztrans = 0._wp 949 ztrans_new = 0._wp 950 DO jkb = 1, ipkb ! calculate transport on input grid 951 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 952 ENDDO 953 DO jk = 1, jpk ! calculate transport on model grid 954 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3u_n(ji,jj,jk ) * umask(ji,jj,jk) 955 ENDDO 956 DO jk = 1, jpk ! make transport correction 957 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 958 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu_n(ji,jj) ) * umask(ji,jj,jk) 959 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 960 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hu_n(ji,jj) * umask(ji,jj,jk) 890 961 ENDIF 891 962 ENDDO 892 ENDDO 893 894 DO ib = 1, ipi 895 zij = idx_bdy(ibdy)%nbi(ib,igrd) 896 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 897 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 898 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 899 SELECT CASE( igrd ) 900 CASE(1) 901 IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 902 WRITE(ibstr,"(I10.10)") map%ptr(ib) 903 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 904 ! IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1), ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 905 ENDIF 906 CASE(2) 907 IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 908 WRITE(ibstr,"(I10.10)") map%ptr(ib) 909 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 910 IF(lwp) WRITE(*,*) 'DEPTHU', zh, sum(e3u_n(zij,zjj,:), mask=umask(zij,zjj,:)==1), sum(umask(zij,zjj,:)), & 911 & hu_n(zij,zjj), map%ptr(ib), ib, zij, zjj, narea-1 , & 912 & dta_read(map%ptr(ib),1,:) 913 ENDIF 914 CASE(3) 915 IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 916 WRITE(ibstr,"(I10.10)") map%ptr(ib) 917 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 918 ENDIF 919 END SELECT 920 DO ik = 1, ipk 921 SELECT CASE( igrd ) 922 CASE(1) 923 zl = gdept_n(zij,zjj,ik) ! if using in step could use fsdept instead of gdept_n? 924 CASE(2) 925 IF(ln_sco) THEN 926 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 927 ELSE 928 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 929 ENDIF 930 CASE(3) 931 IF(ln_sco) THEN 932 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 933 ELSE 934 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 935 ENDIF 936 END SELECT 937 IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN ! above the first level of external data 938 dta(ib,1,ik) = dta_read(map%ptr(ib),1,1) 939 ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN ! below the last level of external data 940 dta(ib,1,ik) = dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 941 ELSE ! inbetween : vertical interpolation between ikk & ikk+1 942 DO ikk = 1, jpkm1_bdy ! when gdept_n(ikk) < zl < gdept_n(ikk+1) 943 IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) & 944 & .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 945 zi = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / & 946 & ( dta_read_z(map%ptr(ib),1,ikk+1) - dta_read_z(map%ptr(ib),1,ikk) ) 947 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 948 & ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi 949 ENDIF 950 END DO 951 ENDIF 952 END DO 953 END DO 954 955 IF(igrd == 2) THEN ! do we need to adjust the transport term? 956 DO ib = 1, ipi 957 zij = idx_bdy(ibdy)%nbi(ib,igrd) 958 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 959 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 960 ztrans = 0._wp 961 ztrans_new = 0._wp 962 DO ik = 1, jpk_bdy ! calculate transport on input grid 963 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 964 ENDDO 965 DO ik = 1, ipk ! calculate transport on model grid 966 ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 967 ENDDO 968 DO ik = 1, ipk ! make transport correction 969 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 970 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 971 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 972 IF( ABS(ztrans * r1_hu_n(zij,zjj)) > 0.01_wp ) & 973 & CALL ctl_warn('fld_bdy_interp: barotropic component of > 0.01 ms-1 found in baroclinic velocities at') 974 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) * umask(zij,zjj,ik) 975 ENDIF 976 ENDDO 963 ENDDO 964 ENDIF 965 966 IF(kgrd == 3) THEN ! do we need to adjust the transport term? 967 DO jb = 1, ipi 968 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 969 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 970 zh = SUM(pdta_read_dz(jb,1,:) ) 971 ztrans = 0._wp 972 ztrans_new = 0._wp 973 DO jkb = 1, ipkb ! calculate transport on input grid 974 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 977 975 ENDDO 978 ENDIF 979 980 IF(igrd == 3) THEN ! do we need to adjust the transport term? 981 DO ib = 1, ipi 982 zij = idx_bdy(ibdy)%nbi(ib,igrd) 983 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 984 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 985 ztrans = 0._wp 986 ztrans_new = 0._wp 987 DO ik = 1, jpk_bdy ! calculate transport on input grid 988 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 989 ENDDO 990 DO ik = 1, ipk ! calculate transport on model grid 991 ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 992 ENDDO 993 DO ik = 1, ipk ! make transport correction 994 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 995 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 996 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 997 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) * vmask(zij,zjj,ik) 998 ENDIF 999 ENDDO 976 DO jk = 1, jpk ! calculate transport on model grid 977 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3v_n(ji,jj,jk ) * vmask(ji,jj,jk) 1000 978 ENDDO 1001 ENDIF 1002 1003 ELSE ! structured open boundary file 1004 1005 DO ib = 1, ipi 1006 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1007 ji=map%ptr(ib)-(jj-1)*ilendta 1008 DO ik = 1, jpk_bdy 1009 IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 1010 dta_read_z(ji,jj,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 1011 dta_read_dz(ji,jj,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 979 DO jk = 1, jpk ! make transport correction 980 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 981 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv_n(ji,jj) ) * vmask(ji,jj,jk) 982 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 983 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hv_n(ji,jj) * vmask(ji,jj,jk) 1012 984 ENDIF 1013 985 ENDDO 1014 ENDDO 1015 1016 1017 DO ib = 1, ipi 1018 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1019 ji=map%ptr(ib)-(jj-1)*ilendta 1020 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1021 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1022 zh = SUM(dta_read_dz(ji,jj,:) ) 1023 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 1024 SELECT CASE( igrd ) 1025 CASE(1) 1026 IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 1027 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1028 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1029 ! IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1), ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 1030 ENDIF 1031 CASE(2) 1032 IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 1033 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1034 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1035 ENDIF 1036 CASE(3) 1037 IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 1038 WRITE(ibstr,"(I10.10)") map%ptr(ib) 1039 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 1040 ENDIF 1041 END SELECT 1042 DO ik = 1, ipk 1043 SELECT CASE( igrd ) ! coded for sco - need zco and zps option using min 1044 CASE(1) 1045 zl = gdept_n(zij,zjj,ik) ! if using in step could use fsdept instead of gdept_n? 1046 CASE(2) 1047 IF(ln_sco) THEN 1048 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 1049 ELSE 1050 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 1051 ENDIF 1052 CASE(3) 1053 IF(ln_sco) THEN 1054 zl = ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp ! if using in step could use fsdept instead of gdept_n? 1055 ELSE 1056 zl = MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 1057 ENDIF 1058 END SELECT 1059 IF( zl < dta_read_z(ji,jj,1) ) THEN ! above the first level of external data 1060 dta(ib,1,ik) = dta_read(ji,jj,1) 1061 ELSEIF( zl > MAXVAL(dta_read_z(ji,jj,:),1) ) THEN ! below the last level of external data 1062 dta(ib,1,ik) = dta_read(ji,jj,MAXLOC(dta_read_z(ji,jj,:),1)) 1063 ELSE ! inbetween : vertical interpolation between ikk & ikk+1 1064 DO ikk = 1, jpkm1_bdy ! when gdept_n(ikk) < zl < gdept_n(ikk+1) 1065 IF( ( (zl-dta_read_z(ji,jj,ikk)) * (zl-dta_read_z(ji,jj,ikk+1)) <= 0._wp) & 1066 & .AND. (dta_read_z(ji,jj,ikk+1) /= fv_alt)) THEN 1067 zi = ( zl - dta_read_z(ji,jj,ikk) ) / & 1068 & ( dta_read_z(ji,jj,ikk+1) - dta_read_z(ji,jj,ikk) ) 1069 dta(ib,1,ik) = dta_read(ji,jj,ikk) + & 1070 & ( dta_read(ji,jj,ikk+1) - dta_read(ji,jj,ikk) ) * zi 1071 ENDIF 1072 END DO 1073 ENDIF 1074 END DO 1075 END DO 1076 1077 IF(igrd == 2) THEN ! do we need to adjust the transport term? 1078 DO ib = 1, ipi 1079 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1080 ji=map%ptr(ib)-(jj-1)*ilendta 1081 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1082 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1083 zh = SUM(dta_read_dz(ji,jj,:) ) 1084 ztrans = 0._wp 1085 ztrans_new = 0._wp 1086 DO ik = 1, jpk_bdy ! calculate transport on input grid 1087 ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 1088 ENDDO 1089 DO ik = 1, ipk ! calculate transport on model grid 1090 ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 1091 ENDDO 1092 DO ik = 1, ipk ! make transport correction 1093 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 1094 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 1095 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 1096 dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 1097 ENDIF 1098 ENDDO 1099 ENDDO 1100 ENDIF 1101 1102 IF(igrd == 3) THEN ! do we need to adjust the transport term? 1103 DO ib = 1, ipi 1104 jj = 1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 1105 ji = map%ptr(ib)-(jj-1)*ilendta 1106 zij = idx_bdy(ibdy)%nbi(ib,igrd) 1107 zjj = idx_bdy(ibdy)%nbj(ib,igrd) 1108 zh = SUM(dta_read_dz(ji,jj,:) ) 1109 ztrans = 0._wp 1110 ztrans_new = 0._wp 1111 DO ik = 1, jpk_bdy ! calculate transport on input grid 1112 ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 1113 ENDDO 1114 DO ik = 1, ipk ! calculate transport on model grid 1115 ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 1116 ENDDO 1117 DO ik = 1, ipk ! make transport correction 1118 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 1119 dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 1120 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 1121 dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 1122 ENDIF 1123 ENDDO 1124 ENDDO 1125 ENDIF 1126 1127 ENDIF ! endif unstructured or structured 1128 986 ENDDO 987 ENDIF 988 1129 989 END SUBROUTINE fld_bdy_interp 1130 990 … … 1151 1011 imf = SIZE( sd ) 1152 1012 DO ju = 1, imf 1013 IF( TRIM(sd(ju)%clrootname) == 'NOT USED' ) CYCLE 1153 1014 ill = LEN_TRIM( sd(ju)%vcomp ) 1154 1015 DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 … … 1159 1020 iv = -1 1160 1021 DO jv = 1, imf 1022 IF( TRIM(sd(jv)%clrootname) == 'NOT USED' ) CYCLE 1161 1023 IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) ) iv = jv 1162 1024 END DO … … 1197 1059 LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 1198 1060 ! 1199 LOGICAL :: llprevyr ! are we reading previous year file?1200 LOGICAL :: llprevmth ! are we reading previous month file?1201 INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd1202 INTEGER :: isec_week ! number of seconds since start of the weekly file1203 INTEGER :: indexyr ! year undex (O/1/2: previous/current/next)1204 INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth !1205 CHARACTER(len = 256) :: clname ! temporary file name1061 LOGICAL :: llprevyr ! are we reading previous year file? 1062 LOGICAL :: llprevmth ! are we reading previous month file? 1063 INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd 1064 INTEGER :: isec_week ! number of seconds since start of the weekly file 1065 INTEGER :: indexyr ! year undex (O/1/2: previous/current/next) 1066 REAL(wp) :: zyear_len, zmonth_len ! length (days) of iyear and imonth ! 1067 CHARACTER(len = 256) :: clname ! temporary file name 1206 1068 !!---------------------------------------------------------------------- 1207 1069 IF( PRESENT(kyear) ) THEN ! use given values … … 1254 1116 ! find the last record to be read -> update sdjf%nreclast 1255 1117 indexyr = iyear - nyear + 1 1256 iyear_len = nyear_len( indexyr)1118 zyear_len = REAL(nyear_len( indexyr ), wp) 1257 1119 SELECT CASE ( indexyr ) 1258 CASE ( 0 ) ; imonth_len = 31! previous year -> imonth = 121259 CASE ( 1 ) ; imonth_len = nmonth_len(imonth)1260 CASE ( 2 ) ; imonth_len = 31! next year -> imonth = 11120 CASE ( 0 ) ; zmonth_len = 31. ! previous year -> imonth = 12 1121 CASE ( 1 ) ; zmonth_len = REAL(nmonth_len(imonth), wp) 1122 CASE ( 2 ) ; zmonth_len = 31. ! next year -> imonth = 1 1261 1123 END SELECT 1262 1124 ! 1263 1125 ! last record to be read in the current file 1264 IF ( sdjf% nfreqh == -12) THEN ; sdjf%nreclast = 1 ! yearly mean1265 ELSEIF( sdjf% nfreqh == -1) THEN ! monthly mean1126 IF ( sdjf%freqh == -12. ) THEN ; sdjf%nreclast = 1 ! yearly mean 1127 ELSEIF( sdjf%freqh == -1. ) THEN ! monthly mean 1266 1128 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = 1 1267 1129 ELSE ; sdjf%nreclast = 12 1268 1130 ENDIF 1269 1131 ELSE ! higher frequency mean (in hours) 1270 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = NINT( 24 * imonth_len / sdjf%nfreqh )1271 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = NINT( 24 * 7 / sdjf%nfreqh )1272 ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = NINT( 24 / sdjf%nfreqh )1273 ELSE ; sdjf%nreclast = NINT( 24 * iyear_len / sdjf%nfreqh )1132 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = NINT( 24. * zmonth_len / sdjf%freqh ) 1133 ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = NINT( 24. * 7. / sdjf%freqh ) 1134 ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = NINT( 24. / sdjf%freqh ) 1135 ELSE ; sdjf%nreclast = NINT( 24. * zyear_len / sdjf%freqh ) 1274 1136 ENDIF 1275 1137 ENDIF … … 1299 1161 ! 1300 1162 DO jf = 1, SIZE(sdf) 1301 sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname ) 1163 sdf(jf)%clrootname = sdf_n(jf)%clname 1164 IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' ) sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname 1302 1165 sdf(jf)%clname = "not yet defined" 1303 sdf(jf)% nfreqh = sdf_n(jf)%nfreqh1166 sdf(jf)%freqh = sdf_n(jf)%freqh 1304 1167 sdf(jf)%clvar = sdf_n(jf)%clvar 1305 1168 sdf(jf)%ln_tint = sdf_n(jf)%ln_tint … … 1308 1171 sdf(jf)%num = -1 1309 1172 sdf(jf)%wgtname = " " 1310 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )// TRIM( sdf_n(jf)%wname )1173 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname 1311 1174 sdf(jf)%lsmname = " " 1312 IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )// TRIM( sdf_n(jf)%lname )1175 IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname 1313 1176 sdf(jf)%vcomp = sdf_n(jf)%vcomp 1314 1177 sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get … … 1317 1180 IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim ) & 1318 1181 & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') 1319 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 1182 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 1183 sdf(jf)%igrd = 0 1184 sdf(jf)%ibdy = 0 1185 sdf(jf)%imap => NULL() 1186 sdf(jf)%ltotvel = .FALSE. 1187 sdf(jf)%lzint = .FALSE. 1320 1188 END DO 1321 1189 ! … … 1331 1199 DO jf = 1, SIZE(sdf) 1332 1200 WRITE(numout,*) ' root filename: ' , TRIM( sdf(jf)%clrootname ), ' variable name: ', TRIM( sdf(jf)%clvar ) 1333 WRITE(numout,*) ' frequency: ' , sdf(jf)% nfreqh, &1201 WRITE(numout,*) ' frequency: ' , sdf(jf)%freqh , & 1334 1202 & ' time interp: ' , sdf(jf)%ln_tint , & 1335 1203 & ' climatology: ' , sdf(jf)%ln_clim -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcapr.F90
r11204 r12143 71 71 REWIND( numnam_ref ) ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing 72 72 READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) 73 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' , lwp)73 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) 74 74 75 75 REWIND( numnam_cfg ) ! Namelist namsbc_apr in configuration namelist : File for atmospheric pressure forcing 76 76 READ ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 ) 77 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' , lwp)77 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' ) 78 78 IF(lwm) WRITE ( numond, namsbc_apr ) 79 79 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcblk.F90
r10535 r12143 182 182 REWIND( numnam_ref ) !* Namelist namsbc_blk in reference namelist : bulk parameters 183 183 READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) 184 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' , lwp)184 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) 185 185 ! 186 186 REWIND( numnam_cfg ) !* Namelist namsbc_blk in configuration namelist : bulk parameters 187 187 READ ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) 188 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' , lwp)188 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) 189 189 ! 190 190 IF(lwm) WRITE( numond, namsbc_blk ) … … 201 201 ! 202 202 IF( ln_dm2dc ) THEN !* check: diurnal cycle on Qsr 203 IF( sn_qsr% nfreqh /= 24) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' )203 IF( sn_qsr%freqh /= 24. ) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) 204 204 IF( sn_qsr%ln_tint ) THEN 205 205 CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module', & … … 225 225 ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) 226 226 IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 227 IF( slf_i(ifpr)% nfreqh > 0. .AND. MOD( 3600. * slf_i(ifpr)%nfreqh , REAL(nn_fsbc) * rdt) /= 0.) &227 IF( slf_i(ifpr)%freqh > 0. .AND. MOD( NINT(3600. * slf_i(ifpr)%freqh), nn_fsbc * NINT(rdt) ) /= 0 ) & 228 228 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & 229 229 & ' This is not ideal. You should consider changing either rdt or nn_fsbc value...' ) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbccpl.F90
r11987 r12143 266 266 REWIND( numnam_ref ) ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling 267 267 READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) 268 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' , lwp)268 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) 269 269 ! 270 270 REWIND( numnam_cfg ) ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling 271 271 READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 ) 272 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' , lwp)272 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' ) 273 273 IF(lwm) WRITE ( numond, namsbc_cpl ) 274 274 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcflx.F90
r10425 r12143 93 93 REWIND( numnam_ref ) ! Namelist namsbc_flx in reference namelist : Files for fluxes 94 94 READ ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) 95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' , lwp)95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) 96 96 97 97 REWIND( numnam_cfg ) ! Namelist namsbc_flx in configuration namelist : Files for fluxes 98 98 READ ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 ) 99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' , lwp)99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' ) 100 100 IF(lwm) WRITE ( numond, namsbc_flx ) 101 101 ! 102 102 ! ! check: do we plan to use ln_dm2dc with non-daily forcing? 103 IF( ln_dm2dc .AND. sn_qsr% nfreqh /= 24) &103 IF( ln_dm2dc .AND. sn_qsr%freqh /= 24. ) & 104 104 & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) 105 105 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcice_cice.F90
r10425 r12143 764 764 REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : 765 765 READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 766 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' , lwp)766 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) 767 767 768 768 REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run 769 769 READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 770 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' , lwp)770 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) 771 771 IF(lwm) WRITE ( numond, namsbc_cice ) 772 772 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcice_if.F90
r10068 r12143 76 76 REWIND( numnam_ref ) ! Namelist namsbc_iif in reference namelist : Ice if file 77 77 READ ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) 78 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' , lwp)78 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) 79 79 80 80 REWIND( numnam_cfg ) ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file 81 81 READ ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) 82 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' , lwp)82 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) 83 83 IF(lwm) WRITE ( numond, namsbc_iif ) 84 84 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcmod.F90
r11489 r12143 108 108 REWIND( numnam_ref ) !* Namelist namsbc in reference namelist : Surface boundary 109 109 READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) 110 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' , lwp)110 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) 111 111 REWIND( numnam_cfg ) !* Namelist namsbc in configuration namelist : Parameters of the run 112 112 READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 113 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' , lwp)113 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) 114 114 IF(lwm) WRITE( numond, namsbc ) 115 115 ! … … 299 299 ! 300 300 ! !* check consistency between model timeline and nn_fsbc 301 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. & 302 MOD( nstock , nn_fsbc) /= 0 ) THEN 303 WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock, & 304 & ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 305 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 301 IF( ln_rst_list .OR. nn_stock /= -1 ) THEN ! we will do restart files 302 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN 303 WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 304 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 305 ENDIF 306 IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN ! we don't use nn_stock if ln_rst_list 307 WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 308 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 309 ENDIF 306 310 ENDIF 307 311 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcrnf.F90
r11987 r12143 263 263 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs 264 264 READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) 265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' , lwp)265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) 266 266 267 267 REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs 268 268 READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) 269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' , lwp)269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) 270 270 IF(lwm) WRITE ( numond, namsbc_rnf ) 271 271 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcssr.F90
r10068 r12143 166 166 REWIND( numnam_ref ) ! Namelist namsbc_ssr in reference namelist : 167 167 READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) 168 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' , lwp)168 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) 169 169 170 170 REWIND( numnam_cfg ) ! Namelist namsbc_ssr in configuration namelist : 171 171 READ ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 ) 172 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' , lwp)172 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' ) 173 173 IF(lwm) WRITE ( numond, namsbc_ssr ) 174 174 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcwave.F90
r10425 r12143 397 397 REWIND( numnam_ref ) ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model 398 398 READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 399 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' , lwp)399 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) 400 400 401 401 REWIND( numnam_cfg ) ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model 402 402 READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 403 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' , lwp)403 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 404 404 IF(lwm) WRITE ( numond, namsbc_wave ) 405 405 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/tideini.F90
r10068 r12143 60 60 REWIND( numnam_ref ) ! Namelist nam_tide in reference namelist : Tides 61 61 READ ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) 62 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' , lwp)62 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) 63 63 ! 64 64 REWIND( numnam_cfg ) ! Namelist nam_tide in configuration namelist : Tides 65 65 READ ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) 66 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' , lwp)66 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) 67 67 IF(lwm) WRITE ( numond, nam_tide ) 68 68 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/SBC/updtide.F90
r10068 r12143 27 27 CONTAINS 28 28 29 SUBROUTINE upd_tide( kt, kit, time_offset )29 SUBROUTINE upd_tide( kt, kit, kt_offset ) 30 30 !!---------------------------------------------------------------------- 31 31 !! *** ROUTINE upd_tide *** … … 39 39 INTEGER, INTENT(in) :: kt ! ocean time-step index 40 40 INTEGER, INTENT(in), OPTIONAL :: kit ! external mode sub-time-step index (lk_dynspg_ts=T) 41 INTEGER, INTENT(in), OPTIONAL :: time_offset ! time offset in number41 INTEGER, INTENT(in), OPTIONAL :: kt_offset ! time offset in number 42 42 ! of internal steps (lk_dynspg_ts=F) 43 43 ! of external steps (lk_dynspg_ts=T) 44 44 ! 45 INTEGER :: joffset ! local integer45 INTEGER :: ioffset ! local integer 46 46 INTEGER :: ji, jj, jk ! dummy loop indices 47 47 REAL(wp) :: zt, zramp ! local scalar … … 52 52 zt = ( kt - kt_tide ) * rdt 53 53 ! 54 joffset = 055 IF( PRESENT( time_offset ) ) joffset = time_offset54 ioffset = 0 55 IF( PRESENT( kt_offset ) ) ioffset = kt_offset 56 56 ! 57 57 IF( PRESENT( kit ) ) THEN 58 zt = zt + ( kit + joffset - 1 ) * rdt / REAL( nn_baro, wp )58 zt = zt + ( kit + ioffset - 1 ) * rdt / REAL( nn_baro, wp ) 59 59 ELSE 60 zt = zt + joffset * rdt60 zt = zt + ioffset * rdt 61 61 ENDIF 62 62 ! … … 70 70 IF( ln_tide_ramp ) THEN ! linear increase if asked 71 71 zt = ( kt - nit000 ) * rdt 72 IF( PRESENT( kit ) ) zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp )72 IF( PRESENT( kit ) ) zt = zt + ( kit + ioffset -1) * rdt / REAL( nn_baro, wp ) 73 73 zramp = MIN( MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp ) 74 74 pot_astro(:,:) = zramp * pot_astro(:,:) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/STO/stopar.F90
r10425 r12143 263 263 REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 264 264 READ ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) 265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' , lwp)265 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) 266 266 267 267 REWIND( numnam_cfg ) ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 268 268 READ ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 ) 269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' , lwp)269 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' ) 270 270 IF(lwm) WRITE ( numond, namsto ) 271 271 272 IF( .NOT.ln_ rststo) THEN ! no use of stochastic parameterization272 IF( .NOT.ln_sto_eos ) THEN ! no use of stochastic parameterization 273 273 IF(lwp) THEN 274 274 WRITE(numout,*) … … 750 750 CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name 751 751 CHARACTER(LEN=10) :: clseed='seed0_0000' ! seed variable name 752 752 !!---------------------------------------------------------------------- 753 754 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 755 753 756 IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN 754 757 … … 790 793 ! Open the restart file one timestep before writing restart 791 794 IF( kt < nitend) THEN 792 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. kt == nitend-1 ) THEN795 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. kt == nitend-1 ) THEN 793 796 ! create the filename 794 797 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/eosbn2.F90
r10425 r12143 30 30 !! eos_insitu_2d : Compute the in situ density for 2d fields 31 31 !! bn2 : Compute the Brunt-Vaisala frequency 32 !! bn2 : compute the Brunt-Vaisala frequency 33 !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature 32 34 !! eos_rab : generic interface of in situ thermal/haline expansion ratio 33 35 !! eos_rab_3d : compute in situ thermal/haline expansion ratio … … 74 76 75 77 ! !!** Namelist nameos ** 76 LOGICAL , PUBLIC :: ln_TEOS10 ! determine if eos_pt_from_ct is used to compute sst_m77 LOGICAL , PUBLIC :: ln_EOS80 ! determine if eos_pt_from_ct is used to compute sst_m78 LOGICAL , PUBLIC :: ln_SEOS ! determine if eos_pt_from_ct is used to compute sst_m78 LOGICAL , PUBLIC :: ln_TEOS10 79 LOGICAL , PUBLIC :: ln_EOS80 80 LOGICAL , PUBLIC :: ln_SEOS 79 81 80 82 ! Parameters … … 1235 1237 REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state 1236 1238 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 1237 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' , lwp)1239 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) 1238 1240 ! 1239 1241 REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state 1240 1242 READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 1241 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' , lwp)1243 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' ) 1242 1244 IF(lwm) WRITE( numond, nameos ) 1243 1245 ! … … 1647 1649 ! 1648 1650 CASE( np_seos ) !== Simplified EOS ==! 1651 1652 r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) 1653 1649 1654 IF(lwp) THEN 1650 1655 WRITE(numout,*) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/traadv.F90
r10068 r12143 196 196 REWIND( numnam_ref ) ! Namelist namtra_adv in reference namelist : Tracer advection scheme 197 197 READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 198 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' , lwp)198 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) 199 199 ! 200 200 REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 201 201 READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 202 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' , lwp)202 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) 203 203 IF(lwm) WRITE( numond, namtra_adv ) 204 204 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/traadv_fct.F90
r10425 r12143 21 21 USE diaar5 ! AR5 diagnostics 22 22 USE phycst , ONLY : rau0_rcp 23 USE zdf_oce , ONLY : ln_zad_Aimp 23 24 ! 24 25 USE in_out_manager ! I/O manager … … 86 87 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 87 88 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 89 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup 90 LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection 88 91 !!---------------------------------------------------------------------- 89 92 ! … … 97 100 l_hst = .FALSE. 98 101 l_ptr = .FALSE. 102 ll_zAimp = .FALSE. 99 103 IF( ( cdtype =='TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 100 104 IF( cdtype =='TRA' .AND. ln_diaptr ) l_ptr = .TRUE. … … 116 120 ! 117 121 zwi(:,:,:) = 0._wp 122 ! 123 ! If adaptive vertical advection, check if it is needed on this PE at this time 124 IF( ln_zad_Aimp ) THEN 125 IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. 126 END IF 127 ! If active adaptive vertical advection, build tridiagonal matrix 128 IF( ll_zAimp ) THEN 129 ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 130 DO jk = 1, jpkm1 131 DO jj = 2, jpjm1 132 DO ji = fs_2, fs_jpim1 ! vector opt. (ensure same order of calculation as below if wi=0.) 133 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t_a(ji,jj,jk) 134 zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t_a(ji,jj,jk) 135 zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t_a(ji,jj,jk) 136 END DO 137 END DO 138 END DO 139 END IF 118 140 ! 119 141 DO jn = 1, kjpt !== loop over the tracers ==! … … 169 191 END DO 170 192 END DO 193 194 IF ( ll_zAimp ) THEN 195 CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) 196 ! 197 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 198 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 199 DO jj = 2, jpjm1 200 DO ji = fs_2, fs_jpim1 ! vector opt. 201 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 202 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 203 ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 204 zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 205 END DO 206 END DO 207 END DO 208 DO jk = 1, jpkm1 209 DO jj = 2, jpjm1 210 DO ji = fs_2, fs_jpim1 ! vector opt. 211 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 212 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 213 END DO 214 END DO 215 END DO 216 ! 217 END IF 171 218 ! 172 219 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) … … 277 324 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 278 325 ENDIF 326 ! 327 IF ( ll_zAimp ) THEN 328 DO jk = 1, jpkm1 !* trend and after field with monotonic scheme 329 DO jj = 2, jpjm1 330 DO ji = fs_2, fs_jpim1 ! vector opt. 331 ! ! total intermediate advective trends 332 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 333 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 334 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 335 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 336 END DO 337 END DO 338 END DO 339 ! 340 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 341 ! 342 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 343 DO jj = 2, jpjm1 344 DO ji = fs_2, fs_jpim1 ! vector opt. 345 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 346 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 347 zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 348 END DO 349 END DO 350 END DO 351 END IF 279 352 ! 280 353 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1. ) … … 289 362 DO jj = 2, jpjm1 290 363 DO ji = fs_2, fs_jpim1 ! vector opt. 291 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 292 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 293 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & 294 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 295 END DO 296 END DO 297 END DO 364 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 365 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 366 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 367 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) 368 zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 369 END DO 370 END DO 371 END DO 372 ! 373 IF ( ll_zAimp ) THEN 374 ! 375 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 376 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 377 DO jj = 2, jpjm1 378 DO ji = fs_2, fs_jpim1 ! vector opt. 379 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 380 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 381 ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 382 zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 383 END DO 384 END DO 385 END DO 386 DO jk = 1, jpkm1 387 DO jj = 2, jpjm1 388 DO ji = fs_2, fs_jpim1 ! vector opt. 389 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 390 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 391 END DO 392 END DO 393 END DO 394 END IF 298 395 ! 299 396 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport … … 318 415 END DO ! end of tracer loop 319 416 ! 417 IF ( ll_zAimp ) THEN 418 DEALLOCATE( zwdia, zwinf, zwsup ) 419 ENDIF 320 420 IF( l_trd .OR. l_hst ) THEN 321 421 DEALLOCATE( ztrdx, ztrdy, ztrdz ) … … 559 659 DO ji = fs_2, fs_jpim1 560 660 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 561 ikb = mbkt(ji,jj)! - above the last wet point661 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point 562 662 ! 563 663 zwd (ji,jj,ikt) = 1._wp ! top -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/trabbc.F90
r10425 r12143 135 135 REWIND( numnam_ref ) ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 136 136 READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' , lwp)137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 138 138 ! 139 139 REWIND( numnam_cfg ) ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 140 140 READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' , lwp)141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) 142 142 IF(lwm) WRITE ( numond, nambbc ) 143 143 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/trabbl.F90
r10425 r12143 485 485 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 486 486 READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 487 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' , lwp)487 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' ) 488 488 ! 489 489 REWIND( numnam_cfg ) ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 490 490 READ ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 491 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' , lwp)491 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) 492 492 IF(lwm) WRITE ( numond, nambbl ) 493 493 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/tradmp.F90
r10425 r12143 179 179 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation 180 180 READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 181 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' , lwp)181 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) 182 182 ! 183 183 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation 184 184 READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 185 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' , lwp)185 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) 186 186 IF(lwm) WRITE ( numond, namtra_dmp ) 187 187 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/traldf_iso.F90
r10068 r12143 289 289 !!---------------------------------------------------------------------- 290 290 ! 291 ztfw( 1,:,:) = 0._wp ; ztfw(jpi,:,:) = 0._wp291 ztfw(fs_2:1,:,:) = 0._wp ; ztfw(jpi:fs_jpim1,:,:) = 0._wp ! avoid to potentially manipulate NaN values 292 292 ! 293 293 ! Vertical fluxes … … 323 323 IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz 324 324 DO jk = 2, jpkm1 325 DO jj = 1, jpjm1325 DO jj = 2, jpjm1 326 326 DO ji = fs_2, fs_jpim1 327 327 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & … … 336 336 CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 337 337 DO jk = 2, jpkm1 338 DO jj = 1, jpjm1338 DO jj = 2, jpjm1 339 339 DO ji = fs_2, fs_jpim1 340 340 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) & … … 346 346 CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb and ptbb gradients, resp. 347 347 DO jk = 2, jpkm1 348 DO jj = 1, jpjm1348 DO jj = 2, jpjm1 349 349 DO ji = fs_2, fs_jpim1 350 350 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/tramle.F90
r10425 r12143 268 268 REWIND( numnam_ref ) ! Namelist namtra_mle in reference namelist : Tracer advection scheme 269 269 READ ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) 270 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' , lwp)270 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) 271 271 272 272 REWIND( numnam_cfg ) ! Namelist namtra_mle in configuration namelist : Tracer advection scheme 273 273 READ ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) 274 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' , lwp)274 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) 275 275 IF(lwm) WRITE ( numond, namtra_mle ) 276 276 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRA/traqsr.F90
r10425 r12143 168 168 DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl 169 169 DO ji = fs_2, fs_jpim1 170 zchl = sf_chl(1)%fnow(ji,jj,1)170 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 171 171 zCtot = 40.6 * zchl**0.459 172 172 zze = 568.2 * zCtot**(-0.746) … … 338 338 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist 339 339 READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 340 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' , lwp)340 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) 341 341 ! 342 342 REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration namelist 343 343 READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 344 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' , lwp)344 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) 345 345 IF(lwm) WRITE ( numond, namtra_qsr ) 346 346 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRD/trdini.F90
r10068 r12143 48 48 REWIND( numnam_ref ) ! Namelist namtrd in reference namelist : trends diagnostic 49 49 READ ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) 50 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' , lwp)50 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' ) 51 51 ! 52 52 REWIND( numnam_cfg ) ! Namelist namtrd in configuration namelist : trends diagnostic 53 53 READ ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) 54 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' , lwp)54 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) 55 55 IF(lwm) WRITE( numond, namtrd ) 56 56 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRD/trdmxl.F90
r10425 r12143 734 734 REWIND( numnam_ref ) ! Namelist namtrd_mxl in reference namelist : mixed layer trends diagnostic 735 735 READ ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) 736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' , lwp)736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) 737 737 738 738 REWIND( numnam_cfg ) ! Namelist namtrd_mxl in configuration namelist : mixed layer trends diagnostic 739 739 READ ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 ) 740 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' , lwp)740 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' ) 741 741 IF(lwm) WRITE( numond, namtrd_mxl ) 742 742 ! … … 764 764 765 765 IF( MOD( nitend, nn_trd ) /= 0 ) THEN 766 WRITE(numout,cform_err) 767 WRITE(numout,*) ' Your nitend parameter, nitend = ', nitend 768 WRITE(numout,*) ' is no multiple of the trends diagnostics frequency ' 769 WRITE(numout,*) ' you defined, nn_trd = ', nn_trd 770 WRITE(numout,*) ' This will not allow you to restart from this simulation. ' 771 WRITE(numout,*) ' You should reconsider this choice. ' 772 WRITE(numout,*) 773 WRITE(numout,*) ' N.B. the nitend parameter is also constrained to be a ' 774 WRITE(numout,*) ' multiple of the nn_fsbc parameter ' 775 CALL ctl_stop( 'trd_mxl_init: see comment just above' ) 766 WRITE(ctmp1,*) ' Your nitend parameter, nitend = ', nitend 767 WRITE(ctmp2,*) ' is no multiple of the trends diagnostics frequency ' 768 WRITE(ctmp3,*) ' you defined, nn_trd = ', nn_trd 769 WRITE(ctmp4,*) ' This will not allow you to restart from this simulation. ' 770 WRITE(ctmp5,*) ' You should reconsider this choice. ' 771 WRITE(ctmp6,*) 772 WRITE(ctmp7,*) ' N.B. the nitend parameter is also constrained to be a ' 773 WRITE(ctmp8,*) ' multiple of the nn_fsbc parameter ' 774 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 776 775 END IF 777 776 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRD/trdmxl_rst.F90
r10425 r12143 47 47 !!-------------------------------------------------------------------------------- 48 48 49 IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart 50 49 51 ! to get better performances with NetCDF format: 50 52 ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) 51 53 ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 52 IF( kt == nitrst - 1 .OR. n stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nstock ) == 0 ) ) THEN54 IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN 53 55 ! beware of the format used to write kt (default is i8.8, that should be large enough...) 54 56 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/TRD/trdvor.F90
r10425 r12143 46 46 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average 47 47 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) 48 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the n write-1 timestep averaging period48 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period 49 49 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the 50 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the N WRITE-1 timesteps50 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps 51 51 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! 52 52 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! … … 129 129 !! from ocean surface down to control surface (NetCDF output) 130 130 !! 131 !! ** Method/usage : integration done over n write-1 time steps131 !! ** Method/usage : integration done over nn_write-1 time steps 132 132 !! 133 133 !! ** Action : trends : … … 143 143 !! vortrd (,,10) = forcing term 144 144 !! vortrd (,,11) = bottom friction term 145 !! rotot(,) : total cumulative trends over n write-1 time steps145 !! rotot(,) : total cumulative trends over nn_write-1 time steps 146 146 !! vor_avrtot(,) : first membre of vrticity equation 147 147 !! vor_avrres(,) : residual = dh/dt entrainment … … 214 214 !! from ocean surface down to control surface (NetCDF output) 215 215 !! 216 !! ** Method/usage : integration done over n write-1 time steps216 !! ** Method/usage : integration done over nn_write-1 time steps 217 217 !! 218 218 !! ** Action : trends : … … 228 228 !! vortrd (,,10) = forcing term 229 229 !! vortrd (,,11) = bottom friction term 230 !! rotot(,) : total cumulative trends over n write-1 time steps230 !! rotot(,) : total cumulative trends over nn_write-1 time steps 231 231 !! vor_avrtot(,) : first membre of vrticity equation 232 232 !! vor_avrres(,) : residual = dh/dt entrainment … … 360 360 ENDIF 361 361 362 ! II.2 cumulated trends over analysis period (kt=2 to n write)362 ! II.2 cumulated trends over analysis period (kt=2 to nn_write) 363 363 ! ---------------------- 364 ! trends cumulated over n write-2 time steps364 ! trends cumulated over nn_write-2 time steps 365 365 366 366 IF( kt >= nit000+2 ) THEN … … 376 376 ! III. Output in netCDF + residual computation 377 377 ! ============================================= 378 378 379 379 ! define time axis 380 380 it = kt … … 504 504 ENDIF 505 505 #if defined key_diainstant 506 zsto = n write*rdt506 zsto = nn_write*rdt 507 507 clop = "inst("//TRIM(clop)//")" 508 508 #else -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/USR/usrdef_nam.F90
r10069 r12143 37 37 CONTAINS 38 38 39 SUBROUTINE usr_def_nam( ldtxt, ldnam,cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 40 40 !!---------------------------------------------------------------------- 41 41 !! *** ROUTINE dom_nam *** … … 49 49 !! ** input : - namusr_def namelist found in namelist_cfg 50 50 !!---------------------------------------------------------------------- 51 CHARACTER(len=*), DIMENSION(:), INTENT(out) :: ldtxt, ldnam ! stored print information 52 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 56 55 ! 57 INTEGER :: ios , ii! Local integer56 INTEGER :: ios ! Local integer 58 57 !! 59 58 NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo 60 59 !!---------------------------------------------------------------------- 61 60 ! 62 ii = 163 !64 61 REWIND( numnam_cfg ) ! Namelist namusr_def (exist in namelist_cfg only) 65 62 READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) 66 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' , .TRUE.)63 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) 67 64 ! 68 WRITE( ldnam(:), namusr_def )65 IF(lwm) WRITE( numond, namusr_def ) 69 66 ! 70 67 cd_cfg = 'GYRE' ! name & resolution (not used) … … 83 80 #endif 84 81 kpk = jpkglo 85 !86 ! ! control print87 WRITE(ldtxt(ii),*) ' ' ; ii = ii + 188 WRITE(ldtxt(ii),*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' ; ii = ii + 189 WRITE(ldtxt(ii),*) '~~~~~~~~~~~ ' ; ii = ii + 190 WRITE(ldtxt(ii),*) ' Namelist namusr_def : GYRE case' ; ii = ii + 191 WRITE(ldtxt(ii),*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench ; ii = ii + 192 WRITE(ldtxt(ii),*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE ; ii = ii + 193 #if defined key_agrif94 IF( Agrif_Root() ) THEN95 #endif96 WRITE(ldtxt(ii),*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi ; ii = ii + 197 WRITE(ldtxt(ii),*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj ; ii = ii + 198 #if defined key_agrif99 ENDIF100 #endif101 WRITE(ldtxt(ii),*) ' number of model levels jpkglo = ', kpk ; ii = ii + 1102 !103 82 ! ! Set the lateral boundary condition of the global domain 104 83 kperio = 0 ! GYRE configuration : closed domain 105 84 ! 106 WRITE(ldtxt(ii),*) ' ' ; ii = ii + 1 107 WRITE(ldtxt(ii),*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio ; ii = ii + 1 85 ! ! control print 86 IF(lwp) THEN 87 WRITE(numout,*) ' ' 88 WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' 89 WRITE(numout,*) '~~~~~~~~~~~ ' 90 WRITE(numout,*) ' Namelist namusr_def : GYRE case' 91 WRITE(numout,*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench 92 WRITE(numout,*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE 93 #if defined key_agrif 94 IF( Agrif_Root() ) THEN 95 #endif 96 WRITE(numout,*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi 97 WRITE(numout,*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj 98 #if defined key_agrif 99 ENDIF 100 #endif 101 WRITE(numout,*) ' number of model levels jpkglo = ', kpk 102 WRITE(numout,*) ' ' 103 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio 104 ENDIF 108 105 ! 109 106 END SUBROUTINE usr_def_nam -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfdrg.F90
r10069 r12143 238 238 REWIND( numnam_ref ) ! Namelist namdrg in reference namelist 239 239 READ ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) 240 901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' , lwp)240 901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' ) 241 241 REWIND( numnam_cfg ) ! Namelist namdrg in configuration namelist 242 242 READ ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) 243 902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' , lwp)243 902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' ) 244 244 IF(lwm) WRITE ( numond, namdrg ) 245 245 ! … … 338 338 IF(ll_top) READ ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) 339 339 IF(ll_bot) READ ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) 340 901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) , lwp)340 901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) ) 341 341 REWIND( numnam_cfg ) ! Namelist cd_namdrg in configuration namelist 342 342 IF(ll_top) READ ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) 343 343 IF(ll_bot) READ ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) 344 902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) , lwp)344 902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) ) 345 345 IF(lwm .AND. ll_top) WRITE ( numond, namdrg_top ) 346 346 IF(lwm .AND. ll_bot) WRITE ( numond, namdrg_bot ) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfgls.F90
r10425 r12143 859 859 REWIND( numnam_ref ) ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 860 860 READ ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) 861 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' , lwp)861 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) 862 862 863 863 REWIND( numnam_cfg ) ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 864 864 READ ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) 865 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' , lwp)865 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) 866 866 IF(lwm) WRITE ( numond, namzdf_gls ) 867 867 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfiwm.F90
r10425 r12143 424 424 REWIND( numnam_ref ) ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing 425 425 READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) 426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' , lwp)426 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) 427 427 ! 428 428 REWIND( numnam_cfg ) ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing 429 429 READ ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) 430 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' , lwp)430 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) 431 431 IF(lwm) WRITE ( numond, namzdf_iwm ) 432 432 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfosm.F90
r10425 r12143 1386 1386 REWIND( numnam_ref ) ! Namelist namzdf_osm in reference namelist : Osmosis ML model 1387 1387 READ ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) 1388 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' , lwp)1388 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) 1389 1389 1390 1390 REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 1391 1391 READ ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) 1392 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' , lwp)1392 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) 1393 1393 IF(lwm) WRITE ( numond, namzdf_osm ) 1394 1394 -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfphy.F90
r10907 r12143 93 93 REWIND( numnam_ref ) ! Namelist namzdf in reference namelist : Vertical mixing parameters 94 94 READ ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) 95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' , lwp)95 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' ) 96 96 ! 97 97 REWIND( numnam_cfg ) ! Namelist namzdf in reference namelist : Vertical mixing parameters 98 98 READ ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) 99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' , lwp)99 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) 100 100 IF(lwm) WRITE ( numond, namzdf ) 101 101 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdfric.F90
r10068 r12143 80 80 REWIND( numnam_ref ) ! Namelist namzdf_ric in reference namelist : Vertical diffusion Kz depends on Richardson number 81 81 READ ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) 82 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' , lwp)82 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) 83 83 84 84 REWIND( numnam_cfg ) ! Namelist namzdf_ric in configuration namelist : Vertical diffusion Kz depends on Richardson number 85 85 READ ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 ) 86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' ) 87 87 IF(lwm) WRITE ( numond, namzdf_ric ) 88 88 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/ZDF/zdftke.F90
r10425 r12143 658 658 REWIND( numnam_ref ) ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy 659 659 READ ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) 660 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' , lwp)660 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) 661 661 662 662 REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 663 663 READ ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 ) 664 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' , lwp)664 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' ) 665 665 IF(lwm) WRITE ( numond, namzdf_tke ) 666 666 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/module_example
r10425 r12143 152 152 REWIND( numnam_ref ) ! Namelist namexa in reference namelist : Example 153 153 READ ( numnam_ref, namexa, IOSTAT = ios, ERR = 901) 154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' , lwp)154 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' ) 155 155 ! 156 156 REWIND( numnam_cfg ) ! Namelist namexa in configuration namelist : Example 157 157 READ ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 ) 158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' , lwp)158 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' ) 159 159 ! Output namelist for control 160 160 WRITE ( numond, namexa ) -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/nemogcm.F90
r11553 r12143 59 59 USE diaobs ! Observation diagnostics (dia_obs_init routine) 60 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 USE diaharm ! tidal harmonics diagnostics (dia_harm_init routine) 61 62 USE step ! NEMO time-stepping (stp routine) 62 63 USE isfstp ! ice shelf (isf_stp_init routine) … … 104 105 105 106 #if defined key_mpp_mpi 107 ! need MPI_Wtime 106 108 INCLUDE 'mpif.h' 107 109 #endif … … 129 131 !!---------------------------------------------------------------------- 130 132 INTEGER :: istp ! time step index 133 REAL(wp):: zstptiming ! elapsed time for 1 time step 131 134 !!---------------------------------------------------------------------- 132 135 ! … … 189 192 ! 190 193 DO WHILE( istp <= nitend .AND. nstop == 0 ) 191 #if defined key_mpp_mpi 194 192 195 ncom_stp = istp 193 IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 194 IF ( istp == nitend ) elapsed_time = MPI_Wtime() - elapsed_time 195 #endif 196 IF( ln_timing ) THEN 197 zstptiming = MPI_Wtime() 198 IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 199 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 200 ENDIF 201 196 202 CALL stp ( istp ) 197 203 istp = istp + 1 204 205 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 206 198 207 END DO 199 208 ! … … 221 230 ! 222 231 IF( nstop /= 0 .AND. lwp ) THEN ! error print 223 WRITE(numout,cform_err) 224 WRITE(numout,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 225 WRITE(numout,*) 232 WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 233 CALL ctl_stop( ctmp1 ) 226 234 ENDIF 227 235 ! … … 235 243 #else 236 244 IF ( lk_oasis ) THEN ; CALL cpl_finalize ! end coupling and mpp communications with OASIS 237 ELSEIF( lk_mpp ) THEN ; CALL mppstop ( ldfinal = .TRUE. )! end mpp communications245 ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications 238 246 ENDIF 239 247 #endif … … 241 249 IF(lwm) THEN 242 250 IF( nstop == 0 ) THEN ; STOP 0 243 ELSE ; STOP 999251 ELSE ; STOP 123 244 252 ENDIF 245 253 ENDIF … … 254 262 !! ** Purpose : initialization of the NEMO GCM 255 263 !!---------------------------------------------------------------------- 256 INTEGER :: ji ! dummy loop indices 257 INTEGER :: ios, ilocal_comm ! local integers 258 CHARACTER(len=120), DIMENSION(60) :: cltxt, cltxt2, clnam 264 INTEGER :: ios, ilocal_comm ! local integers 259 265 !! 260 266 NAMELIST/namctl/ ln_ctl , sn_cfctl, nn_print, nn_ictls, nn_ictle, & … … 264 270 !!---------------------------------------------------------------------- 265 271 ! 266 cltxt = ''267 cltxt2 = ''268 clnam = ''269 272 cxios_context = 'nemo' 270 273 ! 271 ! ! Open reference namelist and configuration namelist files 272 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 273 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 274 ! 275 REWIND( numnam_ref ) ! Namelist namctl in reference namelist 276 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 277 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) 278 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist 279 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 280 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) 281 ! 282 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 283 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 284 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 285 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 286 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 287 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. ) 288 289 ! !--------------------------! 290 ! ! Set global domain size ! (control print return in cltxt2) 291 ! !--------------------------! 292 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 293 CALL domain_cfg ( cltxt2, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 294 ! 295 ELSE ! user-defined namelist 296 CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 297 ENDIF 298 ! 299 ! 300 ! !--------------------------------------------! 301 ! ! set communicator & select the local node ! 302 ! ! NB: mynode also opens output.namelist.dyn ! 303 ! ! on unit number numond on first proc ! 304 ! !--------------------------------------------! 274 ! !-------------------------------------------------! 275 ! ! set communicator & select the local rank ! 276 ! ! must be done as soon as possible to get narea ! 277 ! !-------------------------------------------------! 278 ! 305 279 #if defined key_iomput 306 280 IF( Agrif_Root() ) THEN 307 281 IF( lk_oasis ) THEN 308 282 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 309 CALL xios_initialize( "not used" , local_comm= ilocal_comm )! send nemo communicator to xios283 CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios 310 284 ELSE 311 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )! nemo local communicator given by xios285 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 312 286 ENDIF 313 287 ENDIF 314 ! Nodes selection (control print return in cltxt) 315 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 288 CALL mpp_start( ilocal_comm ) 316 289 #else 317 290 IF( lk_oasis ) THEN … … 319 292 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 320 293 ENDIF 321 ! Nodes selection (control print return in cltxt) 322 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 294 CALL mpp_start( ilocal_comm ) 323 295 ELSE 324 ilocal_comm = 0 ! Nodes selection (control print return in cltxt)325 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )326 ENDIF 327 #endif 328 329 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 )330 331 IF( sn_cfctl%l_config ) THEN332 ! Activate finer control of report outputs333 ! optionally switch off output from selected areas (note this only334 ! applies to output which does not involve global communications)335 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. &336 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) &337 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. )338 ELSE339 ! Use ln_ctl to turn on or off all options.340 CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. )341 ENDIF342 343 lwm = (narea == 1) ! control of output namelists344 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print345 346 IF(lwm) THEN ! write merged namelists from earlier to output namelist347 ! ! now that the file has been opened in call to mynode.348 ! ! NB: nammpp has already been written in mynode (if lk_mpp_mpi)349 WRITE( numond, namctl)350 WRITE( numond, namcfg)351 IF( .NOT.ln_read_cfg ) THEN352 DO ji = 1, SIZE(clnam)353 IF( TRIM(clnam(ji)) /= '' ) WRITE(numond, * ) clnam(ji) ! namusr_def print 354 END DO355 ENDIF356 ENDIF357 358 IF(lwp) THEN ! open listing units359 !360 CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )296 CALL mpp_start( ) 297 ENDIF 298 #endif 299 ! 300 narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 ) 301 lwm = (narea == 1) ! control of output namelists 302 ! 303 ! !---------------------------------------------------------------! 304 ! ! Open output files, reference and configuration namelist files ! 305 ! !---------------------------------------------------------------! 306 ! 307 ! open ocean.output as soon as possible to get all output prints (including errors messages) 308 IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 309 ! open reference and configuration namelist files 310 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 311 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 312 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 313 ! open /dev/null file to be able to supress output write easily 314 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 315 ! 316 ! !--------------------! 317 ! ! Open listing units ! -> need ln_ctl from namctl to define lwp 318 ! !--------------------! 319 ! 320 REWIND( numnam_ref ) ! Namelist namctl in reference namelist 321 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 322 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) 323 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist 324 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 325 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) 326 ! 327 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print 328 ! 329 IF(lwp) THEN ! open listing units 330 ! 331 IF( .NOT. lwm ) & ! alreay opened for narea == 1 332 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 361 333 ! 362 334 WRITE(numout,*) 363 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV -CMCC'335 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 364 336 WRITE(numout,*) ' NEMO team' 365 337 WRITE(numout,*) ' Ocean General Circulation Model' … … 380 352 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 381 353 WRITE(numout,*) 382 383 DO ji = 1, SIZE(cltxt)384 IF( TRIM(cltxt (ji)) /= '' ) WRITE(numout,*) TRIM(cltxt(ji)) ! control print of mynode385 END DO386 WRITE(numout,*)387 WRITE(numout,*)388 DO ji = 1, SIZE(cltxt2)389 IF( TRIM(cltxt2(ji)) /= '' ) WRITE(numout,*) TRIM(cltxt2(ji)) ! control print of domain size390 END DO391 354 ! 392 355 WRITE(numout,cform_aaa) ! Flag AAAAAAA 393 356 ! 394 357 ENDIF 395 ! open /dev/null file to be able to supress output write easily 396 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 397 ! 398 ! ! Domain decomposition 399 CALL mpp_init ! MPP 358 ! 359 ! finalize the definition of namctl variables 360 IF( sn_cfctl%l_config ) THEN 361 ! Activate finer control of report outputs 362 ! optionally switch off output from selected areas (note this only 363 ! applies to output which does not involve global communications) 364 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. & 365 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) & 366 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 367 ELSE 368 ! Use ln_ctl to turn on or off all options. 369 CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 370 ENDIF 371 ! 372 IF(lwm) WRITE( numond, namctl ) 373 ! 374 ! !------------------------------------! 375 ! ! Set global domain size parameters ! 376 ! !------------------------------------! 377 ! 378 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 379 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 380 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 381 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 382 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 383 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 384 ! 385 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 386 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 387 ELSE ! user-defined namelist 388 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 389 ENDIF 390 ! 391 IF(lwm) WRITE( numond, namcfg ) 392 ! 393 ! !-----------------------------------------! 394 ! ! mpp parameters and domain decomposition ! 395 ! !-----------------------------------------! 396 CALL mpp_init 400 397 401 398 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays … … 485 482 486 483 ! ! Diagnostics 487 IF( lk_floats )CALL flo_init ! drifting Floats484 CALL flo_init ! drifting Floats 488 485 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 489 486 CALL dia_ptr_init ! Poleward TRansports initialization 490 IF( lk_diadct )CALL dia_dct_init ! Sections tranports487 CALL dia_dct_init ! Sections tranports 491 488 CALL dia_hsb_init ! heat content, salt content and volume budgets 492 489 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends … … 494 491 CALL dia_tmb_init ! TMB outputs 495 492 CALL dia_25h_init ! 25h mean outputs 496 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 493 CALL dia_harm_init ! tidal harmonics outputs 494 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 497 495 498 496 ! ! Assimilation increments … … 512 510 !! ** Purpose : control print setting 513 511 !! 514 !! ** Method : - print namctl information and check some consistencies512 !! ** Method : - print namctl and namcfg information and check some consistencies 515 513 !!---------------------------------------------------------------------- 516 514 ! … … 655 653 USE trc_oce , ONLY : trc_oce_alloc 656 654 USE bdy_oce , ONLY : bdy_oce_alloc 657 #if defined key_diadct658 USE diadct , ONLY : diadct_alloc659 #endif660 655 ! 661 656 INTEGER :: ierr … … 669 664 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) 670 665 ! 671 #if defined key_diadct672 ierr = ierr + diadct_alloc () !673 #endif674 !675 666 CALL mpp_sum( 'nemogcm', ierr ) 676 667 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) … … 678 669 END SUBROUTINE nemo_alloc 679 670 671 680 672 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 681 673 !!---------------------------------------------------------------------- -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/step.F90
r12062 r12143 112 112 IF( ln_tide ) CALL sbc_tide( kstp ) ! update tide potential 113 113 IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) 114 IF( ln_bdy ) CALL bdy_dta ( kstp, time_offset=+1 ) ! update dynamic & tracer data at open boundaries114 IF( ln_bdy ) CALL bdy_dta ( kstp, kt_offset = +1 ) ! update dynamic & tracer data at open boundaries 115 115 IF( ln_isf ) CALL isf_stp ( kstp ) ! ice shelf/ocean boundary condition 116 116 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) … … 166 166 CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation 167 167 168 !!jc: fs simplification169 !!jc: lines below are useless if ln_linssh=F. Keep them here (which maintains a bug if ln_linssh=T and ln_zps=T, cf ticket #1636)170 !! but ensures reproductible results171 !! with previous versions using split-explicit free surface172 IF( ln_zps .AND. .NOT. ln_isfcav ) &173 & CALL zps_hde ( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient174 & rhd, gru , grv ) ! of t, s, rd at the last ocean level175 IF( ln_zps .AND. ln_isfcav ) &176 & CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)177 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level178 !!jc: fs simplification179 168 180 169 ua(:,:,:) = 0._wp ! set dynamics trends to zero … … 215 204 ! diagnostics and outputs 216 205 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 217 IF( l k_floats ) CALL flo_stp ( kstp ) ! drifting Floats206 IF( ln_floats ) CALL flo_stp ( kstp ) ! drifting Floats 218 207 IF( ln_diacfl ) CALL dia_cfl ( kstp ) ! Courant number diagnostics 219 208 IF( lk_diahth ) CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth) 220 IF( l k_diadct ) CALL dia_dct ( kstp ) ! Transports209 IF( ln_diadct ) CALL dia_dct ( kstp ) ! Transports 221 210 CALL dia_ar5 ( kstp ) ! ar5 diag 222 IF( l k_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis211 IF( ln_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 223 212 CALL dia_wri ( kstp ) ! ocean model: outputs 224 213 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/stpctl.F90
r10570 r12143 96 96 IF( ln_zad_Aimp ) THEN 97 97 istatus = NF90_DEF_VAR( idrun, 'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1 ) 98 istatus = NF90_DEF_VAR( idrun, 'C u_max', NF90_DOUBLE, (/ idtime /), idc1 )98 istatus = NF90_DEF_VAR( idrun, 'Cf_max', NF90_DOUBLE, (/ idtime /), idc1 ) 99 99 ENDIF 100 100 istatus = NF90_ENDDEF(idrun) … … 123 123 IF( ln_zad_Aimp ) THEN 124 124 zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! implicit vertical vel. max 125 zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! cell Courant no. max125 zmax(9) = MAXVAL( Cu_adv(:,:,:) , mask = tmask(:,:,:) == 1._wp ) ! partitioning coeff. max 126 126 ENDIF 127 127 ! -
NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/timing.F90
r10510 r12143 347 347 348 348 ! write output file 349 IF( lwriter ) WRITE(numtime,*) 350 IF( lwriter ) WRITE(numtime,*) 349 351 IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' 350 352 IF( lwriter ) WRITE(numtime,*) '--------------------' … … 657 659 ! Compute cpu/elapsed ratio 658 660 zall_ratio(:) = all_ctime(:) / all_etime(:) 659 ztot_ratio = SUM( zall_ratio(:))660 zavg_ratio = ztot_ratio/REAL(jpnij,wp)661 ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) 662 zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,wp) 661 663 zmax_ratio = MAXVAL(zall_ratio(:)) 662 664 zmin_ratio = MINVAL(zall_ratio(:)) … … 667 669 cllignes(2)='1x,"--------------------",//,' 668 670 cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' 669 cllignes(4)=' (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),'670 WRITE(cllignes(4)(1: 4),'(I4)') jpnij671 cllignes(4)=' (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' 672 WRITE(cllignes(4)(1:6),'(I6)') jpnij 671 673 cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' 672 674 cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,'
Note: See TracChangeset
for help on using the changeset viewer.