Changeset 5883
- Timestamp:
- 2015-11-13T08:01:08+01:00 (8 years ago)
- Location:
- branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM
- Files:
-
- 1 deleted
- 41 edited
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/namelist_cfg
r5866 r5883 257 257 / 258 258 !----------------------------------------------------------------------- 259 &namhsb ! Heat and salt budgets 260 !----------------------------------------------------------------------- 259 &namhsb ! Heat and salt budgets (default F) 260 !----------------------------------------------------------------------- 261 ln_diahsb = .true. ! check the heat and salt budgets (T) or not (F) 261 262 / 262 263 !----------------------------------------------------------------------- -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/CONFIG/SHARED/namelist_ref
r5866 r5883 33 33 nn_leapy = 0 ! Leap year calendar (1) or not (0) 34 34 ln_rstart = .false. ! start from rest (F) or from a restart file (T) 35 nn_euler = 1! = 0 : start with forward time step if ln_rstart=T36 nn_rstctl = 0! restart control ==> activated only if ln_rstart=T37 ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist38 ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart39 ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart40 cn_ocerst_in = "restart"! suffix of ocean restart name (input)41 cn_ocerst_indir = "."! directory from which to read input ocean restarts42 cn_ocerst_out = "restart"! suffix of ocean restart name (output)43 cn_ocerst_outdir = "."! directory in which to write output ocean restarts35 nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T 36 nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T 37 ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist 38 ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart 39 ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart 40 cn_ocerst_in = "restart" ! suffix of ocean restart name (input) 41 cn_ocerst_indir = "." ! directory from which to read input ocean restarts 42 cn_ocerst_out = "restart" ! suffix of ocean restart name (output) 43 cn_ocerst_outdir = "." ! directory in which to write output ocean restarts 44 44 nn_istate = 0 ! output the initial state (1) or not (0) 45 45 ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) … … 50 50 ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%) 51 51 ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard 52 ln_clobber = .true. ! clobber (overwrite) an existing file52 ln_clobber = .true. ! clobber (overwrite) an existing file 53 53 nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) 54 54 / … … 65 65 ! 66 66 !----------------------------------------------------------------------- 67 &namcfg ! parameters of the configuration68 !----------------------------------------------------------------------- 69 cp_cfg = "default"! name of the configuration70 cp_cfz = "no zoom"! name of the zoom of configuration71 jp_cfg = 0! resolution of the configuration72 jpidta = 10! 1st lateral dimension ( >= jpi )73 jpjdta = 12! 2nd " " ( >= jpj )74 jpkdta = 31! number of levels ( >= jpk )75 jpiglo = 10! 1st dimension of global domain --> i =jpidta76 jpjglo = 12! 2nd - - --> j =jpjdta77 jpizoom = 1! left bottom (i,j) indices of the zoom78 jpjzoom = 1! in data domain indices79 jperio = 0! lateral cond. type (between 0 and 6)80 81 82 83 84 85 ln_use_jattr = .false. 86 67 &namcfg ! parameters of the configuration 68 !----------------------------------------------------------------------- 69 cp_cfg = "default" ! name of the configuration 70 cp_cfz = "no zoom" ! name of the zoom of configuration 71 jp_cfg = 0 ! resolution of the configuration 72 jpidta = 10 ! 1st lateral dimension ( >= jpi ) 73 jpjdta = 12 ! 2nd " " ( >= jpj ) 74 jpkdta = 31 ! number of levels ( >= jpk ) 75 jpiglo = 10 ! 1st dimension of global domain --> i =jpidta 76 jpjglo = 12 ! 2nd - - --> j =jpjdta 77 jpizoom = 1 ! left bottom (i,j) indices of the zoom 78 jpjzoom = 1 ! in data domain indices 79 jperio = 0 ! lateral cond. type (between 0 and 6) 80 ! = 0 closed ; = 1 cyclic East-West 81 ! = 2 equatorial symmetric ; = 3 North fold T-point pivot 82 ! = 4 cyclic East-West AND North fold T-point pivot 83 ! = 5 North fold F-point pivot 84 ! = 6 cyclic East-West AND North fold F-point pivot 85 ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present 86 ! in netcdf input files, as the start j-row for reading 87 87 / 88 88 !----------------------------------------------------------------------- … … 236 236 !----------------------------------------------------------------------- 237 237 nn_fsbc = 5 ! frequency of surface boundary condition computation 238 ! (also = the frequency of sea-ice model call) 238 ! (also = the frequency of sea-ice & iceberg model call) 239 ! Type of air-sea fluxes 239 240 ln_ana = .false. ! analytical formulation (T => fill namsbc_ana ) 240 241 ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) … … 242 243 ln_blk_core = .true. ! CORE bulk formulation (T => fill namsbc_core) 243 244 ln_blk_mfs = .false. ! MFS bulk formulation (T => fill namsbc_mfs ) 245 ! Type of coupling (Ocean/Ice/Atmosphere) : 244 246 ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) 245 247 ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) … … 248 250 ! =1 opa-sas OASIS coupling: multi executable configuration, OPA component 249 251 ! =2 opa-sas OASIS coupling: multi executable configuration, SAS component 250 ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) 252 nn_limflx = -1 ! LIM3 Multi-category heat flux formulation (use -1 if LIM3 is not used) 253 ! =-1 Use per-category fluxes, bypass redistributor, forced mode only, not yet implemented coupled 254 ! = 0 Average per-category fluxes (forced and coupled mode) 255 ! = 1 Average and redistribute per-category fluxes, forced mode only, not yet implemented coupled 256 ! = 2 Redistribute a single flux over categories (coupled mode only) 257 ! Sea-ice : 251 258 nn_ice = 2 ! =0 no ice boundary condition , 252 259 ! =1 use observed ice-cover , … … 255 262 ! =1 levitating ice with mass and salt exchange but no presure effect 256 263 ! =2 embedded sea-ice (full salt and mass exchanges and pressure) 257 ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave 258 ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) 264 ! Misc. options of sbc : 265 ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr ) 266 ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave 267 ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) 268 ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) 269 nn_fwb = 2 ! FreshWater Budget: =0 unchecked 270 ! =1 global mean of e-p-r set to zero at each time step 271 ! =2 annual global mean of e-p-r set to zero 272 ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) 259 273 nn_isf = 0 ! ice shelf melting/freezing (/=0 => fill namsbc_isf) 260 274 ! 0 =no isf 1 = presence of ISF … … 262 276 ! 4 = ISF fwf specified 263 277 ! option 1 and 4 need ln_isfcav = .true. (domzgr) 264 ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) 265 nn_fwb = 2 ! FreshWater Budget: =0 unchecked 266 ! =1 global mean of e-p-r set to zero at each time step 267 ! =2 annual global mean of e-p-r set to zero 268 ln_wave = .false. ! Activate coupling with wave (either Stokes Drift or Drag coefficient, or both) (T => fill namsbc_wave) 269 ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => fill namsbc_wave) 270 ln_sdw = .false. ! Computation of 3D stokes drift (T => fill namsbc_wave) 278 ln_wave = .false. ! coupling with surface wave (T => fill namsbc_wave) 271 279 nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , 272 280 ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) 273 nn_limflx = -1 ! LIM3 Multi-category heat flux formulation (use -1 if LIM3 is not used)274 ! =-1 Use per-category fluxes, bypass redistributor, forced mode only, not yet implemented coupled275 ! = 0 Average per-category fluxes (forced and coupled mode)276 ! = 1 Average and redistribute per-category fluxes, forced mode only, not yet implemented coupled277 ! = 2 Redistribute a single flux over categories (coupled mode only)278 281 / 279 282 !----------------------------------------------------------------------- … … 406 409 407 410 cn_dir = './' ! root directory for the location of the runoff files 408 ln_traqsr = .true. ! Light penetration (T) or not (F)409 411 ln_qsr_rgb = .true. ! RGB (Red-Green-Blue) light penetration 410 412 ln_qsr_2bd = .false. ! 2 bands light penetration … … 1152 1154 / 1153 1155 !----------------------------------------------------------------------- 1154 &namhsb ! Heat and salt budgets 1156 &namhsb ! Heat and salt budgets (default F) 1155 1157 !----------------------------------------------------------------------- 1156 1158 ln_diahsb = .false. ! check the heat and salt budgets (T) or not (F) … … 1267 1269 sn_wn = 'sdw_wave' , 1 , 'wave_num' , .true. , .false. , 'daily' , '' , '' , '' 1268 1270 ! 1269 cn_dir_cdg = './' ! root directory for the location of drag coefficient files 1270 / 1271 cn_dir_cdg = './' ! root directory for the location of drag coefficient files 1272 ln_cdgw = .false. ! Neutral drag coefficient read from wave model 1273 ln_sdw = .false. ! Computation of 3D stokes drift 1274 / -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r5866 r5883 869 869 ! 870 870 sshb(:,:) = sshn(:,:) ! Update before fields 871 ! 872 IF( .NOT.ln_linssh ) THEN 873 DO jk = 1, jpk 874 e3t_b(:,:,jk) = e3t_n(:,:,jk) 875 END DO 876 ENDIF 871 e3t_b(:,:,:) = e3t_n(:,:,:) 872 !!gm why not e3u_b, e3v_b, gdept_b ???? 877 873 ! 878 874 DEALLOCATE( ssh_bkg ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r5866 r5883 113 113 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 114 114 END IF 115 !!gm 116 !!gm riceload should be added in both ln_linssh=T or F, no? 117 !!gm 115 118 END IF 116 119 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r5866 r5883 103 103 ! !== time varying part of coordinate system ==! 104 104 ! 105 IF( .NOT.ln_linssh ) THEN ! time varying : initialize before/now/after variables 106 ! 107 CALL dom_vvl_init 108 ! 109 ELSE ! Fix in time : set to the reference one for all 105 IF( ln_linssh ) THEN ! Fix in time : set to the reference one for all 110 106 ! before ! now ! after ! 111 107 ; gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points … … 134 130 ! 135 131 CALL wrk_dealloc( jpi,jpj, z1_hu_0, z1_hv_0 ) 132 ! 133 ELSE ! time varying : initialize before/now/after variables 134 ! 135 CALL dom_vvl_init 136 ! 136 137 ENDIF 137 138 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r5866 r5883 267 267 !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling. 268 268 !!---------------------------------------------------------------------- 269 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 270 REAL(wp), POINTER, DIMENSION(:,: ) :: zht, z_scale, zwu, zwv, zhdiv 271 !! * Arguments 272 INTEGER, INTENT( in ) :: kt ! time step 273 INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence 274 !! * Local declarations 269 INTEGER, INTENT( in ) :: kt ! time step 270 INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence 271 ! 275 272 INTEGER :: ji, jj, jk ! dummy loop indices 276 273 INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers … … 278 275 REAL(wp) :: z_tmin, z_tmax ! temporary scalars 279 276 LOGICAL :: ll_do_bclinic ! temporary logical 280 !!---------------------------------------------------------------------- 277 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 278 REAL(wp), POINTER, DIMENSION(:,: ) :: zht, z_scale, zwu, zwv, zhdiv 279 !!---------------------------------------------------------------------- 280 ! 281 IF( ln_linssh ) RETURN ! No calculation in linear free surface 281 282 ! 282 283 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') … … 579 580 REAL(wp) :: zcoef ! local scalar 580 581 !!---------------------------------------------------------------------- 581 582 ! 583 IF( ln_linssh ) RETURN ! No calculation in linear free surface 584 ! 582 585 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_swp') 583 586 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r5866 r5883 122 122 ENDIF 123 123 ENDIF 124 ! 124 ! 125 !!gm This is to be changed !!!! 125 126 ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here 126 127 IF( .NOT.ln_linssh ) THEN … … 129 130 END DO 130 131 ENDIF 132 !!gm 131 133 ! 132 134 ENDIF -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_cen2.F90
r5866 r5883 10 10 11 11 !!---------------------------------------------------------------------- 12 !! dyn_adv_cen2 : flux form momentum advection (ln_dynadv_cen2=T) 13 !! trends using a 2nd order centred scheme 12 !! dyn_adv_cen2 : flux form momentum advection (ln_dynadv_cen2=T) using a 2nd order centred scheme 14 13 !!---------------------------------------------------------------------- 15 14 USE oce ! ocean dynamics and tracers … … 67 66 ENDIF 68 67 ! 69 IF( l_trddyn ) THEN ! Save ua and vatrends68 IF( l_trddyn ) THEN ! trends: store the input trends 70 69 zfu_uw(:,:,:) = ua(:,:,:) 71 70 zfv_vw(:,:,:) = va(:,:,:) 72 71 ENDIF 73 74 ! ! ====================== ! 75 ! ! Horizontal advection ! 76 DO jk = 1, jpkm1 ! ====================== ! 77 ! ! horizontal volume fluxes 72 ! 73 ! !== Horizontal advection ==! 74 ! 75 DO jk = 1, jpkm1 ! horizontal transport 78 76 zfu(:,:,jk) = 0.25 * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) 79 77 zfv(:,:,jk) = 0.25 * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 80 ! 81 DO jj = 1, jpjm1 ! horizontal momentum fluxes at T- and F-point 78 DO jj = 1, jpjm1 ! horizontal momentum fluxes (at T- and F-point) 82 79 DO ji = 1, fs_jpim1 ! vector opt. 83 zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj 84 zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj 85 zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji 86 zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji 80 zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji+1,jj ,jk) ) 81 zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji ,jj+1,jk) ) 82 zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji+1,jj ,jk) ) 83 zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji ,jj+1,jk) ) 87 84 END DO 88 85 END DO 89 DO jj = 2, jpjm1 86 DO jj = 2, jpjm1 ! divergence of horizontal momentum fluxes 90 87 DO ji = fs_2, fs_jpim1 ! vector opt. 91 88 zbu = e1e2u(ji,jj) * e3u_n(ji,jj,jk) 92 89 zbv = e1e2v(ji,jj) * e3v_n(ji,jj,jk) 93 90 ! 94 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_t(ji+1,jj ,jk) - zfu_t(ji,jj ,jk) &95 & + zfv_f(ji ,jj ,jk) - zfv_f(ji,jj-1,jk) ) / zbu96 va(ji,jj,jk) = va(ji,jj,jk) - ( zfu_f(ji ,jj ,jk) - zfu_f(ji-1,jj,jk) &97 & + zfv_t(ji ,jj+1,jk) - zfv_t(ji ,jj,jk) ) / zbv91 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 92 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) / zbu 93 va(ji,jj,jk) = va(ji,jj,jk) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & 94 & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) / zbv 98 95 END DO 99 96 END DO 100 97 END DO 101 98 ! 102 IF( l_trddyn ) THEN ! save the horizontal advection trendfor diagnostic99 IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic 103 100 zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 104 101 zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) … … 108 105 ENDIF 109 106 ! 110 111 ! ! ==================== ! 112 ! ! Vertical advection ! 113 DO jk = 1, jpkm1 ! ==================== ! 114 ! ! Vertical volume fluxesÊ 115 zfw(:,:,jk) = 0.25 * e1e2t(:,:) * wn(:,:,jk) 116 ! 117 IF( jk == 1 ) THEN ! surface/bottom advective fluxes 118 zfu_uw(:,:,jpk) = 0.e0 ! Bottom value : flux set to zero 119 zfv_vw(:,:,jpk) = 0.e0 120 ! ! Surface value : 121 IF( .NOT.ln_linssh ) THEN ! variable volume : flux set to zero 122 zfu_uw(:,:, 1 ) = 0._wp 123 zfv_vw(:,:, 1 ) = 0._wp 124 ELSE ! constant volume : advection through the surface 125 DO jj = 2, jpjm1 126 DO ji = fs_2, fs_jpim1 127 zfu_uw(ji,jj, 1 ) = 2.e0 * ( zfw(ji,jj,1) + zfw(ji+1,jj ,1) ) * un(ji,jj,1) 128 zfv_vw(ji,jj, 1 ) = 2.e0 * ( zfw(ji,jj,1) + zfw(ji ,jj+1,1) ) * vn(ji,jj,1) 129 END DO 130 END DO 131 ENDIF 132 ELSE ! interior fluxes 133 DO jj = 2, jpjm1 134 DO ji = fs_2, fs_jpim1 ! vector opt. 135 zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) 136 zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) 137 END DO 107 ! !== Vertical advection ==! 108 ! 109 DO jj = 2, jpjm1 ! surface/bottom advective fluxes set to zero 110 DO ji = fs_2, fs_jpim1 111 zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(jj,jj,jpk) = 0._wp 112 zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(jj,jj, 1 ) = 0._wp 113 END DO 114 END DO 115 IF( ln_linssh ) THEN ! linear free surface: advection through the surface 116 DO jj = 2, jpjm1 117 DO ji = fs_2, fs_jpim1 118 zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) 119 zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) 138 120 END DO 139 ENDIF 140 END DO 141 DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence 142 DO jj = 2, jpjm1 121 END DO 122 ENDIF 123 DO jk = 2, jpkm1 ! interior advective fluxes 124 DO jj = 2, jpjm1 ! 1/4 * Vertical transport 125 DO ji = fs_2, fs_jpim1 126 zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 127 END DO 128 END DO 129 DO jj = 2, jpjm1 143 130 DO ji = fs_2, fs_jpim1 ! vector opt. 144 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) & 145 & / ( e1e2u(ji,jj) * e3u_n(ji,jj,jk) ) 146 va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) & 147 & / ( e1e2v(ji,jj) * e3v_n(ji,jj,jk) ) 131 zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) 132 zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) 148 133 END DO 149 134 END DO 150 135 END DO 151 136 ! 152 IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic 137 DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence 138 DO jj = 2, jpjm1 139 DO ji = fs_2, fs_jpim1 ! vector opt. 140 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 141 va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 142 END DO 143 END DO 144 END DO 145 ! 146 IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic 153 147 zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 154 148 zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 155 149 CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 156 150 ENDIF 157 ! 151 ! ! Control print 158 152 IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' cen2 adv - Ua: ', mask1=umask, & 159 153 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90
r5866 r5883 100 100 zlu_uv(:,:,:,:) = 0._wp 101 101 zlv_vu(:,:,:,:) = 0._wp 102 103 IF( l_trddyn ) THEN ! Save ua and vatrends102 ! 103 IF( l_trddyn ) THEN ! trends: store the input trends 104 104 zfu_uw(:,:,:) = ua(:,:,:) 105 105 zfv_vw(:,:,:) = va(:,:,:) 106 106 ENDIF 107 108 107 ! ! =========================== ! 109 108 DO jk = 1, jpkm1 ! Laplacian of the velocity ! … … 115 114 DO jj = 2, jpjm1 ! laplacian 116 115 DO ji = fs_2, fs_jpim1 ! vector opt. 117 !118 116 zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj ,jk) ) * umask(ji,jj,jk) 119 117 zlv_vv(ji,jj,jk,1) = ( vb (ji ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji ,jj-1,jk) ) * vmask(ji,jj,jk) … … 136 134 CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', 1. ) 137 135 CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', 1. ) 138 136 ! 139 137 ! ! ====================== ! 140 138 ! ! Horizontal advection ! … … 149 147 zvj = ( vn(ji,jj,jk) + vn(ji ,jj+1,jk) ) 150 148 ! 151 IF (zui > 0) THEN ; zl_u = zlu_uu(ji ,jj,jk,1)152 ELSE ; zl_u = zlu_uu(ji+1,jj,jk,1)153 ENDIF 154 IF (zvj > 0) THEN ; zl_v = zlv_vv(ji,jj ,jk,1)155 ELSE ; zl_v = zlv_vv(ji,jj+1,jk,1)149 IF( zui > 0 ) THEN ; zl_u = zlu_uu(ji ,jj,jk,1) 150 ELSE ; zl_u = zlu_uu(ji+1,jj,jk,1) 151 ENDIF 152 IF( zvj > 0 ) THEN ; zl_v = zlv_vv(ji,jj ,jk,1) 153 ELSE ; zl_v = zlv_vv(ji,jj+1,jk,1) 156 154 ENDIF 157 155 ! … … 165 163 zfuj = ( zfu(ji,jj,jk) + zfu(ji ,jj+1,jk) ) 166 164 zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj ,jk) ) 167 IF (zfuj > 0) THEN ; zl_v = zlv_vu( ji ,jj ,jk,1)168 ELSE ; zl_v = zlv_vu( ji+1,jj,jk,1)169 ENDIF 170 IF (zfvi > 0) THEN ; zl_u = zlu_uv( ji,jj ,jk,1)171 ELSE ; zl_u = zlu_uv( ji,jj+1,jk,1)165 IF( zfuj > 0 ) THEN ; zl_v = zlv_vu( ji ,jj ,jk,1) 166 ELSE ; zl_v = zlv_vu( ji+1,jj,jk,1) 167 ENDIF 168 IF( zfvi > 0 ) THEN ; zl_u = zlu_uv( ji,jj ,jk,1) 169 ELSE ; zl_u = zlu_uv( ji,jj+1,jk,1) 172 170 ENDIF 173 171 ! … … 190 188 END DO 191 189 END DO 192 IF( l_trddyn ) THEN ! save the horizontal advection trendfor diagnostic190 IF( l_trddyn ) THEN ! trends: send trends to trddyn for diagnostic 193 191 zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 194 192 zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) … … 197 195 zfv_t(:,:,:) = va(:,:,:) 198 196 ENDIF 199 200 197 ! ! ==================== ! 201 198 ! ! Vertical advection ! 202 DO jk = 1, jpkm1! ==================== !203 ! ! Vertical volume fluxesÊ204 zfw(:,:,jk) = 0.25 * e1e2t(:,:) * wn(:,:,jk)205 !206 IF( jk == 1 ) THEN ! surface/bottom advective fluxes207 zfu_uw( :,:,jpk) = 0.e0 ! Bottom value : flux set to zero208 zfv_vw( :,:,jpk) = 0.e0209 ! ! Surface value :210 IF( .NOT.ln_linssh ) THEN ! variable volume : flux set to zero211 zfu_uw(:,:, 1 ) = 0._wp212 zfv_vw(:,:, 1 ) = 0._wp213 ELSE ! constant volume : advection through the surface214 DO jj = 2, jpjm1215 DO ji = fs_2, fs_jpim1216 zfu_uw(ji,jj, 1 ) = 2._wp * ( zfw(ji,jj,1) + zfw(ji+1,jj ,1) ) * un(ji,jj,1)217 zfv_vw(ji,jj, 1 ) = 2._wp * ( zfw(ji,jj,1) + zfw(ji ,jj+1,1) ) * vn(ji,jj,1)218 END DO219 END DO220 ENDIF221 ELSE ! interior fluxes222 DO jj = 2, jpjm1223 DO ji = fs_2, fs_jpim1 ! vector opt.224 zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) )225 zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) )226 END DO227 END DO228 ENDIF229 END DO230 DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence231 DO jj = 2, jpjm1232 DO ji = fs_2, fs_jpim1 ! vector opt.233 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) &234 & / ( e1e2u(ji,jj) * e3u_n(ji,jj,jk) )235 va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) &236 & / ( e1e2v(ji,jj) * e3v_n(ji,jj,jk))237 END DO 238 END DO 239 END DO 240 ! 241 IF( l_trddyn ) THEN 199 ! ! ==================== ! 200 DO jj = 2, jpjm1 ! surface/bottom advective fluxes set to zero 201 DO ji = fs_2, fs_jpim1 202 zfu_uw(ji,jj,jpk) = 0._wp 203 zfv_vw(ji,jj,jpk) = 0._wp 204 zfu_uw(ji,jj, 1 ) = 0._wp 205 zfv_vw(ji,jj, 1 ) = 0._wp 206 END DO 207 END DO 208 IF( ln_linssh ) THEN ! constant volume : advection through the surface 209 DO jj = 2, jpjm1 210 DO ji = fs_2, fs_jpim1 211 zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) 212 zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) 213 END DO 214 END DO 215 ENDIF 216 DO jk = 2, jpkm1 ! interior fluxes 217 DO jj = 2, jpjm1 218 DO ji = fs_2, fs_jpim1 219 zfw(ji,jj,jk) = 0.25 * e1e2t(ji,jj) * wn(ji,jj,jk) 220 END DO 221 END DO 222 DO jj = 2, jpjm1 223 DO ji = fs_2, fs_jpim1 ! vector opt. 224 zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) 225 zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) 226 END DO 227 END DO 228 END DO 229 DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence 230 DO jj = 2, jpjm1 231 DO ji = fs_2, fs_jpim1 ! vector opt. 232 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 233 va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 234 END DO 235 END DO 236 END DO 237 ! 238 IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic 242 239 zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 243 240 zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 244 241 CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 245 242 ENDIF 246 ! 243 ! ! Control print 247 244 IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' ubs2 adv - Ua: ', mask1=umask, & 248 245 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90
r5845 r5883 63 63 zm1_2dt = - 1._wp / ( 2._wp * rdt ) 64 64 65 IF( l_trddyn ) THEN ! temporary save of ua and vatrends66 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv )65 IF( l_trddyn ) THEN ! trends: store the input trends 66 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 67 67 ztrdu(:,:,:) = ua(:,:,:) 68 68 ztrdv(:,:,:) = va(:,:,:) … … 80 80 END DO 81 81 END DO 82 83 IF ( ln_isfcav ) THEN82 ! 83 IF( ln_isfcav ) THEN ! ocean cavities 84 84 DO jj = 2, jpjm1 85 85 DO ji = 2, jpim1 … … 97 97 END DO 98 98 END IF 99 100 99 ! 101 IF( l_trddyn ) THEN ! save the vertical diffusive trendsfor further diagnostics100 IF( l_trddyn ) THEN ! trends: send trends to trddyn for further diagnostics 102 101 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 103 102 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 104 103 CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt ) 105 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )104 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 106 105 ENDIF 107 106 ! ! print mean trends (used for debugging) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_lap_blp.F90
r5866 r5883 4 4 !! Ocean dynamics: lateral viscosity trend (laplacian and bilaplacian) 5 5 !!====================================================================== 6 !! History : OPA ! 1990-09 (G. Madec) Original code 7 !! 4.0 ! 1991-11 (G. Madec) 8 !! 6.0 ! 1996-01 (G. Madec) statement function for e3 and ahm 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 !! - ! 2004-08 (C. Talandier) New trends organization 11 !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, 12 !! ! add velocity dependent coefficient and optional read in file 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 13 7 !!---------------------------------------------------------------------- 14 8 -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r5429 r5883 4 4 !! Ocean : lateral boundary conditions 5 5 !!===================================================================== 6 !! History : OPA ! 1997-06 (G. Madec) 7 !! NEMO 1.0 ! 2002-09 (G. Madec) 6 !! History : OPA ! 1997-06 (G. Madec) Original code 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'lbc_bdy_lnk' 10 !! and lbc_obc_lnk' routine to optimize 11 !! the BDY/OBC communications 12 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add a C1D case 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 13 11 !!---------------------------------------------------------------------- 14 12 #if defined key_mpp_mpi … … 22 20 USE lib_mpp ! distributed memory computing library 23 21 24 25 22 INTERFACE lbc_lnk_multi 26 23 MODULE PROCEDURE mpp_lnk_2d_9 27 24 END INTERFACE 28 25 ! 29 26 INTERFACE lbc_lnk 30 27 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 31 28 END INTERFACE 32 29 ! 33 30 INTERFACE lbc_bdy_lnk 34 31 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 35 32 END INTERFACE 36 33 ! 37 34 INTERFACE lbc_lnk_e 38 35 MODULE PROCEDURE mpp_lnk_2d_e 39 36 END INTERFACE 40 37 ! 41 38 INTERFACE lbc_lnk_icb 42 39 MODULE PROCEDURE mpp_lnk_2d_icb 43 40 END INTERFACE 44 41 45 PUBLIC lbc_lnk ! ocean lateral boundary conditions46 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions47 PUBLIC lbc_lnk_e48 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions49 PUBLIC lbc_lnk_icb42 PUBLIC lbc_lnk ! ocean lateral boundary conditions 43 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 44 PUBLIC lbc_lnk_e ! 45 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 46 PUBLIC lbc_lnk_icb ! 50 47 51 48 !!---------------------------------------------------------------------- … … 54 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 55 52 !!---------------------------------------------------------------------- 56 57 53 #else 58 54 !!---------------------------------------------------------------------- … … 75 71 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 76 72 END INTERFACE 77 73 ! 78 74 INTERFACE lbc_lnk_e 79 75 MODULE PROCEDURE lbc_lnk_2d_e 80 76 END INTERFACE 81 77 ! 82 78 INTERFACE lbc_bdy_lnk 83 79 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 84 80 END INTERFACE 85 81 ! 86 82 INTERFACE lbc_lnk_icb 87 83 MODULE PROCEDURE lbc_lnk_2d_e … … 89 85 90 86 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 91 PUBLIC lbc_lnk_e 87 PUBLIC lbc_lnk_e ! 92 88 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 93 PUBLIC lbc_lnk_icb 89 PUBLIC lbc_lnk_icb ! 94 90 95 91 !!---------------------------------------------------------------------- … … 230 226 ! this is in mpp case. In this module, just do nothing 231 227 ELSE 232 !233 228 ! ! East-West boundaries 234 229 ! ! ====================== … … 249 244 ! 250 245 END SELECT 251 !252 246 ! ! North-South boundaries 253 247 ! ! ====================== … … 287 281 END SUBROUTINE lbc_lnk_3d 288 282 283 289 284 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 290 285 !!--------------------------------------------------------------------- … … 316 311 ! this is in mpp case. In this module, just do nothing 317 312 ELSE 318 !319 313 ! ! East-West boundaries 320 314 ! ! ==================== … … 335 329 ! 336 330 END SELECT 337 !338 331 ! ! North-South boundaries 339 332 ! ! ====================== … … 375 368 #endif 376 369 377 378 370 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 379 371 !!--------------------------------------------------------------------- … … 381 373 !! 382 374 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 383 !! to maintain the same interface with regards to the mpp384 ! case385 !! 386 !!----------------------------------------------------------------------387 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points388 REAL(wp) , DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied389 REAL(wp) , INTENT(in ) :: psgn ! control of the sign390 INTEGER :: ib_bdy ! BDY boundary set391 ! !375 !! to maintain the same interface with regards to the mpp case 376 !! 377 !!---------------------------------------------------------------------- 378 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 379 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 380 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 381 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 382 !!---------------------------------------------------------------------- 383 ! 392 384 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 393 385 ! 394 386 END SUBROUTINE lbc_bdy_lnk_3d 395 387 388 396 389 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 397 390 !!--------------------------------------------------------------------- … … 399 392 !! 400 393 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 401 !! to maintain the same interface with regards to the mpp402 ! case403 !! 404 !!----------------------------------------------------------------------405 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points406 REAL(wp) , DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied407 REAL(wp) , INTENT(in ) :: psgn ! control of the sign408 INTEGER :: ib_bdy ! BDY boundary set409 ! !394 !! to maintain the same interface with regards to the mpp case 395 !! 396 !!---------------------------------------------------------------------- 397 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 398 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 399 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 400 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 401 !!---------------------------------------------------------------------- 402 ! 410 403 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 411 404 ! 412 405 END SUBROUTINE lbc_bdy_lnk_2d 413 406 … … 426 419 !! for closed boundaries. 427 420 !!---------------------------------------------------------------------- 428 CHARACTER(len=1) , INTENT(in ) 429 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) 430 REAL(wp) , INTENT(in ) 431 INTEGER , INTENT(in ) 432 INTEGER , INTENT(in ) 433 !!---------------------------------------------------------------------- 434 421 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 422 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 423 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 424 INTEGER , INTENT(in ) :: jpri ! size of extra halo (not needed in non-mpp) 425 INTEGER , INTENT(in ) :: jprj ! size of extra halo (not needed in non-mpp) 426 !!---------------------------------------------------------------------- 427 ! 435 428 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 436 429 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5836 r5883 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 26 !!---------------------------------------------------------------------- 27 27 … … 2662 2662 END SUBROUTINE mpp_lbc_north_e 2663 2663 2664 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2664 2665 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2665 2666 !!---------------------------------------------------------------------- 2666 2667 !! *** routine mpp_lnk_bdy_3d *** … … 2683 2684 !! 2684 2685 !!---------------------------------------------------------------------- 2685 2686 USE lbcnfd ! north fold2687 2688 INCLUDE 'mpif.h'2689 2690 2686 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2691 2687 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points … … 2694 2690 ! ! = 1. , the sign is kept 2695 2691 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2692 ! 2696 2693 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2697 INTEGER :: imigr, iihom, ijhom ! temporaryintegers2694 INTEGER :: imigr, iihom, ijhom ! local integers 2698 2695 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2699 REAL(wp) :: zland 2696 REAL(wp) :: zland ! local scalar 2700 2697 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2701 2698 ! 2702 2699 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 2703 2700 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 2704 2705 !!---------------------------------------------------------------------- 2706 2701 !!---------------------------------------------------------------------- 2702 ! 2707 2703 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 2708 2704 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2709 2705 2710 zland = 0. e02706 zland = 0.-WP 2711 2707 2712 2708 ! 1. standard boundary treatment 2713 2709 ! ------------------------------ 2714 2715 2710 ! ! East-West boundaries 2716 2711 ! !* Cyclic east-west 2717 2718 2712 IF( nbondi == 2) THEN 2719 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN2720 ptab( 1 ,:,:) = ptab(jpim1,:,:)2721 ptab(jpi,:,:) = ptab( 2 ,:,:)2722 ELSE2723 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2724 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2725 ENDIF2713 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 2714 ptab( 1 ,:,:) = ptab(jpim1,:,:) 2715 ptab(jpi,:,:) = ptab( 2 ,:,:) 2716 ELSE 2717 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2718 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2719 ENDIF 2726 2720 ELSEIF(nbondi == -1) THEN 2727 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2721 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2728 2722 ELSEIF(nbondi == 1) THEN 2729 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2723 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2730 2724 ENDIF !* closed 2731 2725 2732 2726 IF (nbondj == 2 .OR. nbondj == -1) THEN 2733 IF( .NOT. cd_type == 'F' ) ptab(:, 1:jprecj,:) = zland ! south except F-point2727 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point 2734 2728 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2735 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2736 ENDIF 2737 2738 ! 2739 2729 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north 2730 ENDIF 2731 ! 2740 2732 ! 2. East and west directions exchange 2741 2733 ! ------------------------------------ … … 2794 2786 CASE ( 0 ) 2795 2787 DO jl = 1, jpreci 2796 ptab( jl,:,:) = zt3we(:,jl,:,2)2788 ptab( jl,:,:) = zt3we(:,jl,:,2) 2797 2789 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 2798 2790 END DO 2799 2791 CASE ( 1 ) 2800 2792 DO jl = 1, jpreci 2801 ptab( jl,:,:) = zt3we(:,jl,:,2)2793 ptab( jl,:,:) = zt3we(:,jl,:,2) 2802 2794 END DO 2803 2795 END SELECT … … 2885 2877 END SUBROUTINE mpp_lnk_bdy_3d 2886 2878 2887 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2879 2880 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2888 2881 !!---------------------------------------------------------------------- 2889 2882 !! *** routine mpp_lnk_bdy_2d *** … … 2906 2899 !! 2907 2900 !!---------------------------------------------------------------------- 2908 2909 USE lbcnfd ! north fold 2910 2911 INCLUDE 'mpif.h' 2912 2913 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2914 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2915 ! ! = T , U , V , F , W points 2916 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2917 ! ! = 1. , the sign is kept 2918 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2901 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2902 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2903 ! ! = T , U , V , F , W points 2904 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2905 ! ! = 1. , the sign is kept 2906 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2907 ! 2919 2908 INTEGER :: ji, jj, jl ! dummy loop indices 2920 INTEGER :: imigr, iihom, ijhom ! temporaryintegers2909 INTEGER :: imigr, iihom, ijhom ! local integers 2921 2910 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2922 2911 REAL(wp) :: zland … … 2925 2914 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 2926 2915 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 2927 2928 2916 !!---------------------------------------------------------------------- 2929 2917 … … 2931 2919 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 2932 2920 2933 zland = 0. e02921 zland = 0._wp 2934 2922 2935 2923 ! 1. standard boundary treatment 2936 2924 ! ------------------------------ 2937 2938 2925 ! ! East-West boundaries 2939 ! !* Cyclic east-west 2940 2941 IF( nbondi == 2) THEN 2942 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2943 ptab( 1 ,:) = ptab(jpim1,:) 2944 ptab(jpi,:) = ptab( 2 ,:) 2945 ELSE 2946 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2947 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2948 ENDIF 2926 ! !* Cyclic east-west 2927 IF( nbondi == 2 ) THEN 2928 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2929 ptab( 1 ,:) = ptab(jpim1,:) 2930 ptab(jpi,:) = ptab( 2 ,:) 2931 ELSE 2932 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2933 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2934 ENDIF 2949 2935 ELSEIF(nbondi == -1) THEN 2950 IF( .NOT. cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point2936 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2951 2937 ELSEIF(nbondi == 1) THEN 2952 ptab(nlci-jpreci+1:jpi ,:) = zland ! north2953 ENDIF !* closed2954 2955 IF (nbondj == 2 .OR. nbondj == -1) THEN2956 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland! south except F-point2938 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2939 ENDIF 2940 ! !* closed 2941 IF( nbondj == 2 .OR. nbondj == -1 ) THEN 2942 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 2957 2943 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2958 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 2959 ENDIF 2960 2961 ! 2962 2944 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north 2945 ENDIF 2946 ! 2963 2947 ! 2. East and west directions exchange 2964 2948 ! ------------------------------------ … … 3107 3091 ! 3108 3092 END SUBROUTINE mpp_lnk_bdy_2d 3093 3109 3094 3110 3095 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) … … 3196 3181 END SUBROUTINE DDPDD_MPI 3197 3182 3183 3198 3184 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3199 3185 !!--------------------------------------------------------------------- … … 3218 3204 !! ! north fold, = 1. otherwise 3219 3205 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3206 ! 3220 3207 INTEGER :: ji, jj, jr 3221 3208 INTEGER :: ierr, itaille, ildi, ilei, iilb … … 3224 3211 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3225 3212 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3226 3227 3213 !!---------------------------------------------------------------------- 3228 3214 ! … … 3234 3220 ENDIF 3235 3221 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3236 3237 ! 3238 ztab_e(:,:) = 0.e0 3239 3240 ij=0 3222 ! 3223 ztab_e(:,:) = 0._wp 3224 ! 3225 ij = 0 3241 3226 ! put in znorthloc_e the last 4 jlines of pt2d 3242 3227 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj … … 3280 3265 ! 3281 3266 END SUBROUTINE mpp_lbc_north_icb 3267 3282 3268 3283 3269 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) … … 3300 3286 !! noso : number for local neighboring processors 3301 3287 !! nono : number for local neighboring processors 3302 !!3303 3288 !!---------------------------------------------------------------------- 3304 3289 INTEGER , INTENT(in ) :: jpri … … 3459 3444 3460 3445 END SUBROUTINE mpp_lnk_2d_icb 3446 3461 3447 #else 3462 3448 !!---------------------------------------------------------------------- -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r5836 r5883 4 4 !! Ocean forcing: read input field for surface boundary condition 5 5 !!===================================================================== 6 !! History : 2.0 ! 06-2006 (S. Masson, G. Madec) Original code 7 !! ! 05-2008 (S. Alderson) Modified for Interpolation in memory 8 !! ! from input grid to model grid 9 !! ! 10-2013 (D. Delrosso, P. Oddo) implement suppression of 10 !! ! land point prior to interpolation 6 !! History : 2.0 ! 06-2006 (S. Masson, G. Madec) Original code 7 !! ! 05-2008 (S. Alderson) Modified for Interpolation in memory from input grid to model grid 8 !! ! 10-2013 (D. Delrosso, P. Oddo) suppression of land point prior to interpolation 11 9 !!---------------------------------------------------------------------- 12 10 … … 15 13 !! surface boundary condition 16 14 !!---------------------------------------------------------------------- 17 USE oce 18 USE dom_oce 19 USE phycst ! ???20 USE in_out_manager 21 USE iom 22 USE geo2ocean 23 USE lib_mpp 24 USE wrk_nemo 25 USE lbclnk 26 USE ioipsl, ONLY :ymds2ju, ju2ymds ! for calendar15 USE oce ! ocean dynamics and tracers 16 USE dom_oce ! ocean space and time domain 17 USE phycst ! physical constant 18 USE in_out_manager ! I/O manager 19 USE iom ! I/O manager library 20 USE geo2ocean ! for vector rotation on to model grid 21 USE lib_mpp ! MPP library 22 USE wrk_nemo ! work arrays 23 USE lbclnk ! ocean lateral boundary conditions (C1D case) 24 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar 27 25 USE sbc_oce 28 26 … … 60 58 INTEGER , DIMENSION(2) :: nrec_b ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year) 61 59 INTEGER , DIMENSION(2) :: nrec_a ! after record (1: index, 2: second since Jan. 1st 00h of nit000 year) 62 REAL(wp) , ALLOCATABLE, DIMENSION(:,:,: ) :: fnow 63 REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:,:) :: fdta 60 REAL(wp) , ALLOCATABLE, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step 61 REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields 64 62 CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key 65 63 ! ! into the WGTLIST structure … … 133 131 INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option 134 132 INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! provide fields at time other than "now" 135 136 137 138 ! !139 INTEGER :: itmp ! temporary variable140 INTEGER :: imf ! size of the structure sd141 INTEGER :: jf ! dummy indices142 INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend143 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step144 INTEGER :: it_offset ! local time offset variable145 LOGICAL :: llnxtyr ! open next year file?146 LOGICAL :: llnxtmth ! open next month file?147 LOGICAL :: llstop ! stop is the file does not exist133 ! ! kt_offset = -1 => fields at "before" time level 134 ! ! kt_offset = +1 => fields at "after" time level 135 ! ! etc. 136 ! 137 INTEGER :: itmp ! temporary variable 138 INTEGER :: imf ! size of the structure sd 139 INTEGER :: jf ! dummy indices 140 INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend 141 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step 142 INTEGER :: it_offset ! local time offset variable 143 LOGICAL :: llnxtyr ! open next year file? 144 LOGICAL :: llnxtmth ! open next month file? 145 LOGICAL :: llstop ! stop is the file does not exist 148 146 LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields 149 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation150 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation151 CHARACTER(LEN=1000) :: clfmt 152 TYPE(MAP_POINTER) :: imap ! global-to-local mapping indices147 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 148 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 149 CHARACTER(LEN=1000) :: clfmt ! write format 150 TYPE(MAP_POINTER) :: imap ! global-to-local mapping indices 153 151 !!--------------------------------------------------------------------- 154 152 ll_firstcall = kt == nit000 … … 299 297 END DO ! --- end loop over field --- ! 300 298 ! 301 ! ! ====================================== ! 302 ENDIF ! update field at each kn_fsbc time-step ! 303 ! ! ====================================== ! 299 ENDIF 304 300 ! 305 301 END SUBROUTINE fld_read … … 333 329 llprevday = .FALSE. 334 330 isec_week = 0 335 331 ! 336 332 ! define record informations 337 333 CALL fld_rec( kn_fsbc, sdjf, ldbefore = .TRUE. ) ! return before values in sdjf%nrec_a (as we will swap it later) 338 334 ! 339 335 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 340 336 ! 341 337 IF( sdjf%ln_tint ) THEN ! we need to read the previous record and we will put it in the current record structure 342 338 ! 343 339 IF( sdjf%nrec_a(1) == 0 ) THEN ! we redefine record sdjf%nrec_a(1) with the last record of previous year file 344 340 IF ( sdjf%nfreqh == -12 ) THEN ! yearly mean … … 391 387 ! 392 388 CALL fld_clopn( sdjf, iyear, imonth, iday, .NOT. llprev ) 393 389 ! 394 390 ! if previous year/month/day file does not exist, we switch to the current year/month/day 395 391 IF( llprev .AND. sdjf%num <= 0 ) THEN … … 401 397 CALL fld_clopn( sdjf ) 402 398 ENDIF 403 399 ! 404 400 IF( llprev ) THEN ! check if the record sdjf%nrec_a(1) exists in the file 405 401 idvar = iom_varid( sdjf%num, sdjf%clvar ) ! id of the variable sdjf%clvar … … 408 404 sdjf%nrec_a(1) = MIN( sdjf%nrec_a(1), inrec ) ! make sure we select an existing record 409 405 ENDIF 410 411 ! read before data in after arrays(as we will swap it later) 412 CALL fld_get( sdjf, map ) 413 406 ! 407 CALL fld_get( sdjf, map ) ! read before data in after arrays(as we will swap it later) 408 ! 414 409 clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" 415 410 IF(lwp) WRITE(numout, clfmt) TRIM(sdjf%clvar), sdjf%nrec_a(1), REAL(sdjf%nrec_a(2),wp)/rday 416 411 ! 417 412 ENDIF 418 413 ! … … 435 430 LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.) 436 431 INTEGER , INTENT(in ), OPTIONAL :: kit ! index of barotropic subcycle 437 432 ! ! used only if sdjf%ln_tint = .TRUE. 438 433 INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! Offset of required time level compared to "now" 439 440 ! !434 ! ! time level in units of time steps. 435 ! 441 436 LOGICAL :: llbefore ! local definition of ldbefore 442 437 INTEGER :: iendrec ! end of this record (in seconds) … … 592 587 !! ** Purpose : read the data 593 588 !!---------------------------------------------------------------------- 594 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables595 TYPE(MAP_POINTER), INTENT(in) :: map! global-to-local mapping indices596 ! !597 INTEGER :: ipk! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk )598 INTEGER :: iw! index into wgts array599 INTEGER :: ipdom! index of the domain600 INTEGER :: idvar! variable ID601 INTEGER :: idmspc! number of spatial dimensions602 LOGICAL :: lmoor! C1D case: point data589 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables 590 TYPE(MAP_POINTER), INTENT(in ) :: map ! global-to-local mapping indices 591 ! 592 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 593 INTEGER :: iw ! index into wgts array 594 INTEGER :: ipdom ! index of the domain 595 INTEGER :: idvar ! variable ID 596 INTEGER :: idmspc ! number of spatial dimensions 597 LOGICAL :: lmoor ! C1D case: point data 603 598 !!--------------------------------------------------------------------- 604 599 ! … … 611 606 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 612 607 CALL wgt_list( sdjf, iw ) 613 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2),&614 &sdjf%nrec_a(1), sdjf%lsmname )615 ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fnow(:,:,: ),&616 &sdjf%nrec_a(1), sdjf%lsmname )608 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fdta(:,:,:,2), & 609 & sdjf%nrec_a(1), sdjf%lsmname ) 610 ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fnow(:,:,: ), & 611 & sdjf%nrec_a(1), sdjf%lsmname ) 617 612 ENDIF 618 613 ELSE 619 IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ;ipdom = jpdom_data620 ELSE ;ipdom = jpdom_unknown614 IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ; ipdom = jpdom_data 615 ELSE ; ipdom = jpdom_unknown 621 616 ENDIF 622 617 ! C1D case: If product of spatial dimensions == ipk, then x,y are of 623 618 ! size 1 (point/mooring data): this must be read onto the central grid point 624 619 idvar = iom_varid( sdjf%num, sdjf%clvar ) 625 idmspc = iom_file ( sdjf%num )%ndims( idvar )620 idmspc = iom_file ( sdjf%num )%ndims( idvar ) 626 621 IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 627 lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk)622 lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk ) 628 623 ! 629 624 SELECT CASE( ipk ) … … 660 655 ! 661 656 sdjf%rotn(2) = .false. ! vector not yet rotated 662 657 ! 663 658 END SUBROUTINE fld_get 659 664 660 665 661 SUBROUTINE fld_map( num, clvar, dta, nrec, map ) … … 688 684 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 689 685 !!--------------------------------------------------------------------- 690 686 ! 691 687 ipi = SIZE( dta, 1 ) 692 688 ipj = 1 693 689 ipk = SIZE( dta, 3 ) 694 690 ! 695 691 idvar = iom_varid( num, clvar ) 696 692 ilendta = iom_file(num)%dimsz(1,idvar) … … 698 694 #if defined key_bdy 699 695 ipj = iom_file(num)%dimsz(2,idvar) 700 IF ( map%ll_unstruc) THEN! unstructured open boundary data file696 IF( map%ll_unstruc) THEN ! unstructured open boundary data file 701 697 dta_read => dta_global 702 ELSE ! structured open boundary data file698 ELSE ! structured open boundary data file 703 699 dta_read => dta_global2 704 700 ENDIF 705 701 #endif 706 702 707 IF(lwp) WRITE(numout,*) 'Dim size for ', TRIM(clvar),' is ', ilendta703 IF(lwp) WRITE(numout,*) 'Dim size for ', TRIM(clvar),' is ', ilendta 708 704 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 709 705 ! 710 706 SELECT CASE( ipk ) 711 707 CASE(1) ; CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) … … 713 709 END SELECT 714 710 ! 715 IF ( map%ll_unstruc ) THEN! unstructured open boundary data file711 IF( map%ll_unstruc ) THEN ! unstructured open boundary data file 716 712 DO ib = 1, ipi 717 713 DO ik = 1, ipk … … 728 724 END DO 729 725 ENDIF 730 726 ! 731 727 END SUBROUTINE fld_map 732 728 … … 738 734 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction 739 735 !!---------------------------------------------------------------------- 740 INTEGER , INTENT(in ) :: kt ! ocean time step 741 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 742 !! 743 INTEGER :: ju,jv,jk,jn ! loop indices 744 INTEGER :: imf ! size of the structure sd 745 INTEGER :: ill ! character length 746 INTEGER :: iv ! indice of V component 736 INTEGER , INTENT(in ) :: kt ! ocean time step 737 TYPE(FLD), DIMENSION(:), INTENT(inout) :: sd ! input field related variables 738 ! 739 INTEGER :: ju, jv, jk, jn ! loop indices 740 INTEGER :: imf ! size of the structure sd 741 INTEGER :: ill ! character length 742 INTEGER :: iv ! indice of V component 743 CHARACTER (LEN=100) :: clcomp ! dummy weight name 747 744 REAL(wp), POINTER, DIMENSION(:,:) :: utmp, vtmp ! temporary arrays for vector rotation 748 CHARACTER (LEN=100) :: clcomp ! dummy weight name 749 !!--------------------------------------------------------------------- 750 751 CALL wrk_alloc( jpi,jpj, utmp, vtmp ) 752 745 !!--------------------------------------------------------------------- 746 ! 747 CALL wrk_alloc( jpi,jpj, utmp, vtmp ) 748 ! 753 749 !! (sga: following code should be modified so that pairs arent searched for each time 754 750 ! … … 786 782 END DO 787 783 ! 788 CALL wrk_dealloc( jpi,jpj, utmp, vtmp )784 CALL wrk_dealloc( jpi,jpj, utmp, vtmp ) 789 785 ! 790 786 END SUBROUTINE fld_rot … … 802 798 INTEGER, OPTIONAL, INTENT(in ) :: kday ! day value 803 799 LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 804 ! !800 ! 805 801 LOGICAL :: llprevyr ! are we reading previous year file? 806 802 LOGICAL :: llprevmth ! are we reading previous month file? … … 853 849 ! 854 850 IF( TRIM(clname) /= TRIM(sdjf%clname) .OR. sdjf%num == 0 ) THEN ! new file to be open 855 851 ! 856 852 sdjf%clname = TRIM(clname) 857 853 IF( sdjf%num /= 0 ) CALL iom_close( sdjf%num ) ! close file if already open 858 854 CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) 859 855 ! 860 856 ! find the last record to be read -> update sdjf%nreclast 861 857 indexyr = iyear - nyear + 1 … … 866 862 CASE ( 2 ) ; imonth_len = 31 ! next year -> imonth = 1 867 863 END SELECT 868 864 ! 869 865 ! last record to be read in the current file 870 866 IF ( sdjf%nfreqh == -12 ) THEN ; sdjf%nreclast = 1 ! yearly mean … … 880 876 ENDIF 881 877 ENDIF 882 878 ! 883 879 ENDIF 884 880 ! … … 901 897 INTEGER :: jf ! dummy indices 902 898 !!--------------------------------------------------------------------- 903 899 ! 904 900 DO jf = 1, SIZE(sdf) 905 901 sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname ) … … 923 919 sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 924 920 END DO 925 921 ! 926 922 IF(lwp) THEN ! control print 927 923 WRITE(numout,*) … … 943 939 END DO 944 940 ENDIF 945 941 ! 946 942 END SUBROUTINE fld_fill 947 943 … … 958 954 TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file 959 955 INTEGER , INTENT(inout) :: kwgt ! index of weights 960 ! !956 ! 961 957 INTEGER :: kw, nestid ! local integer 962 958 LOGICAL :: found ! local logical … … 966 962 !! weights filename is either present or we hit the end of the list 967 963 found = .FALSE. 968 964 ! 969 965 !! because agrif nest part of filenames are now added in iom_open 970 966 !! to distinguish between weights files on the different grids, need to track … … 1028 1024 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 1029 1025 !! 1030 INTEGER :: jn ! dummy loop indices 1031 INTEGER :: inum ! temporary logical unit 1032 INTEGER :: id ! temporary variable id 1033 INTEGER :: ipk ! temporary vertical dimension 1034 CHARACTER (len=5) :: aname 1026 INTEGER :: jn ! dummy loop indices 1027 INTEGER :: inum ! local logical unit 1028 INTEGER :: id ! local variable id 1029 INTEGER :: ipk ! local vertical dimension 1030 INTEGER :: zwrap ! local integer 1031 LOGICAL :: cyclical ! 1032 CHARACTER (len=5) :: aname ! 1035 1033 INTEGER , DIMENSION(:), ALLOCATABLE :: ddims 1036 1034 INTEGER , POINTER, DIMENSION(:,:) :: data_src 1037 1035 REAL(wp), POINTER, DIMENSION(:,:) :: data_tmp 1038 LOGICAL :: cyclical 1039 INTEGER :: zwrap ! local integer 1040 !!---------------------------------------------------------------------- 1041 ! 1042 CALL wrk_alloc( jpi,jpj, data_src ) ! integer 1043 CALL wrk_alloc( jpi,jpj, data_tmp ) 1036 !!---------------------------------------------------------------------- 1037 ! 1038 CALL wrk_alloc( jpi,jpj, data_src ) ! integer 1039 CALL wrk_alloc( jpi,jpj, data_tmp ) 1044 1040 ! 1045 1041 IF( nxt_wgt > tot_wgts ) THEN … … 1151 1147 ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt+3, ref_wgts(nxt_wgt)%jpjwgt+3 ,ipk) ) 1152 1148 IF( ref_wgts(nxt_wgt)%cyclic ) ALLOCATE( ref_wgts(nxt_wgt)%col(1,ref_wgts(nxt_wgt)%jpjwgt+3,ipk) ) 1153 1149 ! 1154 1150 nxt_wgt = nxt_wgt + 1 1155 1151 ! 1156 1152 ELSE 1157 1153 CALL ctl_stop( ' fld_weight : unable to read the file ' ) … … 1166 1162 1167 1163 1168 SUBROUTINE apply_seaoverland( clmaskfile,zfieldo,jpi1_lsm,jpi2_lsm,jpj1_lsm,&1169 & jpj2_lsm, itmpi,itmpj,itmpz,rec1_lsm,recn_lsm)1164 SUBROUTINE apply_seaoverland( clmaskfile, zfieldo, jpi1_lsm, jpi2_lsm, jpj1_lsm, & 1165 & jpj2_lsm, itmpi, itmpj, itmpz, rec1_lsm, recn_lsm ) 1170 1166 !!--------------------------------------------------------------------- 1171 1167 !! *** ROUTINE apply_seaoverland *** … … 1176 1172 !! D. Delrosso INGV 1177 1173 !!---------------------------------------------------------------------- 1178 INTEGER :: inum,jni,jnj,jnz,jc ! temporary indices1179 INTEGER, INTENT(in ) :: itmpi,itmpj,itmpz ! lengths1180 INTEGER, INTENT(in) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices1181 INTEGER, DIMENSION(3), INTENT(in) :: rec1_lsm,recn_lsm ! temporary arrays for start and length1182 REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application1183 REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! temporary array for land point detection1184 REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points1185 REAL(wp),DIMENSION (:,: ), ALLOCATABLE :: zfield ! array of forcing field1186 CHARACTER (len=100), INTENT(in) :: clmaskfile ! land/sea mask file name1187 !!---------------------------------------------------------------------1188 ALLOCATE ( zslmec1(itmpi,itmpj,itmpz) )1189 ALLOCATE ( zfieldn(itmpi,itmpj) )1190 ALLOCATE ( z field(itmpi,itmpj) )1191 1174 INTEGER, INTENT(in ) :: itmpi,itmpj,itmpz ! lengths 1175 INTEGER, INTENT(in ) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices 1176 INTEGER, DIMENSION(3), INTENT(in ) :: rec1_lsm,recn_lsm ! temporary arrays for start and length 1177 REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application 1178 CHARACTER (len=100), INTENT(in ) :: clmaskfile ! land/sea mask file name 1179 ! 1180 INTEGER :: inum,jni,jnj,jnz,jc ! local indices 1181 REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! local array for land point detection 1182 REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points 1183 REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field 1184 !!--------------------------------------------------------------------- 1185 ! 1186 ALLOCATE ( zslmec1(itmpi,itmpj,itmpz), zfieldn(itmpi,itmpj), zfield(itmpi,itmpj) ) 1187 ! 1192 1188 ! Retrieve the land sea mask data 1193 1189 CALL iom_open( clmaskfile, inum ) 1194 1190 SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) 1195 1191 CASE(1) 1196 1192 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), 1, rec1_lsm, recn_lsm) 1197 1193 CASE DEFAULT 1198 1194 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, recn_lsm) 1199 1195 END SELECT 1200 1196 CALL iom_close( inum ) 1201 1202 DO jnz=1,rec1_lsm(3) !! Loop over k dimension 1203 1204 DO jni=1,itmpi !! copy the original field into a tmp array 1205 DO jnj=1,itmpj !! substituting undeff over land points 1206 zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz) 1207 IF ( zslmec1(jni,jnj,jnz) == 1. ) THEN 1208 zfieldn(jni,jnj) = undeff_lsm 1209 ENDIF 1197 ! 1198 DO jnz=1,rec1_lsm(3) !! Loop over k dimension 1199 ! 1200 DO jni = 1, itmpi !! copy the original field into a tmp array 1201 DO jnj = 1, itmpj !! substituting undeff over land points 1202 zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz) 1203 IF( zslmec1(jni,jnj,jnz) == 1. ) zfieldn(jni,jnj) = undeff_lsm 1210 1204 END DO 1211 1205 END DO 1212 1213 CALL seaoverland(zfieldn,itmpi,itmpj,zfield) 1214 DO jc=1,nn_lsm 1215 CALL seaoverland(zfield,itmpi,itmpj,zfield) 1216 END DO 1217 1218 ! Check for Undeff and substitute original values 1219 IF(ANY(zfield==undeff_lsm)) THEN 1220 DO jni=1,itmpi 1221 DO jnj=1,itmpj 1222 IF (zfield(jni,jnj)==undeff_lsm) THEN 1223 zfield(jni,jnj) = zfieldo(jni,jnj,jnz) 1224 ENDIF 1225 ENDDO 1226 ENDDO 1227 ENDIF 1228 1229 zfieldo(:,:,jnz)=zfield(:,:) 1230 1231 END DO !! End Loop over k dimension 1232 1233 DEALLOCATE ( zslmec1 ) 1234 DEALLOCATE ( zfieldn ) 1235 DEALLOCATE ( zfield ) 1236 1206 ! 1207 CALL seaoverland( zfieldn, itmpi, itmpj, zfield ) 1208 DO jc = 1, nn_lsm 1209 CALL seaoverland( zfield, itmpi, itmpj, zfield ) 1210 END DO 1211 ! 1212 ! Check for Undeff and substitute original values 1213 IF( ANY(zfield==undeff_lsm) ) THEN 1214 DO jni = 1, itmpi 1215 DO jnj = 1, itmpj 1216 IF( zfield(jni,jnj)==undeff_lsm ) zfield(jni,jnj) = zfieldo(jni,jnj,jnz) 1217 END DO 1218 END DO 1219 ENDIF 1220 ! 1221 zfieldo(:,:,jnz) = zfield(:,:) 1222 ! 1223 END DO !! End Loop over k dimension 1224 ! 1225 DEALLOCATE ( zslmec1, zfieldn, zfield ) 1226 ! 1237 1227 END SUBROUTINE apply_seaoverland 1238 1228 1239 1229 1240 SUBROUTINE seaoverland( zfieldn,ileni,ilenj,zfield)1230 SUBROUTINE seaoverland( zfieldn, ileni, ilenj, zfield ) 1241 1231 !!--------------------------------------------------------------------- 1242 1232 !! *** ROUTINE seaoverland *** … … 1245 1235 !! D. Delrosso INGV 1246 1236 !!---------------------------------------------------------------------- 1247 INTEGER,INTENT(in) :: ileni,ilenj ! lengths 1248 REAL,DIMENSION (ileni,ilenj),INTENT(in) :: zfieldn ! array of forcing field with undeff for land points 1249 REAL,DIMENSION (ileni,ilenj),INTENT(out) :: zfield ! array of forcing field 1250 REAL,DIMENSION (ileni,ilenj) :: zmat1,zmat2,zmat3,zmat4 ! temporary arrays for seaoverland application 1251 REAL,DIMENSION (ileni,ilenj) :: zmat5,zmat6,zmat7,zmat8 ! temporary arrays for seaoverland application 1252 REAL,DIMENSION (ileni,ilenj) :: zlsm2d ! temporary arrays for seaoverland application 1253 REAL,DIMENSION (ileni,ilenj,8) :: zlsm3d ! temporary arrays for seaoverland application 1254 LOGICAL,DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection 1255 LOGICAL,DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection 1237 INTEGER , INTENT(in ) :: ileni,ilenj ! lengths 1238 REAL, DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points 1239 REAL, DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field 1240 ! 1241 REAL , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays 1242 REAL , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - 1243 REAL , DIMENSION (ileni,ilenj) :: zlsm2d ! - - 1244 REAL , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - 1245 LOGICAL, DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection 1246 LOGICAL, DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection 1256 1247 !!---------------------------------------------------------------------- 1257 zmat8 = eoshift( zfieldn , SHIFT=-1, BOUNDARY = (/zfieldn(:,1)/) ,DIM=2)1258 zmat1 = eoshift( zmat8 , SHIFT=-1, BOUNDARY = (/zmat8(1,:)/) ,DIM=1)1259 zmat2 = eoshift( zfieldn , SHIFT=-1, BOUNDARY = (/zfieldn(1,:)/) ,DIM=1)1260 zmat4 = eoshift( zfieldn , SHIFT= 1, BOUNDARY = (/zfieldn(:,ilenj)/),DIM=2)1261 zmat3 = eoshift( zmat4 , SHIFT=-1, BOUNDARY = (/zmat4(1,:)/) ,DIM=1)1262 zmat5 = eoshift( zmat4 , SHIFT= 1, BOUNDARY = (/zmat4(ileni,:)/) ,DIM=1)1263 zmat6 = eoshift( zfieldn , SHIFT= 1, BOUNDARY = (/zfieldn(ileni,:)/),DIM=1)1264 zmat7 = eoshift( zmat8 , SHIFT= 1, BOUNDARY = (/zmat8(ileni,:)/) ,DIM=1)1265 1248 zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) 1249 zmat1 = eoshift( zmat8 , SHIFT=-1 , BOUNDARY = (/zmat8(1,:)/) , DIM=1 ) 1250 zmat2 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(1,:)/) , DIM=1 ) 1251 zmat4 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(:,ilenj)/) , DIM=2 ) 1252 zmat3 = eoshift( zmat4 , SHIFT=-1 , BOUNDARY = (/zmat4(1,:)/) , DIM=1 ) 1253 zmat5 = eoshift( zmat4 , SHIFT= 1 , BOUNDARY = (/zmat4(ileni,:)/) , DIM=1 ) 1254 zmat6 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(ileni,:)/) , DIM=1 ) 1255 zmat7 = eoshift( zmat8 , SHIFT= 1 , BOUNDARY = (/zmat8(ileni,:)/) , DIM=1 ) 1256 ! 1266 1257 zlsm3d = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /)) 1267 ll_msknan3d = .not.(zlsm3d==undeff_lsm) 1268 ll_msknan2d = .not.(zfieldn==undeff_lsm) ! FALSE where is Undeff (land) 1269 zlsm2d = (SUM ( zlsm3d, 3 , ll_msknan3d ) )/(MAX(1,(COUNT( ll_msknan3d , 3 )) )) 1270 WHERE ((COUNT( ll_msknan3d , 3 )) == 0.0_wp) zlsm2d = undeff_lsm 1271 zfield = MERGE (zfieldn,zlsm2d,ll_msknan2d) 1258 ll_msknan3d = .NOT.( zlsm3d == undeff_lsm ) 1259 ll_msknan2d = .NOT.( zfieldn == undeff_lsm ) ! FALSE where is Undeff (land) 1260 zlsm2d = SUM( zlsm3d, 3 , ll_msknan3d ) / MAX( 1 , COUNT( ll_msknan3d , 3 ) ) 1261 WHERE( COUNT( ll_msknan3d , 3 ) == 0._wp ) zlsm2d = undeff_lsm 1262 zfield = MERGE( zfieldn, zlsm2d, ll_msknan2d ) 1263 ! 1272 1264 END SUBROUTINE seaoverland 1273 1265 … … 1288 1280 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 1289 1281 CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name 1290 !! 1291 REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: ztmp_fly_dta,zfieldo ! temporary array of values on input grid 1292 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 1293 INTEGER, DIMENSION(3) :: rec1_lsm,recn_lsm ! temporary arrays for start and length in case of seaoverland 1294 INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices 1295 INTEGER :: jk, jn, jm, jir, jjr ! loop counters 1296 INTEGER :: ni, nj ! lengths 1297 INTEGER :: jpimin,jpiwid ! temporary indices 1298 INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices 1299 INTEGER :: jpjmin,jpjwid ! temporary indices 1300 INTEGER :: jpjmin_lsm,jpjwid_lsm ! temporary indices 1301 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 1302 INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices 1303 INTEGER :: itmpi,itmpj,itmpz ! lengths 1304 1282 ! 1283 INTEGER, DIMENSION(3) :: rec1, recn ! temporary arrays for start and length 1284 INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland 1285 INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices 1286 INTEGER :: jk, jn, jm, jir, jjr ! loop counters 1287 INTEGER :: ni, nj ! lengths 1288 INTEGER :: jpimin,jpiwid ! temporary indices 1289 INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices 1290 INTEGER :: jpjmin,jpjwid ! temporary indices 1291 INTEGER :: jpjmin_lsm,jpjwid_lsm ! temporary indices 1292 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 1293 INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices 1294 INTEGER :: itmpi,itmpj,itmpz ! lengths 1295 REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta, zfieldo ! local array of values on input grid 1305 1296 !!---------------------------------------------------------------------- 1306 1297 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/SBC/geo2ocean.F90
r5836 r5883 5 5 !!====================================================================== 6 6 !! History : OPA ! 07-1996 (O. Marti) Original code 7 !! NEMO 1.0 ! 02-2008 (G. Madec) F90: Free form 8 !! 3.0 ! 7 !! NEMO 1.0 ! 06-2006 (G. Madec ) Free form, F90 + opt. 8 !! ! 04-2007 (S. Masson) angle: Add T, F points and bugfix in cos lateral boundary 9 !! 3.0 ! 07-2008 (G. Madec) geo2oce suppress lon/lat agruments 10 !! 3.7 ! 11-2015 (G. Madec) remove the unused repere and repcmo routines 9 11 !!---------------------------------------------------------------------- 10 12 11 13 !!---------------------------------------------------------------------- 12 !! r epcmo :13 !! angle :14 !! geo2oce :15 !! repere : old routine suppress it ???14 !! rot_rep : Rotate the Repere: geographic grid <==> stretched coordinates grid 15 !! angle : 16 !! geo2oce : 17 !! oce2geo : 16 18 !!---------------------------------------------------------------------- 17 USE dom_oce ! mesh and scale factors 18 USE phycst ! physical constants 19 USE in_out_manager ! I/O manager 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 USE lib_mpp ! MPP library 19 USE dom_oce ! mesh and scale factors 20 USE phycst ! physical constants 21 ! 22 USE in_out_manager ! I/O manager 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE lib_mpp ! MPP library 22 25 23 26 IMPLICIT NONE 24 27 PRIVATE 25 28 26 PUBLIC rot_rep, repcmo, repere, geo2oce, oce2geo ! only rot_rep should be used 27 ! repcmo and repere are keep only for compatibility. 28 ! they are only a useless overlay of rot_rep 29 30 PUBLIC obs_rot 31 32 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & 33 gsint, gcost, & ! cos/sin between model grid lines and NP direction at T point 34 gsinu, gcosu, & ! cos/sin between model grid lines and NP direction at U point 35 gsinv, gcosv, & ! cos/sin between model grid lines and NP direction at V point 36 gsinf, gcosf ! cos/sin between model grid lines and NP direction at F point 29 PUBLIC rot_rep ! called in sbccpl, fldread, and cyclone 30 PUBLIC geo2oce ! called in sbccpl 31 PUBLIC oce2geo ! called in sbccpl 32 PUBLIC obs_rot ! called in obs_rot_vel and obs_write 33 34 ! ! cos/sin between model grid lines and NP direction 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsint, gcost ! at T point 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinu, gcosu ! at U point 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinv, gcosv ! at V point 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinf, gcosf ! at F point 37 39 38 40 LOGICAL , SAVE, DIMENSION(4) :: linit = .FALSE. 39 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gsinlon, gcoslon, gsinlat, gcoslat 40 42 41 LOGICAL :: lmust_init = .TRUE. !: used to initialize the cos/sin variables (se above)43 LOGICAL :: lmust_init = .TRUE. !: used to initialize the cos/sin variables (see above) 42 44 43 45 !! * Substitutions … … 50 52 CONTAINS 51 53 52 SUBROUTINE repcmo ( pxu1, pyu1, pxv1, pyv1, &53 px2 , py2 )54 !!----------------------------------------------------------------------55 !! *** ROUTINE repcmo ***56 !!57 !! ** Purpose : Change vector componantes from a geographic grid to a58 !! stretched coordinates grid.59 !!60 !! ** Method : Initialization of arrays at the first call.61 !!62 !! ** Action : - px2 : first componante (defined at u point)63 !! - py2 : second componante (defined at v point)64 !!----------------------------------------------------------------------65 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: pxu1, pyu1 ! geographic vector componantes at u-point66 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: pxv1, pyv1 ! geographic vector componantes at v-point67 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: px2 ! i-componante (defined at u-point)68 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: py2 ! j-componante (defined at v-point)69 !!----------------------------------------------------------------------70 71 ! Change from geographic to stretched coordinate72 ! ----------------------------------------------73 CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 )74 CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 )75 76 END SUBROUTINE repcmo77 78 79 54 SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot ) 80 55 !!---------------------------------------------------------------------- … … 83 58 !! ** Purpose : Rotate the Repere: Change vector componantes between 84 59 !! geographic grid <--> stretched coordinates grid. 85 !! 86 !! History : 87 !! 9.2 ! 07-04 (S. Masson) 88 !! (O. Marti ) Original code (repere and repcmo) 89 !!---------------------------------------------------------------------- 90 REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pxin, pyin ! vector componantes 91 CHARACTER(len=1), INTENT( IN ) :: cd_type ! define the nature of pt2d array grid-points 92 CHARACTER(len=5), INTENT( IN ) :: cdtodo ! specify the work to do: 93 !! ! 'en->i' east-north componantes to model i componante 94 !! ! 'en->j' east-north componantes to model j componante 95 !! ! 'ij->e' model i-j componantes to east componante 96 !! ! 'ij->n' model i-j componantes to east componante 97 REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: prot 98 !!---------------------------------------------------------------------- 99 100 ! Initialization of gsin* and gcos* at first call 101 ! ----------------------------------------------- 102 103 IF( lmust_init ) THEN 60 !!---------------------------------------------------------------------- 61 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes 62 CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points 63 CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: 64 ! ! 'en->i' = east-north to i-component 65 ! ! 'en->j' = east-north to j-component 66 ! ! 'ij->e' = (i,j) components to east 67 ! ! 'ij->n' = (i,j) components to north 68 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot 69 !!---------------------------------------------------------------------- 70 ! 71 IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. 104 72 IF(lwp) WRITE(numout,*) 105 IF(lwp) WRITE(numout,*) ' rot_rep : geographic <--> stretched'106 IF(lwp) WRITE(numout,*) ' ~~~~~ coordinate transformation'73 IF(lwp) WRITE(numout,*) ' rot_rep: coordinate transformation : geographic <==> model (i,j)-components' 74 IF(lwp) WRITE(numout,*) ' ~~~~~~~~ ' 107 75 ! 108 76 CALL angle ! initialization of the transformation 109 77 lmust_init = .FALSE. 110 78 ENDIF 111 112 SELECT CASE (cdtodo) 113 CASE ('en->i') ! 'en->i' est-north componantes to model i componante 79 ! 80 SELECT CASE( cdtodo ) ! type of rotation 81 ! 82 CASE( 'en->i' ) ! east-north to i-component 114 83 SELECT CASE (cd_type) 115 84 CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) … … 119 88 CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 120 89 END SELECT 121 CASE ('en->j') ! 'en->j' est-north componantes to model j componante90 CASE ('en->j') ! east-north to j-component 122 91 SELECT CASE (cd_type) 123 92 CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) … … 127 96 CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 128 97 END SELECT 129 CASE ('ij->e') ! 'ij->e' model i-j componantes to est componante98 CASE ('ij->e') ! (i,j)-components to east 130 99 SELECT CASE (cd_type) 131 100 CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) … … 135 104 CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) 136 105 END SELECT 137 CASE ('ij->n') ! 'ij->n' model i-j componantes to est componante106 CASE ('ij->n') ! (i,j)-components to north 138 107 SELECT CASE (cd_type) 139 108 CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) … … 145 114 CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) 146 115 END SELECT 147 116 ! 148 117 END SUBROUTINE rot_rep 149 118 … … 155 124 !! ** Purpose : Compute angles between model grid lines and the North direction 156 125 !! 157 !! ** Method : 158 !! 159 !! ** Action : Compute (gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf) arrays: 160 !! sinus and cosinus of the angle between the north-south axe and the 161 !! j-direction at t, u, v and f-points 162 !! 163 !! History : 164 !! 7.0 ! 96-07 (O. Marti ) Original code 165 !! 8.0 ! 98-06 (G. Madec ) 166 !! 8.5 ! 98-06 (G. Madec ) Free form, F90 + opt. 167 !! 9.2 ! 07-04 (S. Masson) Add T, F points and bugfix in cos lateral boundary 168 !!---------------------------------------------------------------------- 169 INTEGER :: ji, jj ! dummy loop indices 170 INTEGER :: ierr ! local integer 171 REAL(wp) :: & 172 zlam, zphi, & ! temporary scalars 173 zlan, zphh, & ! " " 174 zxnpt, zynpt, znnpt, & ! x,y components and norm of the vector: T point to North Pole 175 zxnpu, zynpu, znnpu, & ! x,y components and norm of the vector: U point to North Pole 176 zxnpv, zynpv, znnpv, & ! x,y components and norm of the vector: V point to North Pole 177 zxnpf, zynpf, znnpf, & ! x,y components and norm of the vector: F point to North Pole 178 zxvvt, zyvvt, znvvt, & ! x,y components and norm of the vector: between V points below and above a T point 179 zxffu, zyffu, znffu, & ! x,y components and norm of the vector: between F points below and above a U point 180 zxffv, zyffv, znffv, & ! x,y components and norm of the vector: between F points left and right a V point 181 zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point 182 !!---------------------------------------------------------------------- 183 126 !! ** Method : sinus and cosinus of the angle between the north-south axe 127 !! and the j-direction at t, u, v and f-points 128 !! dot and cross products are used to obtain cos and sin, resp. 129 !! 130 !! ** Action : - gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf 131 !!---------------------------------------------------------------------- 132 INTEGER :: ji, jj ! dummy loop indices 133 INTEGER :: ierr ! local integer 134 REAL(wp) :: zlam, zphi ! local scalars 135 REAL(wp) :: zlan, zphh ! - - 136 REAL(wp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole 137 REAL(wp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole 138 REAL(wp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole 139 REAL(wp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole 140 REAL(wp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point 141 REAL(wp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point 142 REAL(wp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point 143 REAL(wp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point 144 !!---------------------------------------------------------------------- 145 ! 184 146 ALLOCATE( gsint(jpi,jpj), gcost(jpi,jpj), & 185 147 & gsinu(jpi,jpj), gcosu(jpi,jpj), & … … 187 149 & gsinf(jpi,jpj), gcosf(jpi,jpj), STAT=ierr ) 188 150 IF(lk_mpp) CALL mpp_sum( ierr ) 189 IF( ierr /= 0 ) CALL ctl_stop( 'angle: unable to allocate arrays' )190 151 IF( ierr /= 0 ) CALL ctl_stop( 'angle: unable to allocate arrays' ) 152 ! 191 153 ! ============================= ! 192 154 ! Compute the cosinus and sinus ! 193 155 ! ============================= ! 194 156 ! (computation done on the north stereographic polar plane) 195 157 ! 196 158 DO jj = 2, jpjm1 197 159 DO ji = fs_2, jpi ! vector opt. 198 199 ! north pole direction & modulous (at t-point) 200 zlam = glamt(ji,jj) 160 ! 161 zlam = glamt(ji,jj) ! north pole direction & modulous (at t-point) 201 162 zphi = gphit(ji,jj) 202 163 zxnpt = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 203 164 zynpt = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 204 165 znnpt = zxnpt*zxnpt + zynpt*zynpt 205 206 ! north pole direction & modulous (at u-point) 207 zlam = glamu(ji,jj) 166 ! 167 zlam = glamu(ji,jj) ! north pole direction & modulous (at u-point) 208 168 zphi = gphiu(ji,jj) 209 169 zxnpu = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 210 170 zynpu = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 211 171 znnpu = zxnpu*zxnpu + zynpu*zynpu 212 213 ! north pole direction & modulous (at v-point) 214 zlam = glamv(ji,jj) 172 ! 173 zlam = glamv(ji,jj) ! north pole direction & modulous (at v-point) 215 174 zphi = gphiv(ji,jj) 216 175 zxnpv = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 217 176 zynpv = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 218 177 znnpv = zxnpv*zxnpv + zynpv*zynpv 219 220 ! north pole direction & modulous (at f-point) 221 zlam = glamf(ji,jj) 178 ! 179 zlam = glamf(ji,jj) ! north pole direction & modulous (at f-point) 222 180 zphi = gphif(ji,jj) 223 181 zxnpf = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 224 182 zynpf = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) 225 183 znnpf = zxnpf*zxnpf + zynpf*zynpf 226 227 ! j-direction: v-point segment direction (around t-point) 228 zlam = glamv(ji,jj ) 184 ! 185 zlam = glamv(ji,jj ) ! j-direction: v-point segment direction (around t-point) 229 186 zphi = gphiv(ji,jj ) 230 187 zlan = glamv(ji,jj-1) … … 236 193 znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt ) ) 237 194 znvvt = MAX( znvvt, 1.e-14 ) 238 239 ! j-direction: f-point segment direction (around u-point) 240 zlam = glamf(ji,jj ) 195 ! 196 zlam = glamf(ji,jj ) ! j-direction: f-point segment direction (around u-point) 241 197 zphi = gphif(ji,jj ) 242 198 zlan = glamf(ji,jj-1) … … 248 204 znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu ) ) 249 205 znffu = MAX( znffu, 1.e-14 ) 250 251 ! i-direction: f-point segment direction (around v-point) 252 zlam = glamf(ji ,jj) 206 ! 207 zlam = glamf(ji ,jj) ! i-direction: f-point segment direction (around v-point) 253 208 zphi = gphif(ji ,jj) 254 209 zlan = glamf(ji-1,jj) … … 260 215 znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv ) ) 261 216 znffv = MAX( znffv, 1.e-14 ) 262 263 ! j-direction: u-point segment direction (around f-point) 264 zlam = glamu(ji,jj+1) 217 ! 218 zlam = glamu(ji,jj+1) ! j-direction: u-point segment direction (around f-point) 265 219 zphi = gphiu(ji,jj+1) 266 220 zlan = glamu(ji,jj ) … … 272 226 znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf ) ) 273 227 znuuf = MAX( znuuf, 1.e-14 ) 274 275 ! cosinus and sinus using scalar and vectorialproducts228 ! 229 ! ! cosinus and sinus using dot and cross products 276 230 gsint(ji,jj) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt 277 231 gcost(ji,jj) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt 278 232 ! 279 233 gsinu(ji,jj) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu 280 234 gcosu(ji,jj) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu 281 235 ! 282 236 gsinf(ji,jj) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf 283 237 gcosf(ji,jj) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf 284 285 ! (caution, rotation of 90 degres) 238 ! 286 239 gsinv(ji,jj) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv 287 gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv 288 240 gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv ! (caution, rotation of 90 degres) 241 ! 289 242 END DO 290 243 END DO … … 318 271 ! Lateral boundary conditions ! 319 272 ! =========================== ! 320 321 ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 273 ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 322 274 CALL lbc_lnk( gcost, 'T', -1. ) ; CALL lbc_lnk( gsint, 'T', -1. ) 323 275 CALL lbc_lnk( gcosu, 'U', -1. ) ; CALL lbc_lnk( gsinu, 'U', -1. ) 324 276 CALL lbc_lnk( gcosv, 'V', -1. ) ; CALL lbc_lnk( gsinv, 'V', -1. ) 325 277 CALL lbc_lnk( gcosf, 'F', -1. ) ; CALL lbc_lnk( gsinf, 'F', -1. ) 326 278 ! 327 279 END SUBROUTINE angle 328 280 329 281 330 SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, & 331 pte, ptn ) 282 SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, pte, ptn ) 332 283 !!---------------------------------------------------------------------- 333 284 !! *** ROUTINE geo2oce *** … … 335 286 !! ** Purpose : 336 287 !! 337 !! ** Method : Change wind stress from geocentric to east/north 338 !! 339 !! History : 340 !! ! (O. Marti) Original code 341 !! ! 91-03 (G. Madec) 342 !! ! 92-07 (M. Imbard) 343 !! ! 99-11 (M. Imbard) NetCDF format with IOIPSL 344 !! ! 00-08 (D. Ludicone) Reduced section at Bab el Mandeb 345 !! 8.5 ! 02-06 (G. Madec) F90: Free form 346 !! 3.0 ! 07-08 (G. Madec) geo2oce suppress lon/lat agruments 288 !! ** Method : Change a vector from geocentric to east/north 289 !! 347 290 !!---------------------------------------------------------------------- 348 291 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz 349 292 CHARACTER(len=1) , INTENT(in ) :: cgrid 350 293 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn 351 ! !294 ! 352 295 REAL(wp), PARAMETER :: rpi = 3.141592653e0 353 296 REAL(wp), PARAMETER :: rad = rpi / 180.e0 … … 355 298 INTEGER :: ierr ! local integer 356 299 !!---------------------------------------------------------------------- 357 300 ! 358 301 IF( .NOT. ALLOCATED( gsinlon ) ) THEN 359 302 ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & … … 361 304 IF( lk_mpp ) CALL mpp_sum( ierr ) 362 305 IF( ierr /= 0 ) CALL ctl_stop('geo2oce: unable to allocate arrays' ) 306 ENDIF 307 ! 308 SELECT CASE( cgrid) 309 CASE ( 'T' ) 310 ig = 1 311 IF( .NOT. linit(ig) ) THEN 312 gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) 313 gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) 314 gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) 315 gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) 316 linit(ig) = .TRUE. 317 ENDIF 318 CASE ( 'U' ) 319 ig = 2 320 IF( .NOT. linit(ig) ) THEN 321 gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) 322 gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) 323 gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) 324 gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) 325 linit(ig) = .TRUE. 326 ENDIF 327 CASE ( 'V' ) 328 ig = 3 329 IF( .NOT. linit(ig) ) THEN 330 gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) 331 gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) 332 gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) 333 gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) 334 linit(ig) = .TRUE. 335 ENDIF 336 CASE ( 'F' ) 337 ig = 4 338 IF( .NOT. linit(ig) ) THEN 339 gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) 340 gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) 341 gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) 342 gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) 343 linit(ig) = .TRUE. 344 ENDIF 345 CASE default 346 WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid 347 CALL ctl_stop( ctmp1 ) 348 END SELECT 349 ! 350 pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy 351 ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & 352 & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & 353 & + gcoslat(:,:,ig) * pzz 354 ! 355 END SUBROUTINE geo2oce 356 357 358 SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz ) 359 !!---------------------------------------------------------------------- 360 !! *** ROUTINE oce2geo *** 361 !! 362 !! ** Purpose : 363 !! 364 !! ** Method : Change vector from east/north to geocentric 365 !! 366 !! History : ! (A. Caubel) oce2geo - Original code 367 !!---------------------------------------------------------------------- 368 REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn 369 CHARACTER(len=1) , INTENT( IN ) :: cgrid 370 REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz 371 !! 372 REAL(wp), PARAMETER :: rpi = 3.141592653E0 373 REAL(wp), PARAMETER :: rad = rpi / 180.e0 374 INTEGER :: ig ! 375 INTEGER :: ierr ! local integer 376 !!---------------------------------------------------------------------- 377 378 IF( .NOT. ALLOCATED( gsinlon ) ) THEN 379 ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & 380 & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) 381 IF( lk_mpp ) CALL mpp_sum( ierr ) 382 IF( ierr /= 0 ) CALL ctl_stop('oce2geo: unable to allocate arrays' ) 363 383 ENDIF 364 384 … … 404 424 CALL ctl_stop( ctmp1 ) 405 425 END SELECT 406 407 pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy 408 ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & 409 - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & 410 + gcoslat(:,:,ig) * pzz 411 !!$ ptv = gcoslon(:,:,ig) * gcoslat(:,:,ig) * pxx & 412 !!$ + gsinlon(:,:,ig) * gcoslat(:,:,ig) * pyy & 413 !!$ + gsinlat(:,:,ig) * pzz 414 ! 415 END SUBROUTINE geo2oce 416 417 SUBROUTINE oce2geo ( pte, ptn, cgrid, & 418 pxx , pyy , pzz ) 419 !!---------------------------------------------------------------------- 420 !! *** ROUTINE oce2geo *** 421 !! 422 !! ** Purpose : 423 !! 424 !! ** Method : Change vector from east/north to geocentric 425 !! 426 !! History : 427 !! ! (A. Caubel) oce2geo - Original code 428 !!---------------------------------------------------------------------- 429 REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn 430 CHARACTER(len=1) , INTENT( IN ) :: cgrid 431 REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz 432 !! 433 REAL(wp), PARAMETER :: rpi = 3.141592653E0 434 REAL(wp), PARAMETER :: rad = rpi / 180.e0 435 INTEGER :: ig ! 436 INTEGER :: ierr ! local integer 437 !!---------------------------------------------------------------------- 438 439 IF( .NOT. ALLOCATED( gsinlon ) ) THEN 440 ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & 441 & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) 442 IF( lk_mpp ) CALL mpp_sum( ierr ) 443 IF( ierr /= 0 ) CALL ctl_stop('oce2geo: unable to allocate arrays' ) 444 ENDIF 445 446 SELECT CASE( cgrid) 447 CASE ( 'T' ) 448 ig = 1 449 IF( .NOT. linit(ig) ) THEN 450 gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) 451 gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) 452 gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) 453 gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) 454 linit(ig) = .TRUE. 455 ENDIF 456 CASE ( 'U' ) 457 ig = 2 458 IF( .NOT. linit(ig) ) THEN 459 gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) 460 gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) 461 gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) 462 gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) 463 linit(ig) = .TRUE. 464 ENDIF 465 CASE ( 'V' ) 466 ig = 3 467 IF( .NOT. linit(ig) ) THEN 468 gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) 469 gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) 470 gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) 471 gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) 472 linit(ig) = .TRUE. 473 ENDIF 474 CASE ( 'F' ) 475 ig = 4 476 IF( .NOT. linit(ig) ) THEN 477 gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) 478 gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) 479 gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) 480 gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) 481 linit(ig) = .TRUE. 482 ENDIF 483 CASE default 484 WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid 485 CALL ctl_stop( ctmp1 ) 486 END SELECT 487 488 pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn 489 pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn 490 pzz = gcoslat(:,:,ig) * ptn 491 492 426 ! 427 pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn 428 pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn 429 pzz = gcoslat(:,:,ig) * ptn 430 ! 493 431 END SUBROUTINE oce2geo 494 432 495 433 496 SUBROUTINE repere ( px1, py1, px2, py2, kchoix, cd_type ) 497 !!---------------------------------------------------------------------- 498 !! *** ROUTINE repere *** 499 !! 500 !! ** Purpose : Change vector componantes between a geopgraphic grid 501 !! and a stretched coordinates grid. 502 !! 503 !! ** Method : 504 !! 505 !! ** Action : 506 !! 507 !! History : 508 !! ! 89-03 (O. Marti) original code 509 !! ! 92-02 (M. Imbard) 510 !! ! 93-03 (M. Guyon) symetrical conditions 511 !! ! 98-05 (B. Blanke) 512 !! 8.5 ! 02-08 (G. Madec) F90: Free form 513 !!---------------------------------------------------------------------- 514 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: px1, py1 ! two horizontal components to be rotated 515 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: px2, py2 ! the two horizontal components in the model repere 516 INTEGER , INTENT(in ) :: kchoix ! type of transformation 517 ! ! = 1 change from geographic to model grid. 518 ! ! =-1 change from model to geographic grid 519 CHARACTER(len=1), INTENT(in ), OPTIONAL :: cd_type ! define the nature of pt2d array grid-points 520 ! 521 CHARACTER(len=1) :: cl_type ! define the nature of pt2d array grid-points (T point by default) 522 !!---------------------------------------------------------------------- 523 524 cl_type = 'T' 525 IF( PRESENT(cd_type) ) cl_type = cd_type 526 ! 527 SELECT CASE (kchoix) 528 CASE ( 1) ! change from geographic to model grid. 529 CALL rot_rep( px1, py1, cl_type, 'en->i', px2 ) 530 CALL rot_rep( px1, py1, cl_type, 'en->j', py2 ) 531 CASE (-1) ! change from model to geographic grid 532 CALL rot_rep( px1, py1, cl_type, 'ij->e', px2 ) 533 CALL rot_rep( px1, py1, cl_type, 'ij->n', py2 ) 534 CASE DEFAULT ; CALL ctl_stop( 'repere: Syntax Error in the definition of kchoix (1 OR -1' ) 535 END SELECT 536 537 END SUBROUTINE repere 538 539 540 SUBROUTINE obs_rot ( psinu, pcosu, psinv, pcosv ) 434 SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv ) 541 435 !!---------------------------------------------------------------------- 542 436 !! *** ROUTINE obs_rot *** … … 546 440 !! current at observation points 547 441 !! 548 !! History : 549 !! 9.2 ! 09-02 (K. Mogensen) 442 !! History : 9.2 ! 09-02 (K. Mogensen) 550 443 !!---------------------------------------------------------------------- 551 444 REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data 552 445 !!---------------------------------------------------------------------- 553 446 ! 554 447 ! Initialization of gsin* and gcos* at first call 555 448 ! ----------------------------------------------- 556 557 449 IF( lmust_init ) THEN 558 450 IF(lwp) WRITE(numout,*) 559 451 IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched' 560 452 IF(lwp) WRITE(numout,*) ' ~~~~~~~ coordinate transformation' 561 562 453 CALL angle ! initialization of the transformation 563 454 lmust_init = .FALSE. 564 565 455 ENDIF 566 456 ! 567 457 psinu(:,:) = gsinu(:,:) 568 458 pcosu(:,:) = gcosu(:,:) 569 459 psinv(:,:) = gsinv(:,:) 570 460 pcosv(:,:) = gcosv(:,:) 571 461 ! 572 462 END SUBROUTINE obs_rot 573 463 -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r5845 r5883 17 17 18 18 !!---------------------------------------------------------------------- 19 !! sbc_init 20 !! sbc 19 !! sbc_init : read namsbc namelist 20 !! sbc : surface ocean momentum, heat and freshwater boundary conditions 21 21 !!---------------------------------------------------------------------- 22 USE oce ! ocean dynamics and tracers 23 USE dom_oce ! ocean space and time domain 24 USE phycst ! physical constants 25 USE sbc_oce ! Surface boundary condition: ocean fields 26 USE trc_oce ! shared ocean-passive tracers variables 27 USE sbc_ice ! Surface boundary condition: ice fields 28 USE sbcdcy ! surface boundary condition: diurnal cycle 29 USE sbcssm ! surface boundary condition: sea-surface mean variables 30 USE sbcana ! surface boundary condition: analytical formulation 31 USE sbcflx ! surface boundary condition: flux formulation 32 USE sbcblk_clio ! surface boundary condition: bulk formulation : CLIO 33 USE sbcblk_core ! surface boundary condition: bulk formulation : CORE 34 USE sbcblk_mfs ! surface boundary condition: bulk formulation : MFS 35 USE sbcice_if ! surface boundary condition: ice-if sea-ice model 36 USE sbcice_lim ! surface boundary condition: LIM 3.0 sea-ice model 37 USE sbcice_lim_2 ! surface boundary condition: LIM 2.0 sea-ice model 38 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 39 USE sbccpl ! surface boundary condition: coupled florulation 40 USE cpl_oasis3 ! OASIS routines for coupling 41 USE sbcssr ! surface boundary condition: sea surface restoring 42 USE sbcrnf ! surface boundary condition: runoffs 43 USE sbcisf ! surface boundary condition: ice shelf 44 USE sbcfwb ! surface boundary condition: freshwater budget 45 USE closea ! closed sea 46 USE icbstp ! Icebergs! 47 48 USE prtctl ! Print control (prt_ctl routine) 49 USE iom ! IOM library 50 USE in_out_manager ! I/O manager 51 USE lib_mpp ! MPP library 52 USE timing ! Timing 53 USE sbcwave ! Wave module 54 USE bdy_par ! Require lk_bdy 22 USE oce ! ocean dynamics and tracers 23 USE dom_oce ! ocean space and time domain 24 USE phycst ! physical constants 25 USE sbc_oce ! Surface boundary condition: ocean fields 26 USE trc_oce ! shared ocean-passive tracers variables 27 USE sbc_ice ! Surface boundary condition: ice fields 28 USE sbcdcy ! surface boundary condition: diurnal cycle 29 USE sbcssm ! surface boundary condition: sea-surface mean variables 30 USE sbcana ! surface boundary condition: analytical formulation 31 USE sbcflx ! surface boundary condition: flux formulation 32 USE sbcblk_clio ! surface boundary condition: bulk formulation : CLIO 33 USE sbcblk_core ! surface boundary condition: bulk formulation : CORE 34 USE sbcblk_mfs ! surface boundary condition: bulk formulation : MFS 35 USE sbcice_if ! surface boundary condition: ice-if sea-ice model 36 USE sbcice_lim ! surface boundary condition: LIM 3.0 sea-ice model 37 USE sbcice_lim_2 ! surface boundary condition: LIM 2.0 sea-ice model 38 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 39 USE sbccpl ! surface boundary condition: coupled florulation 40 USE cpl_oasis3 ! OASIS routines for coupling 41 USE sbcssr ! surface boundary condition: sea surface restoring 42 USE sbcrnf ! surface boundary condition: runoffs 43 USE sbcisf ! surface boundary condition: ice shelf 44 USE sbcfwb ! surface boundary condition: freshwater budget 45 USE closea ! closed sea 46 USE icbstp ! Icebergs 47 USE traqsr ! active tracers: light penetration 48 USE sbcwave ! Wave module 49 USE bdy_par ! Require lk_bdy 50 ! 51 USE prtctl ! Print control (prt_ctl routine) 52 USE iom ! IOM library 53 USE in_out_manager ! I/O manager 54 USE lib_mpp ! MPP library 55 USE timing ! Timing 55 56 56 57 IMPLICIT NONE … … 83 84 INTEGER :: icpt ! local integer 84 85 !! 85 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, ln_mixcpl, & 86 & ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc , ln_rnf , & 87 & ln_ssr , nn_isf , nn_fwb, ln_cdgw , ln_wave , ln_sdw , & 88 & nn_lsm , nn_limflx , nn_components, ln_cpl 86 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, ln_blk_mfs, & 87 & ln_cpl , ln_mixcpl, nn_components , nn_limflx , & 88 & ln_traqsr, ln_dm2dc , & 89 & nn_ice , nn_ice_embd, & 90 & ln_rnf , ln_ssr , nn_isf , nn_fwb , ln_apr_dyn, & 91 & ln_wave , & 92 & nn_lsm 89 93 INTEGER :: ios 90 94 INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3, jpm 91 95 LOGICAL :: ll_purecpl 92 96 !!---------------------------------------------------------------------- 93 97 ! 94 98 IF(lwp) THEN 95 99 WRITE(numout,*) … … 97 101 WRITE(numout,*) '~~~~~~~~ ' 98 102 ENDIF 99 103 ! 100 104 REWIND( numnam_ref ) ! Namelist namsbc in reference namelist : Surface boundary 101 105 READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) 102 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp )103 106 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp ) 107 ! 104 108 REWIND( numnam_cfg ) ! Namelist namsbc in configuration namelist : Parameters of the run 105 109 READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 106 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp )107 IF(lwm) WRITE 108 110 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp ) 111 IF(lwm) WRITE( numond, namsbc ) 112 ! 109 113 ! ! overwrite namelist parameter using CPP key information 110 114 IF( Agrif_Root() ) THEN ! AGRIF zoom … … 117 121 nn_ice = 0 118 122 ENDIF 119 123 ! 120 124 IF(lwp) THEN ! Control print 121 125 WRITE(numout,*) ' Namelist namsbc (partly overwritten with CPP key setting)' 122 126 WRITE(numout,*) ' frequency update of sbc (and ice) nn_fsbc = ', nn_fsbc 123 WRITE(numout,*) ' Type of sbc : ' 124 WRITE(numout,*) ' analytical formulation ln_ana = ', ln_ana 125 WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx 126 WRITE(numout,*) ' CLIO bulk formulation ln_blk_clio = ', ln_blk_clio 127 WRITE(numout,*) ' CORE bulk formulation ln_blk_core = ', ln_blk_core 128 WRITE(numout,*) ' MFS bulk formulation ln_blk_mfs = ', ln_blk_mfs 129 WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl 130 WRITE(numout,*) ' forced-coupled mixed formulation ln_mixcpl = ', ln_mixcpl 131 WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis 132 WRITE(numout,*) ' components of your executable nn_components = ', nn_components 133 WRITE(numout,*) ' Multicategory heat flux formulation (LIM3) nn_limflx = ', nn_limflx 127 WRITE(numout,*) ' Type of air-sea fluxes : ' 128 WRITE(numout,*) ' analytical formulation ln_ana = ', ln_ana 129 WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx 130 WRITE(numout,*) ' CLIO bulk formulation ln_blk_clio = ', ln_blk_clio 131 WRITE(numout,*) ' CORE bulk formulation ln_blk_core = ', ln_blk_core 132 WRITE(numout,*) ' MFS bulk formulation ln_blk_mfs = ', ln_blk_mfs 133 WRITE(numout,*) ' Type of coupling (Ocean/Ice/Atmosphere) : ' 134 WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl 135 WRITE(numout,*) ' forced-coupled mixed formulation ln_mixcpl = ', ln_mixcpl 136 WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis 137 WRITE(numout,*) ' components of your executable nn_components = ', nn_components 138 WRITE(numout,*) ' Multicategory heat flux formulation (LIM3) nn_limflx = ', nn_limflx 139 WRITE(numout,*) ' Sea-ice : ' 140 WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice 141 WRITE(numout,*) ' ice-ocean embedded/levitating (=0/1/2) nn_ice_embd = ', nn_ice_embd 134 142 WRITE(numout,*) ' Misc. options of sbc : ' 135 WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn 136 WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice 137 WRITE(numout,*) ' ice-ocean embedded/levitating (=0/1/2) nn_ice_embd = ', nn_ice_embd 138 WRITE(numout,*) ' daily mean to diurnal cycle qsr ln_dm2dc = ', ln_dm2dc 139 WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf 140 WRITE(numout,*) ' iceshelf formulation nn_isf = ', nn_isf 141 WRITE(numout,*) ' Sea Surface Restoring on SST and/or SSS ln_ssr = ', ln_ssr 142 WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb 143 WRITE(numout,*) ' closed sea (=0/1) (set in namdom) nn_closea = ', nn_closea 144 WRITE(numout,*) ' n. of iterations if land-sea-mask applied nn_lsm = ', nn_lsm 145 ENDIF 146 147 ! LIM3 Multi-category heat flux formulation 148 SELECT CASE ( nn_limflx) 149 CASE ( -1 ) 150 IF(lwp) WRITE(numout,*) ' Use of per-category fluxes (nn_limflx = -1) ' 151 CASE ( 0 ) 152 IF(lwp) WRITE(numout,*) ' Average per-category fluxes (nn_limflx = 0) ' 153 CASE ( 1 ) 154 IF(lwp) WRITE(numout,*) ' Average then redistribute per-category fluxes (nn_limflx = 1) ' 155 CASE ( 2 ) 156 IF(lwp) WRITE(numout,*) ' Redistribute a single flux over categories (nn_limflx = 2) ' 157 END SELECT 158 ! 159 IF ( nn_components /= jp_iam_nemo .AND. .NOT. lk_oasis ) & 160 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) 161 IF ( nn_components == jp_iam_opa .AND. ln_cpl ) & 162 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) 163 IF ( nn_components == jp_iam_opa .AND. ln_mixcpl ) & 164 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) 165 IF ( ln_cpl .AND. .NOT. lk_oasis ) & 166 & CALL ctl_stop( 'STOP', 'sbc_init : OASIS-coupled atmosphere model, but key_oasis3 disabled' ) 143 WRITE(numout,*) ' Light penetration in temperature Eq. ln_traqsr = ', ln_traqsr 144 WRITE(numout,*) ' daily mean to diurnal cycle qsr ln_dm2dc = ', ln_dm2dc 145 WRITE(numout,*) ' Sea Surface Restoring on SST and/or SSS ln_ssr = ', ln_ssr 146 WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb 147 WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn 148 WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf 149 WRITE(numout,*) ' iceshelf formulation nn_isf = ', nn_isf 150 WRITE(numout,*) ' closed sea (=0/1) (set in namdom) nn_closea = ', nn_closea 151 WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm 152 WRITE(numout,*) ' surface wave ln_wave = ', ln_wave 153 ENDIF 154 ! 155 IF(lwp) THEN 156 WRITE(numout,*) 157 SELECT CASE ( nn_limflx ) ! LIM3 Multi-category heat flux formulation 158 CASE ( -1 ) ; WRITE(numout,*) ' LIM3: use per-category fluxes (nn_limflx = -1) ' 159 CASE ( 0 ) ; WRITE(numout,*) ' LIM3: use average per-category fluxes (nn_limflx = 0) ' 160 CASE ( 1 ) ; WRITE(numout,*) ' LIM3: use average then redistribute per-category fluxes (nn_limflx = 1) ' 161 CASE ( 2 ) ; WRITE(numout,*) ' LIM3: Redistribute a single flux over categories (nn_limflx = 2) ' 162 END SELECT 163 ENDIF 164 ! 165 IF( nn_components /= jp_iam_nemo .AND. .NOT. lk_oasis ) & 166 & CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) 167 IF( nn_components == jp_iam_opa .AND. ln_cpl ) & 168 & CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) 169 IF( nn_components == jp_iam_opa .AND. ln_mixcpl ) & 170 & CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) 171 IF( ln_cpl .AND. .NOT. lk_oasis ) & 172 & CALL ctl_stop( 'sbc_init : OASIS-coupled atmosphere model, but key_oasis3 disabled' ) 167 173 IF( ln_mixcpl .AND. .NOT. lk_oasis ) & 168 174 & CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires the cpp key key_oasis3' ) … … 176 182 177 183 ! ! Checks: 178 IF( nn_isf .EQ. 0 ) THEN! variable initialisation if no ice shelf184 IF( nn_isf == 0 ) THEN ! variable initialisation if no ice shelf 179 185 IF( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_isf arrays' ) 180 fwfisf (:,:) = 0. 0_wp ; fwfisf_b (:,:) = 0.0_wp181 risf_tsc(:,:,:) = 0. 0_wp ; risf_tsc_b(:,:,:) = 0.0_wp182 rdivisf = 0. 0_wp186 fwfisf (:,:) = 0._wp ; fwfisf_b (:,:) = 0._wp 187 risf_tsc(:,:,:) = 0._wp ; risf_tsc_b(:,:,:) = 0._wp 188 rdivisf = 0._wp 183 189 END IF 184 IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa ) fr_i(:,:) = 0. e0! no ice in the domain, ice fraction is always zero185 186 sfx(:,:) = 0. 0_wp! the salt flux due to freezing/melting will be computed (i.e. will be non-zero)190 IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! no ice in the domain, ice fraction is always zero 191 192 sfx(:,:) = 0._wp ! the salt flux due to freezing/melting will be computed (i.e. will be non-zero) 187 193 ! only if sea-ice is present 188 194 189 fmmflx(:,:) = 0. 0_wp! freezing-melting array initialisation195 fmmflx(:,:) = 0._wp ! freezing-melting array initialisation 190 196 191 taum(:,:) = 0. 0_wp! Initialise taum for use in gls in case of reduced restart197 taum(:,:) = 0._wp ! Initialise taum for use in gls in case of reduced restart 192 198 193 199 ! ! restartability … … 212 218 & CALL ctl_stop( 'diurnal cycle into qsr field from daily values requires a flux or core-bulk formulation' ) 213 219 214 IF ( ln_wave ) THEN215 !Activated wave module but neither drag nor stokes drift activated216 IF ( .NOT.(ln_cdgw .OR. ln_sdw) ) THEN217 CALL ctl_warn( 'Ask for wave coupling but nor drag coefficient (ln_cdgw=F) neither stokes drift activated (ln_sdw=F)' )218 !drag coefficient read from wave model definable only with mfs bulk formulae and core219 ELSEIF (ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) ) THEN220 CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core')221 ENDIF222 ELSE223 IF ( ln_cdgw .OR. ln_sdw ) &224 & CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ', &225 & 'with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ')226 ENDIF227 220 ! ! Choice of the Surface Boudary Condition (set nsbc) 228 221 ll_purecpl = ln_cpl .AND. .NOT. ln_mixcpl … … 243 236 IF(lwp) THEN 244 237 WRITE(numout,*) 245 IF( nsbc == jp_gyre ) WRITE(numout,*) ' GYRE analytical formulation' 246 IF( nsbc == jp_ana ) WRITE(numout,*) ' analytical formulation' 247 IF( nsbc == jp_flx ) WRITE(numout,*) ' flux formulation' 248 IF( nsbc == jp_clio ) WRITE(numout,*) ' CLIO bulk formulation' 249 IF( nsbc == jp_core ) WRITE(numout,*) ' CORE bulk formulation' 250 IF( nsbc == jp_purecpl ) WRITE(numout,*) ' pure coupled formulation' 251 IF( nsbc == jp_mfs ) WRITE(numout,*) ' MFS Bulk formulation' 252 IF( nsbc == jp_none ) WRITE(numout,*) ' OPA coupled to SAS via oasis' 253 IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation' 238 SELECT CASE( nsbc ) 239 CASE( jp_gyre ) ; WRITE(numout,*) ' GYRE analytical formulation' 240 CASE( jp_ana ) ; WRITE(numout,*) ' analytical formulation' 241 CASE( jp_flx ) ; WRITE(numout,*) ' flux formulation' 242 CASE( jp_clio ) ; WRITE(numout,*) ' CLIO bulk formulation' 243 CASE( jp_core ) ; WRITE(numout,*) ' CORE bulk formulation' 244 CASE( jp_purecpl ) ; WRITE(numout,*) ' pure coupled formulation' 245 CASE( jp_mfs ) ; WRITE(numout,*) ' MFS Bulk formulation' 246 CASE( jp_none ) ; WRITE(numout,*) ' OPA coupled to SAS via oasis' 247 IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation' 248 END SELECT 254 249 IF( nn_components/= jp_iam_nemo ) & 255 & WRITE(numout,*) '+ OASIS coupled SAS'250 & WRITE(numout,*) ' + OASIS coupled SAS' 256 251 ENDIF 257 252 ! 258 253 IF( lk_oasis ) CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before: (1) first time step 259 254 ! ! (2) the use of nn_fsbc 260 261 ! nn_fsbc initialization if OPA-SAS coupling via OASIS 262 ! sas model time step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly 263 IF ( nn_components /= jp_iam_nemo ) THEN 264 IF ( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) 265 IF ( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) 255 ! nn_fsbc initialization if OPA-SAS coupling via OASIS 256 ! sas model time step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly 257 IF( nn_components /= jp_iam_nemo ) THEN 258 IF( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) 259 IF( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) 266 260 ! 267 261 IF(lwp)THEN … … 271 265 ENDIF 272 266 ENDIF 273 267 ! 274 268 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. & 275 269 MOD( nstock , nn_fsbc) /= 0 ) THEN … … 284 278 IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) ) < 8 ) ) & 285 279 & CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 286 287 288 ! 289 IF( ln_ssr 290 ! 291 292 ! 293 IF( nn_ice == 3 294 295 IF( nn_ice == 4 296 280 ! 281 CALL sbc_ssm_init ! Sea-surface mean fields initialisation 282 ! 283 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialisation 284 ! 285 CALL sbc_rnf_init ! Runof initialisation 286 ! 287 IF( nn_ice == 3 ) CALL sbc_lim_init ! LIM3 initialisation 288 ! 289 IF( nn_ice == 4 ) CALL cice_sbc_init( nsbc ) ! CICE initialisation 290 ! 297 291 END SUBROUTINE sbc_init 298 292 … … 325 319 vtau_b(:,:) = vtau(:,:) ! (except at nit000 where before fields 326 320 qns_b (:,:) = qns (:,:) ! are set at the end of the routine) 327 ! The 3D heat content due to qsr forcing is treated in traqsr 328 ! qsr_b (:,:) = qsr (:,:) 329 emp_b(:,:) = emp(:,:) 330 sfx_b(:,:) = sfx(:,:) 321 emp_b (:,:) = emp (:,:) 322 sfx_b (:,:) = sfx (:,:) 331 323 ENDIF 332 324 ! ! ---------------------------------------- ! … … 334 326 ! ! ---------------------------------------- ! 335 327 ! 336 IF( nn_components /= jp_iam_sas ) CALL sbc_ssm ( kt )! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m)328 IF( nn_components /= jp_iam_sas ) CALL sbc_ssm ( kt ) ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 337 329 ! ! averaged over nf_sbc time-step 338 339 IF (ln_wave) CALL sbc_wave( kt ) 330 IF( ln_wave ) CALL sbc_wave( kt ) ! surface waves 331 332 340 333 !== sbc formulation ==! 341 334 … … 355 348 CASE( jp_mfs ) ; CALL sbc_blk_mfs ( kt ) ! bulk formulation : MFS for the ocean 356 349 CASE( jp_none ) 357 IF( nn_components == jp_iam_opa ) &358 350 IF( nn_components == jp_iam_opa ) & 351 & CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! OPA-SAS coupling: OPA receiving fields from SAS 359 352 END SELECT 360 353 361 354 IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! forced-coupled mixed formulation after forcing 362 355 363 356 ! 364 357 ! !== Misc. Options ==! 365 358 ! 366 359 SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas 367 360 CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) … … 428 421 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 429 422 ENDIF 430 431 423 ! ! ---------------------------------------- ! 432 424 ! ! Outputs and control print ! … … 450 442 ! 451 443 IF(ln_ctl) THEN ! print mean trends (used for debugging) 452 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i 453 CALL prt_ctl(tab2d_1=(emp-rnf + fwfisf), clinfo1=' emp-rnf 454 CALL prt_ctl(tab2d_1=(sfx-rnf + fwfisf), clinfo1=' sfx-rnf 444 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask, ovlap=1 ) 445 CALL prt_ctl(tab2d_1=(emp-rnf + fwfisf), clinfo1=' emp-rnf - : ', mask1=tmask, ovlap=1 ) 446 CALL prt_ctl(tab2d_1=(sfx-rnf + fwfisf), clinfo1=' sfx-rnf - : ', mask1=tmask, ovlap=1 ) 455 447 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask, ovlap=1 ) 456 448 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask, ovlap=1 ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r5866 r5883 125 125 IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required 126 126 ! 127 !!gm BUG : TO BE REMOVED !! 127 128 ! Runoff reduction only associated to the ORCA2_LIM configuration 128 129 ! when reading the NetCDF file runoff_1m_nomask.nc … … 132 133 END WHERE 133 134 ENDIF 135 !!gm end 134 136 ! 135 137 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
r5845 r5883 71 71 REAL(wp), DIMENSION(:,:,:), POINTER :: zusd_t, zvsd_t, ze3hdiv ! 3D workspace 72 72 !! 73 NAMELIST/namsbc_wave/ sn_cdg, cn_dir, sn_usd, sn_vsd, sn_wn 73 NAMELIST/namsbc_wave/ sn_cdg, cn_dir, sn_usd, sn_vsd, sn_wn, ln_cdgw , ln_sdw 74 74 !!--------------------------------------------------------------------- 75 75 ! … … 80 80 READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 81 81 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist', lwp ) 82 82 ! 83 83 REWIND( numnam_cfg ) ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model 84 84 READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) … … 86 86 IF(lwm) WRITE ( numond, namsbc_wave ) 87 87 ! 88 IF ( ln_cdgw ) THEN 88 IF(lwp) THEN ! Control print 89 WRITE(numout,*) ' Namelist namsbc_wave : surface wave setting' 90 WRITE(numout,*) ' wave drag coefficient ln_cdgw = ', ln_cdgw 91 WRITE(numout,*) ' wave stokes drift ln_sdw = ', ln_sdw 92 ENDIF 93 ! 94 IF( .NOT.( ln_cdgw .OR. ln_sdw ) ) & 95 & CALL ctl_warn( 'ln_sbcwave=T but nor drag coefficient (ln_cdgw=F) neither stokes drift activated (ln_sdw=F)' ) 96 IF( ln_cdgw .AND. .NOT.(ln_blk_mfs .OR. ln_blk_core) ) & 97 & CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core') 98 ! 99 IF( ln_cdgw ) THEN 89 100 ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg 90 101 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave: unable to allocate sf_wave structure' ) … … 96 107 cdn_wave(:,:) = 0.0 97 108 ENDIF 98 IF 109 IF( ln_sdw ) THEN 99 110 slf_i(jp_usd) = sn_usd ; slf_i(jp_vsd) = sn_vsd; slf_i(jp_wn) = sn_wn 100 111 ALLOCATE( sf_sd(3), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg … … 114 125 ENDIF 115 126 ! 116 IF ( ln_cdgw ) THEN!== Neutral drag coefficient ==!127 IF( ln_cdgw ) THEN !== Neutral drag coefficient ==! 117 128 CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing 118 129 cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) 119 130 ENDIF 120 131 ! 121 IF ( ln_sdw ) THEN !== Computation of the 3d Stokes Drift ==! 132 IF( ln_sdw ) THEN !== Computation of the 3d Stokes Drift ==! 133 ! 134 CALL wrk_alloc( jpi,jpj,jpk, zusd_t, zvsd_t, ze3hdiv ) 122 135 ! 123 136 CALL fld_read( kt, nn_fsbc, sf_sd ) !* read drag coefficient from external forcing 124 137 ! 125 ! 126 CALL wrk_alloc( jpi,jpj,jpk, zusd_t, zvsd_t, ze3hdiv ) 127 ! !* distribute it on the vertical 128 DO jk = 1, jpkm1 138 DO jk = 1, jpkm1 !* distribute it on the vertical 129 139 zusd_t(:,:,jk) = sf_sd(jp_usd)%fnow(:,:,1) * EXP( -2._wp * sf_sd(jp_wn)%fnow(:,:,1) * gdept_n(:,:,jk) ) 130 140 zvsd_t(:,:,jk) = sf_sd(jp_vsd)%fnow(:,:,1) * EXP( -2._wp * sf_sd(jp_wn)%fnow(:,:,1) * gdept_n(:,:,jk) ) 131 141 END DO 132 ! !* interpolate the stokes drift from t-point to u- and v-points 133 DO jk = 1, jpkm1 142 DO jk = 1, jpkm1 !* interpolate the stokes drift from t-point to u- and v-points 134 143 DO jj = 1, jpjm1 135 144 DO ji = 1, jpim1 -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r5866 r5883 142 142 CASE ( np_QCK ) ! QUICKEST 143 143 CALL tra_adv_qck ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) 144 !145 144 END SELECT 146 145 ! 147 ! 146 ! ! print mean trends (used for debugging) 148 147 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv - Ta: ', mask1=tmask, & 149 148 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) … … 173 172 ! 174 173 ! !== Namelist ==! 175 !176 174 REWIND( numnam_ref ) ! Namelist namtra_adv in reference namelist : Tracer advection scheme 177 175 READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 178 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp )176 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp ) 179 177 ! 180 178 REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 181 179 READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 182 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp )183 IF(lwm) WRITE 184 180 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp ) 181 IF(lwm) WRITE( numond, namtra_adv ) 182 ! 185 183 IF(lwp) THEN ! Namelist print 186 184 WRITE(numout,*) … … 201 199 WRITE(numout,*) ' QUICKEST scheme ln_traadv_qck = ', ln_traadv_qck 202 200 ENDIF 203 201 ! 204 202 ioptio = 0 !== Parameter control ==! 205 203 IF( ln_traadv_cen ) ioptio = ioptio + 1 … … 252 250 IF( ln_traadv_ubs ) nadv = np_UBS 253 251 IF( ln_traadv_qck ) nadv = np_QCK 254 252 ! 255 253 IF(lwp) THEN ! Print the choice 256 254 WRITE(numout,*) 257 IF( nadv == np_NO_adv ) WRITE(numout,*) ' NO T-S advection' 258 IF( nadv == np_CEN ) WRITE(numout,*) ' CEN scheme is used. Horizontal order: ', nn_cen_h, & 259 & ' Vertical order: ', nn_cen_v 260 IF( nadv == np_FCT ) WRITE(numout,*) ' FCT scheme is used. Horizontal order: ', nn_fct_h, & 261 & ' Vertical order: ', nn_fct_v 262 IF( nadv == np_FCT_zts ) WRITE(numout,*) ' use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping' 263 IF( nadv == np_MUS ) WRITE(numout,*) ' MUSCL scheme is used' 264 IF( nadv == np_UBS ) WRITE(numout,*) ' UBS scheme is used' 265 IF( nadv == np_QCK ) WRITE(numout,*) ' QUICKEST scheme is used' 255 SELECT CASE ( nadv ) 256 CASE( np_NO_adv ) ; WRITE(numout,*) ' NO T-S advection' 257 CASE( np_CEN ) ; WRITE(numout,*) ' CEN scheme is used. Horizontal order: ', nn_cen_h, & 258 & ' Vertical order: ', nn_cen_v 259 CASE( np_FCT ) ; WRITE(numout,*) ' FCT scheme is used. Horizontal order: ', nn_fct_h, & 260 & ' Vertical order: ', nn_fct_v 261 CASE( np_FCT_zts ) ; WRITE(numout,*) ' use 2nd order FCT with ', nn_fct_zts,'vertical sub-timestepping' 262 CASE( np_MUS ) ; WRITE(numout,*) ' MUSCL scheme is used' 263 CASE( np_UBS ) ; WRITE(numout,*) ' UBS scheme is used' 264 CASE( np_QCK ) ; WRITE(numout,*) ' QUICKEST scheme is used' 265 END SELECT 266 266 ENDIF 267 267 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen.F90
r5866 r5883 2 2 !!====================================================================== 3 3 !! *** MODULE traadv_cen *** 4 !! Ocean tracers: horizontal & verticaladvective trend (2nd/4th order centered)4 !! Ocean tracers: advective trend (2nd/4th order centered) 5 5 !!====================================================================== 6 6 !! History : 3.7 ! 2014-05 (G. Madec) original code … … 52 52 !! ** Method : The advection is evaluated by a 2nd or 4th order scheme 53 53 !! using now fields (leap-frog scheme). 54 !!55 54 !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal 56 55 !! = 4 ==>> 4th order - - - - 57 !!58 56 !! kn_cen_v = 2 ==>> 2nd order centered scheme on the vertical 59 57 !! = 4 ==>> 4th order COMPACT scheme - - 60 58 !! 61 !! ** Action : - update pta with the now advective tracer trends 62 !! - send trends to trdtra module for further diagnostcs 59 !! ** Action : - update pta with the now advective tracer trends 60 !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) 61 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 63 62 !!---------------------------------------------------------------------- 64 63 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 89 88 ENDIF 90 89 ! 91 ! ! surface & bottom values92 IF( .NOT.ln_linssh ) zwz(:,:, 1 ) = 0._wp ! set to zero one for all93 zwz(:,:,jpk) = 0._wp ! except at the surface in linear free surface90 ! 91 zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers 92 zwz(:,:,jpk) = 0._wp 94 93 ! 95 94 DO jn = 1, kjpt !== loop over the tracers ==! 96 95 ! 97 SELECT CASE( kn_cen_h ) 98 ! 99 CASE( 2 ) !2nd order centered96 SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --! 97 ! 98 CASE( 2 ) !* 2nd order centered 100 99 DO jk = 1, jpkm1 101 100 DO jj = 1, jpjm1 … … 107 106 END DO 108 107 ! 109 CASE( 4 ) !4th order centered110 ztu(:,:,jpk) = 0._wp 108 CASE( 4 ) !* 4th order centered 109 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 111 110 ztv(:,:,jpk) = 0._wp 112 DO jk = 1, jpkm1 !gradient113 DO jj = 2, jpjm1 ! masked derivative111 DO jk = 1, jpkm1 ! masked gradient 112 DO jj = 2, jpjm1 114 113 DO ji = fs_2, fs_jpim1 ! vector opt. 115 114 ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) … … 120 119 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn) 121 120 ! 122 DO jk = 1, jpkm1 121 DO jk = 1, jpkm1 ! Horizontal advective fluxes 123 122 DO jj = 2, jpjm1 124 123 DO ji = 1, fs_jpim1 ! vector opt. … … 139 138 END SELECT 140 139 ! 141 ! !== Vertical fluxes ==! 142 ! 143 SELECT CASE( kn_cen_v ) !* interior fluxes 144 ! 145 CASE( 2 ) ! 2nd order centered 140 SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) 141 ! 142 CASE( 2 ) !* 2nd order centered 146 143 DO jk = 2, jpk 147 144 DO jj = 2, jpjm1 … … 152 149 END DO 153 150 ! 154 CASE( 4 ) ! 4th order centered155 CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! 4th order compact interpolationof T at w-point151 CASE( 4 ) !* 4th order compact 152 CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! ztw = interpolated value of T at w-point 156 153 DO jk = 2, jpkm1 157 154 DO jj = 2, jpjm1 … … 164 161 END SELECT 165 162 ! 166 IF( ln_linssh ) THEN !* top value ( only in linear free surf.as zwz is multiplied by wmask)163 IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask) 167 164 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 168 165 DO jj = 1, jpj 169 166 DO ji = 1, jpi 170 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn) ! linear free surface167 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn) 171 168 END DO 172 169 END DO … … 182 179 & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 183 180 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 184 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))181 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 185 182 END DO 186 183 END DO 187 184 END DO 188 ! 185 ! ! trend diagnostics 189 186 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 190 187 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) … … 192 189 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 193 190 END IF 194 ! 191 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 195 192 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 196 193 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_fct.F90
r5866 r5883 53 53 !! *** ROUTINE tra_adv_fct *** 54 54 !! 55 !! ** Purpose : Compute the now trend due to total advection of 56 !! tracersand add it to the general trend of tracer equations55 !! ** Purpose : Compute the now trend due to total advection of tracers 56 !! and add it to the general trend of tracer equations 57 57 !! 58 58 !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction 59 59 !! (choice through the value of kn_fct) 60 !! - 4th order compact scheme on the vertical60 !! - on the vertical the 4th order is a compact scheme 61 61 !! - corrected flux (monotonic correction) 62 62 !! 63 !! ** Action : - update (pta) with the now advective tracer trends 64 !! - send the trends for further diagnostics 63 !! ** Action : - update pta with the now advective tracer trends 64 !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) 65 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 65 66 !!---------------------------------------------------------------------- 66 67 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 101 102 ENDIF 102 103 ! 103 ! 104 IF( .NOT.ln_linssh ) zwz(:,:, 1 ) = 0._wp ! except at the surface in linear free surface case104 ! ! surface & bottom value : flux set to zero one for all 105 zwz(:,:, 1 ) = 0._wp 105 106 zwx(:,:,jpk) = 0._wp ; zwy(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp 106 107 ! 107 108 zwi(:,:,:) = 0._wp 108 ! ! =========== 109 DO jn = 1, kjpt ! tracer loop 110 ! ! =========== 109 ! 110 DO jn = 1, kjpt !== loop over the tracers ==! 111 111 ! 112 112 ! !== upstream advection with initial mass fluxes & intermediate update ==! … … 126 126 END DO 127 127 ! !* upstream tracer flux in the k direction *! 128 DO jk = 2, jpkm1 128 DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) 129 129 DO jj = 1, jpj 130 130 DO ji = 1, jpi … … 135 135 END DO 136 136 END DO 137 !138 137 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) 139 138 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface … … 155 154 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 156 155 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 157 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))156 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 158 157 ! update and guess with monotonic sheme 159 158 !!gm why tmask added in the two following lines ??? the mask is done in tranxt ! … … 174 173 ENDIF 175 174 ! 176 !177 175 ! !== anti-diffusive flux : high order minus low order ==! 178 176 ! 179 SELECT CASE( kn_fct_h ) 180 ! 181 CASE( 2 ) !2nd order centered177 SELECT CASE( kn_fct_h ) !* horizontal anti-diffusive fluxes 178 ! 179 CASE( 2 ) !- 2nd order centered 182 180 DO jk = 1, jpkm1 183 181 DO jj = 1, jpjm1 … … 189 187 END DO 190 188 ! 191 CASE( 4 ) !4th order centered192 zltu(:,:,jpk) = 0._wp 189 CASE( 4 ) !- 4th order centered 190 zltu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 193 191 zltv(:,:,jpk) = 0._wp 194 DO jk = 1, jpkm1 195 DO jj = 1, jpjm1 ! First derivative (gradient)192 DO jk = 1, jpkm1 ! Laplacian 193 DO jj = 1, jpjm1 ! 1st derivative (gradient) 196 194 DO ji = 1, fs_jpim1 ! vector opt. 197 195 ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) … … 199 197 END DO 200 198 END DO 201 DO jj = 2, jpjm1 !199 DO jj = 2, jpjm1 ! 2nd derivative * 1/ 6 202 200 DO ji = fs_2, fs_jpim1 ! vector opt. 203 201 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 … … 206 204 END DO 207 205 END DO 208 !209 206 CALL lbc_lnk( zltu, 'T', 1. ) ; CALL lbc_lnk( zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn) 210 207 ! 211 DO jk = 1, jpkm1 208 DO jk = 1, jpkm1 ! Horizontal advective fluxes 212 209 DO jj = 1, jpjm1 213 210 DO ji = 1, fs_jpim1 ! vector opt. … … 221 218 END DO 222 219 ! 223 CASE( 41 ) !4th order centered ==>> !!gm coding attempt need to be tested224 ztu(:,:,jpk) = 0._wp 220 CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested 221 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 225 222 ztv(:,:,jpk) = 0._wp 226 DO jk = 1, jpkm1 ! gradient227 DO jj = 1, jpjm1 ! First derivative (gradient)223 DO jk = 1, jpkm1 ! 1st derivative (gradient) 224 DO jj = 1, jpjm1 228 225 DO ji = 1, fs_jpim1 ! vector opt. 229 226 ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) … … 234 231 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn) 235 232 ! 236 DO jk = 1, jpkm1 233 DO jk = 1, jpkm1 ! Horizontal advective fluxes 237 234 DO jj = 2, jpjm1 238 235 DO ji = 2, fs_jpim1 ! vector opt. … … 250 247 ! 251 248 END SELECT 252 ! !* vertical anti-diffusive fluxes253 SELECT CASE( kn_fct_v ) ! Interior values (w-masked)254 ! 255 CASE( 2 ) !2nd order centered249 ! 250 SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values) 251 ! 252 CASE( 2 ) !- 2nd order centered 256 253 DO jk = 2, jpkm1 257 254 DO jj = 2, jpjm1 258 255 DO ji = fs_2, fs_jpim1 259 zwz(ji,jj,jk) = ( 0.5_wp * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) & 260 - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 261 END DO 262 END DO 263 END DO 264 ! 265 CASE( 4 ) ! 4th order COMPACT 266 ! 267 CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! COMPACT interpolation of T at w-point 268 ! 256 zwz(ji,jj,jk) = ( pwn(ji,jj,jk) * 0.5_wp * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) & 257 & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 258 END DO 259 END DO 260 END DO 261 ! 262 CASE( 4 ) !- 4th order COMPACT 263 CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! zwt = COMPACT interpolation of T at w-point 269 264 DO jk = 2, jpkm1 270 265 DO jj = 2, jpjm1 … … 276 271 ! 277 272 END SELECT 278 ! ! top ocean value: high order = upstream ==>> zwz=0 279 zwz(:,:, 1 ) = 0._wp ! only ocean surface as interior zwz values have been w-masked 273 IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0 274 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 275 ENDIF 280 276 ! 281 277 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions 282 278 CALL lbc_lnk( zwz, 'W', 1. ) 283 279 ! 284 280 ! !== monotonicity algorithm ==! 285 281 ! 286 282 CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) 287 288 283 ! 289 284 ! !== final trend with corrected fluxes ==! 290 285 ! … … 300 295 END DO 301 296 ! 302 IF( l_trd ) THEN 297 IF( l_trd ) THEN ! trend diagnostics (contribution of upstream fluxes) 303 298 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 304 299 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed … … 311 306 CALL wrk_dealloc( jpi,jpj,jpk, ztrdx, ztrdy, ztrdz ) 312 307 END IF 313 ! 308 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 314 309 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 315 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:)316 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:)310 IF( jn == jp_tem ) htr_adv(:) = htr_adv(:) + ptr_sj( zwy(:,:,:) ) 311 IF( jn == jp_sal ) str_adv(:) = str_adv(:) + ptr_sj( zwy(:,:,:) ) 317 312 ENDIF 318 313 ! 319 END DO 314 END DO ! end of tracer loop 320 315 ! 321 316 CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw ) … … 392 387 zr_p2dt(:) = 1._wp / p2dt(:) 393 388 ! 389 ! surface & Bottom value : flux set to zero for all tracers 390 zwz(:,:, 1 ) = 0._wp 391 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp 392 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp 393 ! 394 394 ! ! =========== 395 395 DO jn = 1, kjpt ! tracer loop 396 396 ! ! =========== 397 ! 1. Bottom value : flux set to zero 398 ! ---------------------------------- 399 zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp 400 zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp 401 402 ! 2. upstream advection with initial mass fluxes & intermediate update 403 ! -------------------------------------------------------------------- 404 ! upstream tracer flux in the i and j direction 405 DO jk = 1, jpkm1 397 ! 398 ! Upstream advection with initial mass fluxes & intermediate update 399 DO jk = 1, jpkm1 ! upstream tracer flux in the i and j direction 406 400 DO jj = 1, jpjm1 407 401 DO ji = 1, fs_jpim1 ! vector opt. … … 416 410 END DO 417 411 END DO 418 419 ! upstream tracer flux in the k direction 420 DO jk = 2, jpkm1 ! Interior value 412 ! ! upstream tracer flux in the k direction 413 DO jk = 2, jpkm1 ! Interior value 421 414 DO jj = 1, jpj 422 415 DO ji = 1, jpi … … 427 420 END DO 428 421 END DO 429 ! ! top value 430 IF( .NOT.ln_linssh ) THEN ! variable volume: only k=1 as zwz is multiplied by wmask 431 zwz(:,:, 1 ) = 0._wp 432 ELSE ! linear free surface 433 IF( ln_isfcav ) THEN ! ice-shelf cavities 422 IF( ln_linssh ) THEN ! top value : linear free surface case only (as zwz is multiplied by wmask) 423 IF( ln_isfcav ) THEN ! ice-shelf cavities: top value 434 424 DO jj = 1, jpj 435 425 DO ji = 1, jpi … … 437 427 END DO 438 428 END DO 439 ELSE ! standard case429 ELSE ! no cavities, surface value 440 430 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 441 431 ENDIF … … 446 436 DO jj = 2, jpjm1 447 437 DO ji = fs_2, fs_jpim1 ! vector opt. 448 ! total intermediate advective trends438 ! ! total intermediate advective trends 449 439 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 450 440 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 451 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))452 ! update and guess with monotonic sheme441 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 442 ! ! update and guess with monotonic sheme 453 443 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 454 444 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) … … 497 487 END DO 498 488 END DO 499 489 ! 500 490 ! !* vertical anti-diffusive flux 501 491 zwz_sav(:,:,:) = zwz(:,:,:) 502 492 ztrs (:,:,:,1) = ptb(:,:,:,jn) 503 493 zwzts (:,:,:) = 0._wp 504 IF( .NOT.ln_linssh ) zwz(:,:, 1 ) = 0._wp ! surface value set to zero in vvl case505 494 ! 506 495 DO jl = 1, kn_fct_zts ! Start of sub timestepping loop … … 535 524 END DO 536 525 END DO 537 ELSE ! standard case526 ELSE ! no ocean cavities 538 527 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 539 528 ENDIF -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mus.F90
r5866 r5883 62 62 !! ld_msc_ups=T : 63 63 !! 64 !! ** Action : - update (ta,sa) with the now advective tracer trends 65 !! - send trends to trdtra module for further diagnostcs 64 !! ** Action : - update pta with the now advective tracer trends 65 !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) 66 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 66 67 !! 67 68 !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation … … 116 117 ENDIF 117 118 ! 118 ! ! =========== 119 DO jn = 1, kjpt ! tracer loop 120 ! ! =========== 121 ! I. Horizontal advective fluxes 122 ! ------------------------------ 123 ! first guess of the slopes 124 zwx(:,:,jpk) = 0.e0 ; zwy(:,:,jpk) = 0.e0 ! bottom values 125 ! interior values 126 DO jk = 1, jpkm1 119 DO jn = 1, kjpt !== loop over the tracers ==! 120 ! 121 ! !* Horizontal advective fluxes 122 ! 123 ! !-- first guess of the slopes 124 zwx(:,:,jpk) = 0.e0 ! bottom values 125 zwy(:,:,jpk) = 0._wp 126 DO jk = 1, jpkm1 ! interior values 127 127 DO jj = 1, jpjm1 128 128 DO ji = 1, fs_jpim1 ! vector opt. … … 132 132 END DO 133 133 END DO 134 ! 135 CALL lbc_lnk( zwx, 'U', -1. ) ! lateral boundary conditions on zwx, zwy (changed sign) 134 CALL lbc_lnk( zwx, 'U', -1. ) ! lateral boundary conditions (changed sign) 136 135 CALL lbc_lnk( zwy, 'V', -1. ) 137 ! !-- Slopes of tracer 138 zslpx(:,:,jpk) = 0.e0 ; zslpy(:,:,jpk) = 0.e0 ! bottom values 139 DO jk = 1, jpkm1 ! interior values 136 ! !-- Slopes of tracer 137 zslpx(:,:,jpk) = 0._wp ! bottom values 138 zslpy(:,:,jpk) = 0._wp 139 DO jk = 1, jpkm1 ! interior values 140 140 DO jj = 2, jpj 141 141 DO ji = fs_2, jpi ! vector opt. … … 148 148 END DO 149 149 ! 150 DO jk = 1, jpkm1 !Slopes limitation150 DO jk = 1, jpkm1 !-- Slopes limitation 151 151 DO jj = 2, jpj 152 152 DO ji = fs_2, jpi ! vector opt. … … 161 161 END DO 162 162 ! 163 ! !-- MUSCL horizontal advective fluxes 164 DO jk = 1, jpkm1 ! interior values 163 DO jk = 1, jpkm1 !-- MUSCL horizontal advective fluxes 165 164 zdt = p2dt(jk) 166 165 DO jj = 2, jpjm1 … … 185 184 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! lateral boundary conditions (changed sign) 186 185 ! 187 DO jk = 1, jpkm1 ! Tracer flux divergence at t-point added to the generaltrend186 DO jk = 1, jpkm1 !-- Tracer advective trend 188 187 DO jj = 2, jpjm1 189 188 DO ji = fs_2, fs_jpim1 ! vector opt. … … 194 193 END DO 195 194 END DO 196 ! ! trend diagnostics (contribution of upstream fluxes)195 ! ! trend diagnostics 197 196 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 198 197 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN … … 200 199 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 201 200 END IF 202 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)201 ! ! "Poleward" heat and salt transports 203 202 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 204 203 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 205 204 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 206 205 ENDIF 207 208 ! II.Vertical advective fluxes209 ! -----------------------------206 ! 207 ! !* Vertical advective fluxes 208 ! 210 209 ! !-- first guess of the slopes 211 210 zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions 212 zwx(:,:,jpk) = 0._wp ! surface & bottom boundary conditions213 DO jk = 2, jpkm1 211 zwx(:,:,jpk) = 0._wp 212 DO jk = 2, jpkm1 ! interior values 214 213 zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) 215 214 END DO 216 217 215 ! !-- Slopes of tracer 218 216 zslpx(:,:,1) = 0._wp ! surface values … … 220 218 DO jj = 1, jpj 221 219 DO ji = 1, jpi 222 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & 223 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 224 END DO 225 END DO 226 END DO 227 ! !-- Slopes limitation 228 DO jk = 2, jpkm1 ! interior values 229 DO jj = 1, jpj 220 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & 221 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 222 END DO 223 END DO 224 END DO 225 DO jk = 2, jpkm1 !-- Slopes limitation 226 DO jj = 1, jpj ! interior values 230 227 DO ji = 1, jpi 231 228 zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & … … 235 232 END DO 236 233 END DO 237 ! !-- vertical advective flux 238 DO jk = 1, jpkm1 ! interior values 234 DO jk = 1, jpk-2 !-- vertical advective flux 239 235 zdt = p2dt(jk) 240 236 DO jj = 2, jpjm1 … … 242 238 z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 243 239 zalpha = 0.5 + z0w 244 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt / ( e1e2t(ji,jj) * e3w_n(ji,jj,jk+1))240 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * r1_e1e2t(ji,jj) / e3w_n(ji,jj,jk+1) 245 241 zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 246 242 zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) … … 249 245 END DO 250 246 END DO 251 ! ! top values (bottom already set to zero) 252 IF( ln_linssh ) THEN !* linear free surface 253 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 247 IF( ln_linssh ) THEN ! top values, linear free surface only 248 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 254 249 DO jj = 1, jpj 255 250 DO ji = 1, jpi … … 257 252 END DO 258 253 END DO 259 ELSE 254 ELSE ! no cavities: only at the ocean surface 260 255 zwx(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 261 256 ENDIF 262 ELSE !* non-linear free surface263 zwx(:,:, 1 ) = 0._wp ! k=1 only as zwx has been multiplied by wmask264 257 ENDIF 265 258 ! 266 DO jk = 1, jpkm1 ! Compute & add thevertical advective trend259 DO jk = 1, jpkm1 !-- vertical advective trend 267 260 DO jj = 2, jpjm1 268 261 DO ji = fs_2, fs_jpim1 ! vector opt. 269 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))270 END DO 271 END DO 272 END DO 273 ! ! Save the vertical advectivetrends for diagnostic262 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 263 END DO 264 END DO 265 END DO 266 ! ! send trends for diagnostic 274 267 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 275 268 &( cdtype == 'TRC' .AND. l_trdtrc ) ) & 276 269 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 277 270 ! 278 END DO 271 END DO ! end of tracer loop 279 272 ! 280 273 CALL wrk_dealloc( jpi,jpj,jpk, zslpx, zslpy, zwx, zwy ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r5866 r5883 78 78 !! prevent the appearance of spurious numerical oscillations 79 79 !! 80 !! ** Action : - update (pta) with the now advective tracer trends 81 !! - save the trends 80 !! ** Action : - update pta with the now advective tracer trends 81 !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) 82 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 82 83 !! 83 84 !! ** Reference : Leonard (1979, 1991) … … 105 106 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 106 107 ! 107 ! I. Thehorizontal fluxes are computed with the QUICKEST + ULTIMATE scheme108 ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 108 109 CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt ) 109 110 CALL tra_adv_qck_j( kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt ) 110 111 111 ! II. Thevertical fluxes are computed with the 2nd order centered scheme112 ! ! vertical fluxes are computed with the 2nd order centered scheme 112 113 CALL tra_adv_cen2_k( kt, cdtype, pwn, ptn, pta, kjpt ) 113 114 ! … … 224 225 END DO 225 226 END DO 226 ! ! trend diagnostics (contribution of upstream fluxes)227 ! ! trend diagnostics 227 228 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 228 229 ! … … 348 349 END DO 349 350 END DO 350 ! ! trend diagnostics (contribution of upstream fluxes)351 ! ! trend diagnostics 351 352 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 352 353 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 381 382 CALL wrk_alloc( jpi,jpj,jpk, zwz ) 382 383 ! 383 ! ! surface & bottom values 384 IF( .NOT.ln_linssh ) zwz(:,:, 1 ) = 0._wp ! set to zero one for all 385 zwz(:,:,jpk) = 0._wp ! except at the surface in linear free surface 384 zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers 385 zwz(:,:,jpk) = 0._wp 386 386 ! 387 387 ! ! =========== … … 403 403 END DO 404 404 END DO 405 ELSE ! no ice-shelfcavities (only ocean surface)405 ELSE ! no ocean cavities (only ocean surface) 406 406 zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) 407 407 ENDIF … … 416 416 END DO 417 417 END DO 418 ! ! S ave the vertical advectivetrends for diagnostic418 ! ! Send trends for diagnostic 419 419 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 420 420 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r5866 r5883 71 71 !! On the vertical, the advection is evaluated using a FCT scheme, 72 72 !! as the UBS have been found to be too diffusive. 73 !!gm !! kn_ubs_v argument (not coded for the moment) 74 !! controles whether the FCT is based on a 2nd order centrered scheme (kn_ubs_v=2)75 !! or on a 4th order compactscheme (kn_ubs_v=4).73 !! kn_ubs_v argument controles whether the FCT is based on 74 !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact 75 !! scheme (kn_ubs_v=4). 76 76 !! 77 !! ** Action : - update (pta) with the now advective tracer trends 77 !! ** Action : - update pta with the now advective tracer trends 78 !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) 79 !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 78 80 !! 79 81 !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. … … 110 112 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 111 113 ! 112 zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp ! Bottom value : set to zero one for all 114 ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers 115 zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp 113 116 ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp 114 IF( .NOT.ln_linssh ) ztw(:,:, 1 ) = 0._wp ! surface value: set to zero only in vvl case115 117 ! 116 118 ! ! =========== … … 264 266 zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk) & 265 267 & + ptn(ji,jj,jk,jn) * ( pwn(ji,jj,jk) - pwn(ji,jj,jk+1) ) & 266 & / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk))268 & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 267 269 END DO 268 270 END DO -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r5845 r5883 12 12 13 13 !!---------------------------------------------------------------------- 14 !! tra_bbc : update the tracer trend at ocean bottom15 !! tra_bbc_init : initialization of geothermal heat flux trend14 !! tra_bbc : update the tracer trend at ocean bottom 15 !! tra_bbc_init : initialization of geothermal heat flux trend 16 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean variables 18 USE dom_oce ! domain: ocean 19 USE phycst ! physical constants 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 USE in_out_manager ! I/O manager 23 USE iom ! I/O manager 24 USE fldread ! read input fields 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE lib_mpp ! distributed memory computing library 27 USE prtctl ! Print control 28 USE wrk_nemo ! Memory Allocation 29 USE timing ! Timing 17 USE oce ! ocean variables 18 USE dom_oce ! domain: ocean 19 USE phycst ! physical constants 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 ! 23 USE in_out_manager ! I/O manager 24 USE iom ! xIOS 25 USE fldread ! read input fields 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 USE lib_mpp ! distributed memory computing library 28 USE prtctl ! Print control 29 USE wrk_nemo ! Memory Allocation 30 USE timing ! Timing 30 31 31 32 IMPLICIT NONE … … 42 43 REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) :: qgh_trd0 ! geothermal heating trend 43 44 44 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh 45 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) 45 46 46 47 !!---------------------------------------------------------------------- … … 67 68 !! Where Qsf is the geothermal heat flux. 68 69 !! 69 !! ** Action : - update the temperature trends (ta) with the trend of70 !! the ocean bottom boundary condition70 !! ** Action : - update the temperature trends with geothermal heating trend 71 !! - send the trend for further diagnostics (ln_trdtra=T) 71 72 !! 72 73 !! References : Stein, C. A., and S. Stein, 1992, Nature, 359, 123-129. … … 74 75 !!---------------------------------------------------------------------- 75 76 INTEGER, INTENT(in) :: kt ! ocean time-step index 76 !! 77 INTEGER :: ji, jj, ik ! dummy loop indices 78 REAL(wp) :: zqgh_trd ! geothermal heat flux trend 77 ! 78 INTEGER :: ji, jj ! dummy loop indices 79 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt 80 80 !!---------------------------------------------------------------------- … … 82 82 IF( nn_timing == 1 ) CALL timing_start('tra_bbc') 83 83 ! 84 IF( l_trdtra ) THEN ! Save t a and sa trends85 CALL wrk_alloc( jpi, jpj, jpk,ztrdt )84 IF( l_trdtra ) THEN ! Save the input temperature trend 85 CALL wrk_alloc( jpi,jpj,jpk, ztrdt ) 86 86 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 87 87 ENDIF 88 ! 89 ! ! Add the geothermal heat flux trend on temperature 88 ! ! Add the geothermal trend on temperature 90 89 DO jj = 2, jpjm1 91 90 DO ji = 2, jpim1 92 ik = mbkt(ji,jj) 93 zqgh_trd = qgh_trd0(ji,jj) / e3t_n(ji,jj,ik) 94 tsa(ji,jj,ik,jp_tem) = tsa(ji,jj,ik,jp_tem) + zqgh_trd 91 tsa(ji,jj,mbkt(ji,jj),jp_tem) = tsa(ji,jj,mbkt(ji,jj),jp_tem) + qgh_trd0(ji,jj) / e3t_n(ji,jj,mbkt(ji,jj)) 95 92 END DO 96 93 END DO … … 98 95 CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 99 96 ! 100 IF( l_trdtra ) THEN ! S ave the geothermal heat fluxtrend for diagnostics97 IF( l_trdtra ) THEN ! Send the trend for diagnostics 101 98 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 102 99 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 103 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt )100 CALL wrk_dealloc( jpi,jpj,jpk, ztrdt ) 104 101 ENDIF 105 102 ! … … 126 123 !! ** Action : - read/fix the geothermal heat qgh_trd0 127 124 !!---------------------------------------------------------------------- 128 USE iom129 !!130 125 INTEGER :: ji, jj ! dummy loop indices 131 126 INTEGER :: inum ! temporary logical unit … … 138 133 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 139 134 !!---------------------------------------------------------------------- 140 135 ! 141 136 REWIND( numnam_ref ) ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 142 137 READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 143 138 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp ) 144 139 ! 145 140 REWIND( numnam_cfg ) ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 146 141 READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 147 142 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp ) 148 143 IF(lwm) WRITE ( numond, nambbc ) 149 144 ! 150 145 IF(lwp) THEN ! Control print 151 146 WRITE(numout,*) … … 158 153 WRITE(numout,*) 159 154 ENDIF 160 155 ! 161 156 IF( ln_trabbc ) THEN !== geothermal heating ==! 162 157 ! … … 189 184 WRITE(ctmp1,*) ' bad flag value for nn_geoflx = ', nn_geoflx 190 185 CALL ctl_stop( ctmp1 ) 191 !192 186 END SELECT 193 187 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r5845 r5883 111 111 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl') 112 112 ! 113 IF( l_trdtra ) THEN !* Save t a and satrends113 IF( l_trdtra ) THEN !* Save the input trends 114 114 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 115 115 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 131 131 ! 132 132 END IF 133 133 ! 134 134 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl 135 135 ! … … 145 145 END IF 146 146 147 IF( l_trdtra ) THEN ! s ave the horizontal diffusive trends for further diagnostics147 IF( l_trdtra ) THEN ! send the trends for further diagnostics 148 148 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 149 149 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) … … 301 301 ! 302 302 END DO 303 ! ! =========== 304 END DO ! end tracer 305 ! ! =========== 306 ! 303 ! ! =========== 304 END DO ! end tracer 305 ! ! =========== 307 306 IF( nn_timing == 1 ) CALL timing_stop( 'tra_bbl_adv') 308 307 ! … … 339 338 INTEGER , INTENT(in ) :: kit000 ! first time step index 340 339 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 341 ! !340 ! 342 341 INTEGER :: ji, jj ! dummy loop indices 343 342 INTEGER :: ik ! local integers … … 400 399 ! 401 400 ENDIF 402 401 ! 403 402 ! !-------------------! 404 403 IF( nn_bbl_adv /= 0 ) THEN ! advective bbl ! … … 499 498 INTEGER :: ios ! - - 500 499 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 501 ! !500 ! 502 501 NAMELIST/nambbl/ nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 503 502 !!---------------------------------------------------------------------- … … 505 504 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl_init') 506 505 ! 507 CALL wrk_alloc( jpi, jpj, zmbk )508 !509 510 506 REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 511 507 READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) … … 544 540 END DO 545 541 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 542 CALL wrk_alloc( jpi, jpj, zmbk ) 546 543 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 547 544 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 545 CALL wrk_dealloc( jpi, jpj, zmbk ) 548 546 549 547 !* sign of grad(H) at u- and v-points … … 592 590 ENDIF 593 591 ! 594 CALL wrk_dealloc( jpi, jpj, zmbk )595 !596 592 IF( nn_timing == 1 ) CALL timing_stop( 'tra_bbl_init') 597 593 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r5845 r5883 31 31 USE dtatsd ! data: temperature & salinity 32 32 USE zdfmxl ! vertical physics: mixed layer depth 33 ! 33 34 USE in_out_manager ! I/O manager 34 35 USE lib_mpp ! MPP library … … 41 42 PRIVATE 42 43 43 PUBLIC tra_dmp ! routinecalled by step.F9044 PUBLIC tra_dmp_init ! routinecalled by nemogcm.F9044 PUBLIC tra_dmp ! called by step.F90 45 PUBLIC tra_dmp_init ! called by nemogcm.F90 45 46 46 47 ! !!* Namelist namtra_dmp : T & S newtonian damping * … … 88 89 !! below the well mixed layer (nlmdmp=2) 89 90 !! 90 !! ** Action : - (ta,sa)tracer trends updated with the damping trend91 !! ** Action : - tsa: tracer trends updated with the damping trend 91 92 !!---------------------------------------------------------------------- 92 93 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 176 177 !!---------------------------------------------------------------------- 177 178 INTEGER :: ios, imask ! local integers 178 ! !179 ! 179 180 NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto 180 181 !!---------------------------------------------------------------------- … … 228 229 END SUBROUTINE tra_dmp_init 229 230 231 !!====================================================================== 230 232 END MODULE tradmp -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r5845 r5883 12 12 13 13 !!---------------------------------------------------------------------- 14 !! tra_ldf : update the tracer trend with the lateral diffusion 15 !! tra_ldf_init : initialization, namelist read, and parameters control 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and tracers 18 USE dom_oce ! ocean space and time domain 19 USE phycst ! physical constants 20 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 21 USE ldfslp ! lateral diffusion: iso-neutral slope 22 USE traldf_lap ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap routine) 23 USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine) 24 USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine) 25 USE traldf_blp ! lateral diffusion (iso-level lap/blp) (tra_ldf_lap routine) 26 USE trd_oce ! trends: ocean variables 27 USE trdtra ! ocean active tracers trends 14 !! tra_ldf : update the tracer trend with the lateral diffusion trend 15 !! tra_ldf_init : initialization, namelist read, and parameters control 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and tracers 18 USE dom_oce ! ocean space and time domain 19 USE phycst ! physical constants 20 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. 21 USE ldfslp ! lateral diffusion: iso-neutral slope 22 USE traldf_lap_blp ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap/_blp routines) 23 USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine ) 24 USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine ) 25 USE trd_oce ! trends: ocean variables 26 USE trdtra ! ocean active tracers trends 28 27 ! 29 28 USE prtctl ! Print control … … 71 70 ! 72 71 SELECT CASE ( nldf ) !* compute lateral mixing trend and add it to the general trend 73 !74 72 CASE ( np_lap ) ! laplacian: iso-level operator 75 73 CALL tra_ldf_lap ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsa, jpts, 1 ) … … 81 79 CALL tra_ldf_blp ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb , tsa, jpts, nldf ) 82 80 END SELECT 83 81 ! 84 82 IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics 85 83 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) … … 113 111 WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' 114 112 WRITE(numout,*) '~~~~~~~~~~~' 115 WRITE(numout,*) ' Namelist namtra_ldf already read in ldftra module'116 WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters'113 WRITE(numout,*) ' Namelist namtra_ldf: already read in ldftra module' 114 WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters' 117 115 WRITE(numout,*) 118 116 ENDIF … … 177 175 ENDIF 178 176 ! 179 IF( ierr == 1 ) CALL ctl_stop( ' iso-level in z-coordinate -partial step, not allowed' )177 IF( ierr == 1 ) CALL ctl_stop( 'iso-level in z-partial step, not allowed' ) 180 178 IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & 181 & CALL ctl_stop( ' eddy induced velocity on tracers requires isopycnal', &182 & ' laplacian diffusion' )179 & CALL ctl_stop( 'eddy induced velocity on tracers requires iso-neutral laplacian diffusion' ) 180 ! 183 181 IF( nldf == np_lap_i .OR. nldf == np_lap_it .OR. & 184 182 & nldf == np_blp_i .OR. nldf == np_blp_it ) l_ldfslp = .TRUE. ! slope of neutral surfaces required … … 186 184 IF(lwp) THEN 187 185 WRITE(numout,*) 188 IF( nldf == np_no_ldf ) WRITE(numout,*) ' NO lateral diffusion' 189 IF( nldf == np_lap ) WRITE(numout,*) ' laplacian iso-level operator' 190 IF( nldf == np_lap_i ) WRITE(numout,*) ' Rotated laplacian operator (standard)' 191 IF( nldf == np_lap_it ) WRITE(numout,*) ' Rotated laplacian operator (triad)' 192 IF( nldf == np_blp ) WRITE(numout,*) ' bilaplacian iso-level operator' 193 IF( nldf == np_blp_i ) WRITE(numout,*) ' Rotated bilaplacian operator (standard)' 194 IF( nldf == np_blp_it ) WRITE(numout,*) ' Rotated bilaplacian operator (triad)' 186 SELECT CASE( nldf ) 187 CASE( np_no_ldf ) ; WRITE(numout,*) ' NO lateral diffusion' 188 CASE( np_lap ) ; WRITE(numout,*) ' laplacian iso-level operator' 189 CASE( np_lap_i ) ; WRITE(numout,*) ' Rotated laplacian operator (standard)' 190 CASE( np_lap_it ) ; WRITE(numout,*) ' Rotated laplacian operator (triad)' 191 CASE( np_blp ) ; WRITE(numout,*) ' bilaplacian iso-level operator' 192 CASE( np_blp_i ) ; WRITE(numout,*) ' Rotated bilaplacian operator (standard)' 193 CASE( np_blp_it ) ; WRITE(numout,*) ' Rotated bilaplacian operator (triad)' 194 END SELECT 195 195 ENDIF 196 196 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r5845 r5883 14 14 15 15 !!---------------------------------------------------------------------- 16 !! tra_ldf_iso : update the tracer trend with the horizontal component of a iso-neutral laplacian operator17 !! and with the vertical part of the isopycnal or geopotential s-coord. operator16 !! tra_ldf_iso : update the tracer trend with the horizontal component of a iso-neutral laplacian operator 17 !! and with the vertical part of the isopycnal or geopotential s-coord. operator 18 18 !!---------------------------------------------------------------------- 19 USE oce 20 USE dom_oce 21 USE trc_oce 22 USE zdf_oce 23 USE ldftra 24 USE ldfslp 25 USE diaptr 19 USE oce ! ocean dynamics and active tracers 20 USE dom_oce ! ocean space and time domain 21 USE trc_oce ! share passive tracers/Ocean variables 22 USE zdf_oce ! ocean vertical physics 23 USE ldftra ! lateral diffusion: tracer eddy coefficients 24 USE ldfslp ! iso-neutral slopes 25 USE diaptr ! poleward transport diagnostics 26 26 ! 27 USE in_out_manager 28 USE iom 29 USE phycst 30 USE lbclnk 31 USE wrk_nemo 32 USE timing 27 USE in_out_manager ! I/O manager 28 USE iom ! I/O library 29 USE phycst ! physical constants 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 USE wrk_nemo ! Memory Allocation 32 USE timing ! Timing 33 33 34 34 IMPLICIT NONE … … 126 126 ah_wslp2(:,:,:) = 0._wp 127 127 ENDIF 128 !129 128 ! ! set time step size (Euler/Leapfrog) 130 129 IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2dt = rdttra(1) ! at nit000 (Euler) … … 136 135 ELSE ; zsign = -1._wp 137 136 ENDIF 138 139 137 140 138 !!---------------------------------------------------------------------- … … 241 239 ENDIF 242 240 ENDIF 243 241 ! 244 242 !!---------------------------------------------------------------------- 245 243 !! II - horizontal trend (full) … … 265 263 ! END IF 266 264 !!gm 267 268 265 DO jj = 1 , jpjm1 !== Horizontal fluxes 269 266 DO ji = 1, fs_jpim1 ! vector opt. … … 298 295 END DO ! End of slab 299 296 300 301 297 !!---------------------------------------------------------------------- 302 298 !! III - vertical trend (full) 303 299 !!---------------------------------------------------------------------- 304 300 ! 305 301 ztfw(1,:,:) = 0._wp ; ztfw(jpi,:,:) = 0._wp 306 302 ! 307 303 ! Vertical fluxes 308 304 ! --------------- 309 310 ! Surface and bottom vertical fluxes set to zero 305 ! ! Surface and bottom vertical fluxes set to zero 311 306 ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp 312 307 313 ! interior (2=<jk=<jpk-1) 314 DO jk = 2, jpkm1 308 DO jk = 2, jpkm1 ! interior (2=<jk=<jpk-1) 315 309 DO jj = 2, jpjm1 316 310 DO ji = fs_2, fs_jpim1 ! vector opt. … … 336 330 END DO 337 331 END DO 338 !339 332 ! !== add the vertical 33 flux ==! 340 333 IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_blp.F90
r5861 r5883 1 MODULE traldf_lap 1 MODULE traldf_lap_blp 2 2 !!============================================================================== 3 !! *** MODULE traldf_lap ***3 !! *** MODULE traldf_lap_blp *** 4 4 !! Ocean tracers: lateral diffusivity trend (laplacian and bilaplacian) 5 5 !!============================================================================== 6 !! History : OPA ! 1987-06 (P. Andrich, D. L Hostis) Original code 7 !! ! 1991-11 (G. Madec) 8 !! ! 1995-11 (G. Madec) suppress volumetric scale factors 9 !! ! 1996-01 (G. Madec) statement function for e3 10 !! NEMO ! 2002-06 (G. Madec) F90: Free form and module 11 !! 1.0 ! 2004-08 (C. Talandier) New trends organization 12 !! ! 2005-11 (G. Madec) add zps case 13 !! 3.0 ! 2010-06 (C. Ethe, G. Madec) Merge TRA-TRC 14 !! 3.7 ! 2014-01 (G. Madec, S. Masson) re-entrant laplacian 15 !!---------------------------------------------------------------------- 16 17 !!---------------------------------------------------------------------- 18 !! tra_ldf_lap : update the tracer trend with the lateral diffusion : iso-level laplacian operator 19 !! tra_ldf_blp : update the tracer trend with the lateral diffusion : iso-level bilaplacian operator 20 !!---------------------------------------------------------------------- 21 USE oce ! ocean dynamics and active tracers 22 USE dom_oce ! ocean space and time domain 23 USE ldftra ! lateral physics: eddy diffusivity 24 USE diaptr ! poleward transport diagnostics 25 USE trc_oce ! share passive tracers/Ocean variables 26 USE zpshde ! partial step: hor. derivative (zps_hde routine) 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 7 !!---------------------------------------------------------------------- 8 9 !!---------------------------------------------------------------------- 10 !! tra_ldf_lap : tracer trend update with iso-level laplacian diffusive operator 11 !! tra_ldf_blp : tracer trend update with iso-level or iso-neutral bilaplacian operator 12 !!---------------------------------------------------------------------- 13 USE oce ! ocean dynamics and active tracers 14 USE dom_oce ! ocean space and time domain 15 USE ldftra ! lateral physics: eddy diffusivity 16 USE traldf_iso ! iso-neutral lateral diffusion (standard operator) (tra_ldf_iso routine) 17 USE traldf_triad ! iso-neutral lateral diffusion (triad operator) (tra_ldf_triad routine) 18 USE diaptr ! poleward transport diagnostics 19 USE trc_oce ! share passive tracers/Ocean variables 20 USE zpshde ! partial step: hor. derivative (zps_hde routine) 27 21 ! 28 USE in_out_manager 29 USE lbclnk 30 USE lib_mpp 31 USE timing 32 USE wrk_nemo 22 USE in_out_manager ! I/O manager 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE lib_mpp ! distribued memory computing library 25 USE timing ! Timing 26 USE wrk_nemo ! Memory allocation 33 27 34 28 IMPLICIT NONE 35 29 PRIVATE 36 30 37 PUBLIC tra_ldf_lap ! routine called by traldf.F90 31 PUBLIC tra_ldf_lap ! called by traldf.F90 32 PUBLIC tra_ldf_blp ! called by traldf.F90 33 34 ! ! Flag to control the type of lateral diffusive operator 35 INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 ! error in specification of lateral diffusion 36 INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 ! without operator (i.e. no lateral diffusive trend) 37 ! !! laplacian ! bilaplacian ! 38 INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 ! iso-level operator 39 INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 , np_blp_i = 21 ! standard iso-neutral or geopotential operator 40 INTEGER, PARAMETER, PUBLIC :: np_lap_it = 12 , np_blp_it = 22 ! triad iso-neutral or geopotential operator 38 41 39 42 !! * Substitutions … … 162 165 END SUBROUTINE tra_ldf_lap 163 166 167 168 SUBROUTINE tra_ldf_blp( kt, kit000, cdtype, pahu, pahv, pgu , pgv , & 169 & pgui, pgvi, & 170 & ptb , pta , kjpt, kldf ) 171 !!---------------------------------------------------------------------- 172 !! *** ROUTINE tra_ldf_blp *** 173 !! 174 !! ** Purpose : Compute the before lateral tracer diffusive 175 !! trend and add it to the general trend of tracer equation. 176 !! 177 !! ** Method : The lateral diffusive trends is provided by a bilaplacian 178 !! operator applied to before field (forward in time). 179 !! It is computed by two successive calls to laplacian routine 180 !! 181 !! ** Action : pta updated with the before rotated bilaplacian diffusion 182 !!---------------------------------------------------------------------- 183 INTEGER , INTENT(in ) :: kt ! ocean time-step index 184 INTEGER , INTENT(in ) :: kit000 ! first time step index 185 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 186 INTEGER , INTENT(in ) :: kjpt ! number of tracers 187 INTEGER , INTENT(in ) :: kldf ! type of operator used 188 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 189 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 190 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 191 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 192 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 193 ! 194 INTEGER :: ji, jj, jk, jn ! dummy loop indices 195 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zlap ! laplacian at t-point 196 REAL(wp), POINTER, DIMENSION(:,:,:) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) 197 REAL(wp), POINTER, DIMENSION(:,:,:) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) 198 !!--------------------------------------------------------------------- 199 ! 200 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_blp') 201 ! 202 CALL wrk_alloc( jpi,jpj,jpk,kjpt, zlap ) 203 CALL wrk_alloc( jpi,jpj, kjpt, zglu, zglv, zgui, zgvi ) 204 ! 205 IF( kt == kit000 .AND. lwp ) THEN 206 WRITE(numout,*) 207 SELECT CASE ( kldf ) 208 CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype 209 CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 210 CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 211 END SELECT 212 WRITE(numout,*) '~~~~~~~~~~~' 213 ENDIF 214 215 zlap(:,:,:,:) = 0._wp 216 ! 217 SELECT CASE ( kldf ) !== 1st laplacian applied to ptb (output in zlap) ==! 218 ! 219 CASE ( np_blp ) ! iso-level bilaplacian 220 CALL tra_ldf_lap ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, zlap, kjpt, 1 ) 221 CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) 222 CALL tra_ldf_iso ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) 223 CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) 224 CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) 225 END SELECT 226 ! 227 DO jn = 1, kjpt 228 CALL lbc_lnk( zlap(:,:,:,jn) , 'T', 1. ) ! Lateral boundary conditions (unchanged sign) 229 END DO 230 ! ! Partial top/bottom cell: GRADh( zlap ) 231 IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom 232 ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, kjpt, zlap, zglu, zglv ) ! only bottom 233 ENDIF 234 ! 235 SELECT CASE ( kldf ) !== 2nd laplacian applied to zlap (output in pta) ==! 236 ! 237 CASE ( np_blp ) ! iso-level bilaplacian 238 CALL tra_ldf_lap ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pta, kjpt, 2 ) 239 CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) 240 CALL tra_ldf_iso ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) 241 CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) 242 CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) 243 END SELECT 244 ! 245 CALL wrk_dealloc( jpi,jpj,jpk,kjpt, zlap ) 246 CALL wrk_dealloc( jpi,jpj ,kjpt, zglu, zglv, zgui, zgvi ) 247 ! 248 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_blp') 249 ! 250 END SUBROUTINE tra_ldf_blp 251 164 252 !!============================================================================== 165 END MODULE traldf_lap 253 END MODULE traldf_lap_blp -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_triad.F90
r5845 r5883 11 11 !! tra_ldf_triad : update the tracer trend with the iso-neutral laplacian triad-operator 12 12 !!---------------------------------------------------------------------- 13 USE oce 14 USE dom_oce 15 USE phycst 16 USE trc_oce 17 USE zdf_oce 18 USE ldftra 19 USE ldfslp 20 USE traldf_iso 21 USE diaptr 22 USE zpshde 13 USE oce ! ocean dynamics and active tracers 14 USE dom_oce ! ocean space and time domain 15 USE phycst ! physical constants 16 USE trc_oce ! share passive tracers/Ocean variables 17 USE zdf_oce ! ocean vertical physics 18 USE ldftra ! lateral physics: eddy diffusivity 19 USE ldfslp ! lateral physics: iso-neutral slopes 20 USE traldf_iso ! lateral diffusion (Madec operator) (tra_ldf_iso routine) 21 USE diaptr ! poleward transport diagnostics 22 USE zpshde ! partial step: hor. derivative (zps_hde routine) 23 23 ! 24 USE in_out_manager 25 USE iom 26 USE lbclnk 27 USE lib_mpp 28 USE wrk_nemo 29 USE timing 24 USE in_out_manager ! I/O manager 25 USE iom ! I/O library 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 USE lib_mpp ! MPP library 28 USE wrk_nemo ! Memory Allocation 29 USE timing ! Timing 30 30 31 31 IMPLICIT NONE … … 112 112 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 113 113 ENDIF 114 !115 114 ! ! set time step size (Euler/Leapfrog) 116 115 IF( neuler == 0 .AND. kt == kit000 ) THEN ; z2dt = rdttra(1) ! at nit000 (Euler) … … 122 121 ELSE ; zsign = -1._wp 123 122 ENDIF 124 123 ! 125 124 !!---------------------------------------------------------------------- 126 125 !! 0 - calculate ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw … … 151 150 akz (ji+ip,jj,jk+kp) = akz (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj) & 152 151 & * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 153 !152 ! 154 153 IF( ln_ldfeiv_dia ) zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & 155 154 & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew … … 249 248 ENDIF 250 249 ENDIF 251 250 ! 252 251 !!---------------------------------------------------------------------- 253 252 !! II - horizontal trend (full) … … 255 254 ! 256 255 DO jk = 1, jpkm1 257 !258 256 ! !== Vertical tracer gradient at level jk and jk+1 259 257 zdkt3d(:,:,1) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) … … 277 275 zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 278 276 zslope_iso = triadi (ji+ip,jj,jk,1-ip,kp) 279 277 ! 280 278 zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk) 281 279 ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahu is masked.... … … 289 287 END DO 290 288 END DO 291 289 ! 292 290 DO jp = 0, 1 293 291 DO kp = 0, 1 … … 311 309 END DO 312 310 END DO 313 311 ! 314 312 ELSE 315 313 ! 316 314 DO ip = 0, 1 !== Horizontal & vertical fluxes 317 315 DO kp = 0, 1 … … 324 322 zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 325 323 zslope_iso = triadi(ji+ip,jj,jk,1-ip,kp) 326 324 ! 327 325 zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk) 328 326 ! ln_botmix_triad is .F. mask zah for bottom half cells … … 336 334 END DO 337 335 END DO 338 336 ! 339 337 DO jp = 0, 1 340 338 DO kp = 0, 1 -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90
r5845 r5883 13 13 14 14 !!---------------------------------------------------------------------- 15 !! tra_npc : apply the non penetrative convection scheme16 !!---------------------------------------------------------------------- 17 USE oce 18 USE dom_oce 19 USE phycst 20 USE zdf_oce 21 USE trd_oce 22 USE trdtra 23 USE eosbn2 15 !! tra_npc : apply the non penetrative convection scheme 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and active tracers 18 USE dom_oce ! ocean space and time domain 19 USE phycst ! physical constants 20 USE zdf_oce ! ocean vertical physics 21 USE trd_oce ! ocean active tracer trends 22 USE trdtra ! ocean active tracer trends 23 USE eosbn2 ! equation of state (eos routine) 24 24 ! 25 USE lbclnk 26 USE in_out_manager 27 USE lib_mpp 28 USE wrk_nemo 29 USE timing 25 USE lbclnk ! lateral boundary conditions (or mpp link) 26 USE in_out_manager ! I/O manager 27 USE lib_mpp ! MPP library 28 USE wrk_nemo ! Memory Allocation 29 USE timing ! Timing 30 30 31 31 IMPLICIT NONE … … 54 54 !! (i.e. static stability computed locally) 55 55 !! 56 !! ** Action : - (ta,sa) after the application odthe npc scheme56 !! ** Action : - tsa: after tracers with the application of the npc scheme 57 57 !! - send the associated trends for on-line diagnostics (l_trdtra=T) 58 58 !! … … 114 114 zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem) ! temperature 115 115 zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal) ! salinity 116 116 ! 117 117 zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha 118 118 zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta 119 119 zvn2(:) = zn2(ji,jj,:) ! N^2 120 120 ! 121 121 IF( l_LB_debug ) THEN !LB debug: 122 122 lp_monitor_point = .FALSE. … … 125 125 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 126 126 ENDIF !LB debug end 127 127 ! 128 128 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 129 129 ikp = 1 ! because N2 is irrelevant at the surface level (will start at ikp=2) … … 131 131 jiter = 0 132 132 l_column_treated = .FALSE. 133 133 ! 134 134 DO WHILE ( .NOT. l_column_treated ) 135 135 ! 136 136 jiter = jiter + 1 137 137 ! 138 138 IF( jiter >= 400 ) EXIT 139 139 ! 140 140 l_bottom_reached = .FALSE. 141 141 ! 142 142 DO WHILE ( .NOT. l_bottom_reached ) 143 143 ! 144 144 ikp = ikp + 1 145 145 ! 146 146 !! Testing level ikp for instability 147 147 !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 148 148 IF( zvn2(ikp) < -zn2_zero ) THEN ! Instability found! 149 149 ! 150 150 ilayer = ilayer + 1 ! yet another instable portion of the water column found.... 151 151 ! 152 152 IF( lp_monitor_point ) THEN 153 153 WRITE(numout,*) … … 164 164 WRITE(numout,*) 165 165 ENDIF 166 167 166 ! 168 167 IF( jiter == 1 ) inpcc = inpcc + 1 169 168 ! 170 169 IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 171 170 ! 172 171 !! ikup is the uppermost point where mixing will start: 173 172 ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 174 173 ! 175 174 !! If the points above ikp-1 have N2 == 0 they must also be mixed: 176 175 IF( ikp > 2 ) THEN … … 183 182 END DO 184 183 ENDIF 185 184 ! 186 185 IF( ikup < 1 ) CALL ctl_stop( 'tra_npc : PROBLEM #1') 187 186 ! 188 187 zsum_temp = 0._wp 189 188 zsum_sali = 0._wp -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r5866 r5883 206 206 REAL(wp) :: ztn, ztd ! local scalars 207 207 !!---------------------------------------------------------------------- 208 208 ! 209 209 IF( kt == kit000 ) THEN 210 210 IF(lwp) WRITE(numout,*) … … 223 223 DO ji = 1, jpi 224 224 ztn = ptn(ji,jj,jk,jn) 225 ztd = pta(ji,jj,jk,jn) - 2. * ztn + ptb(ji,jj,jk,jn) ! 225 ztd = pta(ji,jj,jk,jn) - 2. * ztn + ptb(ji,jj,jk,jn) ! time laplacian on tracers 226 226 ! 227 227 ptb(ji,jj,jk,jn) = ztn + atfp * ztd ! ptb <-- filtered ptn … … 272 272 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt) :: psbc_tc ! surface tracer content 273 273 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt) :: psbc_tc_b ! before surface tracer content 274 275 !! 274 ! 276 275 LOGICAL :: ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf ! local logical 277 276 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 290 289 ll_traqsr = ln_traqsr ! active tracers case and solar penetration 291 290 ll_rnf = ln_rnf ! active tracers case and river runoffs 292 IF (nn_isf .GE. 1) THEN291 IF( nn_isf >= 1 ) THEN 293 292 ll_isf = .TRUE. ! active tracers case and ice shelf melting/freezing 294 293 ELSE -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r5866 r5883 2 2 !!====================================================================== 3 3 !! *** MODULE traqsr *** 4 !! Ocean physics: solar radiation penetration in the top ocean levels4 !! Ocean physics: solar radiation penetration in the top ocean levels 5 5 !!====================================================================== 6 6 !! History : OPA ! 1990-10 (B. Blanke) Original code … … 10 10 !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate 11 11 !! 3.2 ! 2009-04 (G. Madec & NEMO team) 12 !! 4.0 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 12 !! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 13 !! 3.7 ! 2015-11 (G. Madec) remove optimisation for fix volume 13 14 !!---------------------------------------------------------------------- 14 15 15 16 !!---------------------------------------------------------------------- 16 !! tra_qsr : trend due to the solar radiation penetration17 !! tra_qsr_init : solar radiation penetration initialization17 !! tra_qsr : temperature trend due to the penetration of solar radiation 18 !! tra_qsr_init : initialization of the qsr penetration 18 19 !!---------------------------------------------------------------------- 19 USE oce ! ocean dynamics and active tracers 20 USE dom_oce ! ocean space and time domain 21 USE sbc_oce ! surface boundary condition: ocean 22 USE trc_oce ! share SMS/Ocean variables 20 USE oce ! ocean dynamics and active tracers 21 USE phycst ! physical constants 22 USE dom_oce ! ocean space and time domain 23 USE sbc_oce ! surface boundary condition: ocean 24 USE trc_oce ! share SMS/Ocean variables 23 25 USE trd_oce ! trends: ocean variables 24 26 USE trdtra ! trends manager: tracers 25 USE in_out_manager ! I/O manager26 USE phycst ! physical constants27 USE prtctl 28 USE iom 29 USE fldread 30 USE restart 31 USE lib_mpp 27 ! 28 USE in_out_manager ! I/O manager 29 USE prtctl ! Print control 30 USE iom ! I/O manager 31 USE fldread ! read input fields 32 USE restart ! ocean restart 33 USE lib_mpp ! MPP library 32 34 USE wrk_nemo ! Memory Allocation 33 35 USE timing ! Timing … … 49 51 REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) 50 52 REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) 53 ! 54 INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m) 51 55 52 ! Module variables 53 REAL(wp) :: xsi0r !: inverse of rn_si0 54 REAL(wp) :: xsi1r !: inverse of rn_si1 56 INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll 57 INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data 58 INTEGER, PARAMETER :: np_2BD = 3 ! 2 bands light penetration 59 INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration 60 ! 61 INTEGER :: nqsr ! user choice of the type of light penetration 62 REAL(wp) :: xsi0r ! inverse of rn_si0 63 REAL(wp) :: xsi1r ! inverse of rn_si1 64 ! 65 REAL(wp) , DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption 55 66 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) 56 INTEGER, PUBLIC :: nksr ! levels below which the light cannot penetrate ( depth larger than 391 m)57 REAL(wp), DIMENSION(3,61) :: rkrgb !: tabulated attenuation coefficients for RGB absorption58 67 59 68 !! * Substitutions … … 71 80 !! 72 81 !! ** Purpose : Compute the temperature trend due to the solar radiation 73 !! penetration and add it to the general temperature trend.82 !! penetration and add it to the general temperature trend. 74 83 !! 75 84 !! ** Method : The profile of the solar radiation within the ocean is defined … … 82 91 !! all heat which has not been absorbed in the above levels is put 83 92 !! in the last ocean level. 84 !! In z-coordinate case, the computation is only done down to the 85 !! level where I(k) < 1.e-15 W/m2. In addition, the coefficients 86 !! used for the computation are calculated one for once as they 87 !! depends on k only. 93 !! The computation is only done down to the level where 94 !! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . 88 95 !! 89 96 !! ** Action : - update ta with the penetrative solar radiation trend 90 !! - s ave the trend in ttrd ('key_trdtra')97 !! - send trend for further diagnostics (l_trdtra=T) 91 98 !! 92 99 !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 93 100 !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 94 101 !!---------------------------------------------------------------------- 95 !96 102 INTEGER, INTENT(in) :: kt ! ocean time-step 97 103 ! 98 INTEGER :: ji, jj, jk ! dummy loop indices99 INTEGER :: irgb ! local integers100 REAL(wp) :: zchl, zcoef, z fact! local scalars101 REAL(wp) :: zc0 , zc1, zc2, zc3! - -104 INTEGER :: ji, jj, jk ! dummy loop indices 105 INTEGER :: irgb ! local integers 106 REAL(wp) :: zchl, zcoef, z1_2 ! local scalars 107 REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - 102 108 REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - - 103 REAL(wp) :: zz0 , zz1, z1_e3t! - -104 REAL(wp), POINTER, DIMENSION(:,: ):: zekb, zekg, zekr109 REAL(wp) :: zz0 , zz1 ! - - 110 REAL(wp), POINTER, DIMENSION(:,:) :: zekb, zekg, zekr 105 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot 106 113 !!---------------------------------------------------------------------- 107 114 ! 108 115 IF( nn_timing == 1 ) CALL timing_start('tra_qsr') 109 !110 CALL wrk_alloc( jpi, jpj, zekb, zekg, zekr )111 CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )112 116 ! 113 117 IF( kt == nit000 ) THEN … … 115 119 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 116 120 IF(lwp) WRITE(numout,*) '~~~~~~~' 117 IF( .NOT.ln_traqsr ) RETURN 118 ENDIF 119 120 IF( l_trdtra ) THEN ! Save ta and sa trends 121 CALL wrk_alloc( jpi, jpj, jpk, ztrdt ) 121 ENDIF 122 ! 123 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 124 CALL wrk_alloc( jpi,jpj,jpk, ztrdt ) 122 125 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 123 126 ENDIF 124 125 ! Set before qsr tracer content field 126 ! *********************************** 127 IF( kt == nit000 ) THEN ! Set the forcing field at nit000 - 1 128 ! ! ----------------------------------- 129 qsr_hc(:,:,:) = 0.e0 130 ! 131 IF( ln_rstart .AND. & ! Restart: read in restart file 132 & iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN 133 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field red in the restart file' 134 zfact = 0.5e0 127 ! 128 ! !-----------------------------------! 129 ! ! before qsr induced heat content ! 130 ! !-----------------------------------! 131 IF( kt == nit000 ) THEN !== 1st time step ==! 132 !!gm case neuler not taken into account.... 133 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN ! read in restart 134 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' 135 z1_2 = 0.5_wp 135 136 CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 136 137 ELSE ! No restart or restart not found: Euler forward time stepping 137 z fact = 1.e0138 qsr_hc_b(:,:,:) = 0. e0138 z1_2 = 1._wp 139 qsr_hc_b(:,:,:) = 0._wp 139 140 ENDIF 140 ELSE ! Swap of forcing field 141 ! ! --------------------- 142 zfact = 0.5e0 141 ELSE !== Swap of qsr heat content ==! 142 z1_2 = 0.5_wp 143 143 qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 144 144 ENDIF 145 ! Compute now qsr tracer content field 146 ! ************************************ 147 148 ! ! ============================================== ! 149 IF( lk_qsr_bio .AND. ln_qsr_bio ) THEN ! bio-model fluxes : all vertical coordinates ! 150 ! ! ============================================== ! 151 DO jk = 1, jpkm1 145 ! 146 ! !--------------------------------! 147 SELECT CASE( nqsr ) ! now qsr induced heat content ! 148 ! !--------------------------------! 149 ! 150 CASE( np_BIO ) !== bio-model fluxes ==! 151 ! 152 DO jk = 1, nksr 152 153 qsr_hc(:,:,jk) = r1_rau0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 153 154 END DO 154 ! Add to the general trend 155 DO jk = 1, jpkm1 156 DO jj = 2, jpjm1 157 DO ji = fs_2, fs_jpim1 ! vector opt. 158 z1_e3t = zfact / e3t_n(ji,jj,jk) 159 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 155 ! 156 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 157 ! 158 CALL wrk_alloc( jpi,jpj, zekb, zekg, zekr ) 159 CALL wrk_alloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea ) 160 ! 161 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll 162 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 163 DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl 164 DO ji = fs_2, fs_jpim1 165 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 166 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 167 zekb(ji,jj) = rkrgb(1,irgb) 168 zekg(ji,jj) = rkrgb(2,irgb) 169 zekr(ji,jj) = rkrgb(3,irgb) 160 170 END DO 161 171 END DO 162 END DO 163 CALL iom_put( 'qsr3d', etot3 ) ! Shortwave Radiation 3D distribution 164 ! clem: store attenuation coefficient of the first ocean level 165 IF ( ln_qsr_ice ) THEN 166 DO jj = 1, jpj 167 DO ji = 1, jpi 168 IF ( qsr(ji,jj) /= 0._wp ) THEN 169 fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 170 ELSE 171 fraqsr_1lev(ji,jj) = 1. 172 ENDIF 172 ELSE !* constant chrlorophyll 173 zchl = 0.05 ! constant chlorophyll 174 ! ! Separation in R-G-B depending of the chlorophyll 175 irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 176 DO jj = 2, jpjm1 177 DO ji = fs_2, fs_jpim1 178 zekb(ji,jj) = rkrgb(1,irgb) 179 zekg(ji,jj) = rkrgb(2,irgb) 180 zekr(ji,jj) = rkrgb(3,irgb) 173 181 END DO 174 182 END DO 175 183 ENDIF 176 ! ! ============================================== ! 177 ELSE ! Ocean alone : 178 ! ! ============================================== ! 179 ! 180 ! ! ------------------------- ! 181 IF( ln_qsr_rgb) THEN ! R-G-B light penetration ! 182 ! ! ------------------------- ! 183 ! Set chlorophyl concentration 184 IF( nn_chldta == 1 .OR. .NOT.ln_linssh ) THEN !* Variable Chlorophyll or ocean volume 185 ! 186 IF( nn_chldta == 1 ) THEN !* Variable Chlorophyll 187 ! 188 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 189 ! 190 DO jj = 1, jpj ! Separation in R-G-B depending of the surface Chl 191 DO ji = 1, jpi 192 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 193 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 194 zekb(ji,jj) = rkrgb(1,irgb) 195 zekg(ji,jj) = rkrgb(2,irgb) 196 zekr(ji,jj) = rkrgb(3,irgb) 197 END DO 198 END DO 199 ELSE ! Variable ocean volume but constant chrlorophyll 200 zchl = 0.05 ! constant chlorophyll 201 irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 202 zekb(:,:) = rkrgb(1,irgb) ! Separation in R-G-B depending of the chlorophyll 203 zekg(:,:) = rkrgb(2,irgb) 204 zekr(:,:) = rkrgb(3,irgb) 184 ! 185 zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B 186 DO jj = 2, jpjm1 187 DO ji = fs_2, fs_jpim1 188 ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 189 ze1(ji,jj,1) = zcoef * qsr(ji,jj) 190 ze2(ji,jj,1) = zcoef * qsr(ji,jj) 191 ze3(ji,jj,1) = zcoef * qsr(ji,jj) 192 zea(ji,jj,1) = qsr(ji,jj) 193 END DO 194 END DO 195 ! 196 DO jk = 2, nksr+1 !* interior equi-partition in R-G-B 197 DO jj = 2, jpjm1 198 DO ji = fs_2, fs_jpim1 199 zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r ) 200 zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) ) 201 zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) ) 202 zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) ) 203 ze0(ji,jj,jk) = zc0 204 ze1(ji,jj,jk) = zc1 205 ze2(ji,jj,jk) = zc2 206 ze3(ji,jj,jk) = zc3 207 zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 208 END DO 209 END DO 210 END DO 211 ! 212 DO jk = 1, nksr !* now qsr induced heat content 213 DO jj = 2, jpjm1 214 DO ji = fs_2, fs_jpim1 215 qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 216 END DO 217 END DO 218 END DO 219 ! 220 CALL wrk_dealloc( jpi,jpj, zekb, zekg, zekr ) 221 CALL wrk_dealloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea ) 222 ! 223 CASE( np_2BD ) !== 2-bands fluxes ==! 224 ! 225 zz0 = rn_abs * r1_rau0_rcp ! surface equi-partition in 2-bands 226 zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 227 DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m 228 DO jj = 2, jpjm1 229 DO ji = fs_2, fs_jpim1 230 zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk )*xsi1r ) 231 zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r ) 232 qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) 233 END DO 234 END DO 235 END DO 236 ! 237 END SELECT 238 ! 239 ! !-----------------------------! 240 DO jk = 1, nksr ! update to the temp. trend ! 241 DO jj = 2, jpjm1 !-----------------------------! 242 DO ji = fs_2, fs_jpim1 ! vector opt. 243 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & 244 & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk) 245 END DO 246 END DO 247 END DO 248 ! 249 IF( ln_qsr_ice ) THEN ! sea-ice: store the 1st ocean level attenuation coefficient 250 DO jj = 2, jpjm1 251 DO ji = fs_2, fs_jpim1 ! vector opt. 252 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 253 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 205 254 ENDIF 206 ! 207 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B 208 ze0(:,:,1) = rn_abs * qsr(:,:) 209 ze1(:,:,1) = zcoef * qsr(:,:) 210 ze2(:,:,1) = zcoef * qsr(:,:) 211 ze3(:,:,1) = zcoef * qsr(:,:) 212 zea(:,:,1) = qsr(:,:) 213 ! 214 DO jk = 2, nksr+1 215 DO jj = 1, jpj 216 DO ji = 1, jpi 217 zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r ) 218 zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) ) 219 zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) ) 220 zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) ) 221 ze0(ji,jj,jk) = zc0 222 ze1(ji,jj,jk) = zc1 223 ze2(ji,jj,jk) = zc2 224 ze3(ji,jj,jk) = zc3 225 zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,jk) 226 END DO 227 END DO 228 END DO 229 ! clem: store attenuation coefficient of the first ocean level 230 IF ( ln_qsr_ice ) THEN 231 DO jj = 1, jpj 232 DO ji = 1, jpi 233 zzc0 = rn_abs * EXP( - e3t_n(ji,jj,1) * xsi0r ) 234 zzc1 = zcoef * EXP( - e3t_n(ji,jj,1) * zekb(ji,jj) ) 235 zzc2 = zcoef * EXP( - e3t_n(ji,jj,1) * zekg(ji,jj) ) 236 zzc3 = zcoef * EXP( - e3t_n(ji,jj,1) * zekr(ji,jj) ) 237 fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2) 238 END DO 239 END DO 240 ENDIF 241 ! 242 DO jk = 1, nksr ! compute and add qsr trend to ta 243 qsr_hc(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) 244 END DO 245 zea(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 246 CALL iom_put( 'qsr3d', zea ) ! Shortwave Radiation 3D distribution 247 ! 248 ELSE !* Constant Chlorophyll 249 DO jk = 1, nksr 250 qsr_hc(:,:,jk) = etot3(:,:,jk) * qsr(:,:) 251 END DO 252 ! clem: store attenuation coefficient of the first ocean level 253 IF ( ln_qsr_ice ) THEN 254 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 255 ENDIF 256 ENDIF 257 258 ENDIF 259 ! ! ------------------------- ! 260 IF( ln_qsr_2bd ) THEN ! 2 band light penetration ! 261 ! ! ------------------------- ! 262 ! 263 IF( .NOT.ln_linssh ) THEN !* variable volume 264 zz0 = rn_abs * r1_rau0_rcp 265 zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 266 DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m 267 DO jj = 1, jpj 268 DO ji = 1, jpi 269 zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk )*xsi1r ) 270 zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r ) 271 qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0*tmask(ji,jj,jk) - zc1*tmask(ji,jj,jk+1) ) 272 END DO 273 END DO 274 END DO 275 ! clem: store attenuation coefficient of the first ocean level 276 IF ( ln_qsr_ice ) THEN 277 DO jj = 1, jpj 278 DO ji = 1, jpi 279 zc0 = zz0 * EXP( -gdepw_n(ji,jj,1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,1)*xsi1r ) 280 zc1 = zz0 * EXP( -gdepw_n(ji,jj,2)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,2)*xsi1r ) 281 fraqsr_1lev(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 282 END DO 283 END DO 284 ENDIF 285 ELSE !* constant volume: coef. computed one for all 286 DO jk = 1, nksr 287 DO jj = 2, jpjm1 288 DO ji = fs_2, fs_jpim1 ! vector opt. 289 ! (ISF) no light penetration below the ice shelves 290 qsr_hc(ji,jj,jk) = etot3(ji,jj,jk) * qsr(ji,jj) * tmask(ji,jj,1) 291 END DO 292 END DO 293 END DO 294 ! clem: store attenuation coefficient of the first ocean level 295 IF ( ln_qsr_ice ) THEN 296 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 297 ENDIF 298 ! 299 ENDIF 300 ! 301 ENDIF 302 ! 303 ! Add to the general trend 304 DO jk = 1, nksr 305 DO jj = 2, jpjm1 306 DO ji = fs_2, fs_jpim1 ! vector opt. 307 z1_e3t = zfact / e3t_n(ji,jj,jk) 308 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 309 END DO 310 END DO 311 END DO 312 ! 313 ENDIF 314 ! 315 IF( lrst_oce ) THEN ! Write in the ocean restart file 316 ! ******************************* 317 IF(lwp) WRITE(numout,*) 318 IF(lwp) WRITE(numout,*) 'qsr tracer content forcing field written in ocean restart file ', & 319 & 'at it= ', kt,' date= ', ndastp 320 IF(lwp) WRITE(numout,*) '~~~~' 255 END DO 256 END DO 257 ENDIF 258 ! 259 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 260 CALL wrk_alloc( jpi,jpj,jpk, zetot ) 261 ! 262 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 263 DO jk = nksr, 1, -1 264 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) / r1_rau0_rcp 265 END DO 266 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 267 ! 268 CALL wrk_dealloc( jpi,jpj,jpk, zetot ) 269 ENDIF 270 ! 271 IF( lrst_oce ) THEN ! write in the ocean restart file 321 272 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) 322 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) ! default definition in sbcssm 323 ! 324 ENDIF 325 273 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) 274 ENDIF 275 ! 326 276 IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics 327 277 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 328 278 CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 329 CALL wrk_dealloc( jpi, jpj, jpk,ztrdt )279 CALL wrk_dealloc( jpi,jpj,jpk, ztrdt ) 330 280 ENDIF 331 281 ! ! print mean trends (used for debugging) 332 282 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 333 !334 CALL wrk_dealloc( jpi, jpj, zekb, zekg, zekr )335 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )336 283 ! 337 284 IF( nn_timing == 1 ) CALL timing_stop('tra_qsr') … … 357 304 !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 358 305 !!---------------------------------------------------------------------- 359 ! 360 INTEGER :: ji, jj, jk ! dummy loop indices 361 INTEGER :: irgb, ierror, ioptio, nqsr ! local integer 362 INTEGER :: ios ! Local integer output status for namelist read 363 REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars 364 REAL(wp) :: zz1, zc2 , zc3, zchl ! - - 365 REAL(wp), POINTER, DIMENSION(:,: ) :: zekb, zekg, zekr 366 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea 306 INTEGER :: ji, jj, jk ! dummy loop indices 307 INTEGER :: ios, irgb, ierror, ioptio ! local integer 308 REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars 309 REAL(wp) :: zz1, zc2 , zc3, zchl ! - - 367 310 ! 368 311 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 369 312 TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read 370 313 !! 371 NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_ traqsr, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice, &314 NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice, & 372 315 & nn_chldta, rn_abs, rn_si0, rn_si1 373 316 !!---------------------------------------------------------------------- 374 375 ! 376 IF( nn_timing == 1 ) CALL timing_start('tra_qsr_init') 377 ! 378 CALL wrk_alloc( jpi,jpj, zekb, zekg, zekr ) 379 CALL wrk_alloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea ) 380 ! 381 382 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist : Ratio and length of penetration 317 ! 318 IF( nn_timing == 1 ) CALL timing_start('tra_qsr_init') 319 ! 320 REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist 383 321 READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 384 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp )385 386 REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration namelist : Ratio and length of penetration322 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp ) 323 ! 324 REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration namelist 387 325 READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 388 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp )326 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp ) 389 327 IF(lwm) WRITE ( numond, namtra_qsr ) 390 328 ! … … 394 332 WRITE(numout,*) '~~~~~~~~~~~~' 395 333 WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration' 396 WRITE(numout,*) ' Light penetration (T) or not (F) ln_traqsr = ', ln_traqsr 397 WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb 398 WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd 399 WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio 400 WRITE(numout,*) ' light penetration for ice-model LIM3 ln_qsr_ice = ', ln_qsr_ice 401 WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta 402 WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs 403 WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 404 WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1 405 ENDIF 406 407 IF( ln_traqsr ) THEN ! control consistency 408 ! 409 IF( .NOT.lk_qsr_bio .AND. ln_qsr_bio ) THEN 410 CALL ctl_warn( 'No bio model : force ln_qsr_bio = FALSE ' ) 411 ln_qsr_bio = .FALSE. 334 WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb 335 WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd 336 WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio 337 WRITE(numout,*) ' light penetration for ice-model (LIM3) ln_qsr_ice = ', ln_qsr_ice 338 WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta 339 WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs 340 WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 341 WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1 342 WRITE(numout,*) 343 ENDIF 344 ! 345 ioptio = 0 ! Parameter control 346 IF( ln_qsr_rgb ) ioptio = ioptio + 1 347 IF( ln_qsr_2bd ) ioptio = ioptio + 1 348 IF( ln_qsr_bio ) ioptio = ioptio + 1 349 ! 350 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', & 351 & ' 2 bands, 3 RGB bands or bio-model light penetration' ) 352 ! 353 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB 354 IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc 355 IF( ln_qsr_2bd ) nqsr = np_2BD 356 IF( ln_qsr_bio ) nqsr = np_BIO 357 ! 358 ! ! Initialisation 359 xsi0r = 1._wp / rn_si0 360 xsi1r = 1._wp / rn_si1 361 ! 362 SELECT CASE( nqsr ) 363 ! 364 CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==! 365 ! 366 IF(lwp) WRITE(numout,*) ' R-G-B light penetration ' 367 ! 368 CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. 369 ! 370 nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction 371 ! 372 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 373 ! 374 IF( nqsr == np_RGBc ) THEN ! Chl data : set sf_chl structure 375 IF(lwp) WRITE(numout,*) ' Chlorophyll read in a file' 376 ALLOCATE( sf_chl(1), STAT=ierror ) 377 IF( ierror > 0 ) THEN 378 CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN 379 ENDIF 380 ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) ) 381 IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) 382 ! ! fill sf_chl with sn_chl and control print 383 CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', & 384 & 'Solar penetration function of read chlorophyll', 'namtra_qsr' ) 412 385 ENDIF 413 ! 414 ioptio = 0 ! Parameter control 415 IF( ln_qsr_rgb ) ioptio = ioptio + 1 416 IF( ln_qsr_2bd ) ioptio = ioptio + 1 417 IF( ln_qsr_bio ) ioptio = ioptio + 1 418 ! 419 IF( ioptio /= 1 ) & 420 CALL ctl_stop( ' Choose ONE type of light penetration in namelist namtra_qsr', & 421 & ' 2 bands, 3 RGB bands or bio-model light penetration' ) 422 ! 423 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = 1 424 IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = 2 425 IF( ln_qsr_2bd ) nqsr = 3 426 IF( ln_qsr_bio ) nqsr = 4 427 ! 428 IF(lwp) THEN ! Print the choice 429 WRITE(numout,*) 430 IF( nqsr == 1 ) WRITE(numout,*) ' R-G-B light penetration - Constant Chlorophyll' 431 IF( nqsr == 2 ) WRITE(numout,*) ' R-G-B light penetration - Chl data ' 432 IF( nqsr == 3 ) WRITE(numout,*) ' 2 bands light penetration' 433 IF( nqsr == 4 ) WRITE(numout,*) ' bio-model light penetration' 386 IF( nqsr == np_RGB ) THEN ! constant Chl 387 IF(lwp) WRITE(numout,*) ' Constant Chlorophyll concentration = 0.05' 434 388 ENDIF 435 389 ! 436 ENDIF 437 ! ! ===================================== ! 438 IF( ln_traqsr ) THEN ! Initialisation of Light Penetration ! 439 ! ! ===================================== ! 440 ! 441 xsi0r = 1.e0 / rn_si0 442 xsi1r = 1.e0 / rn_si1 443 ! ! ---------------------------------- ! 444 IF( ln_qsr_rgb ) THEN ! Red-Green-Blue light penetration ! 445 ! ! ---------------------------------- ! 446 ! 447 CALL trc_oce_rgb( rkrgb ) !* tabulated attenuation coef. 448 ! 449 ! !* level of light extinction 450 IF( ln_sco ) THEN ; nksr = jpkm1 451 ELSE ; nksr = trc_oce_ext_lev( r_si2, 0.33e2 ) 452 ENDIF 453 454 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 455 ! 456 IF( nn_chldta == 1 ) THEN !* Chl data : set sf_chl structure 457 IF(lwp) WRITE(numout,*) 458 IF(lwp) WRITE(numout,*) ' Chlorophyll read in a file' 459 ALLOCATE( sf_chl(1), STAT=ierror ) 460 IF( ierror > 0 ) THEN 461 CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN 462 ENDIF 463 ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) ) 464 IF( sn_chl%ln_tint )ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) 465 ! ! fill sf_chl with sn_chl and control print 466 CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', & 467 & 'Solar penetration function of read chlorophyll', 'namtra_qsr' ) 468 ! 469 ELSE !* constant Chl : compute once for all the distribution of light (etot3) 470 IF(lwp) WRITE(numout,*) 471 IF(lwp) WRITE(numout,*) ' Constant Chlorophyll concentration = 0.05' 472 IF( .NOT.ln_linssh ) THEN ! variable volume 473 IF(lwp) WRITE(numout,*) ' non-linear free surface: light distribution will be computed at each time step' 474 ELSE ! constant volume: computes one for all 475 IF(lwp) WRITE(numout,*) ' linear free surface: light distribution computed one for all' 476 ! 477 zchl = 0.05 ! constant chlorophyll 478 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 479 zekb(:,:) = rkrgb(1,irgb) ! Separation in R-G-B depending of the chlorophyll 480 zekg(:,:) = rkrgb(2,irgb) 481 zekr(:,:) = rkrgb(3,irgb) 482 ! 483 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B 484 ze0(:,:,1) = rn_abs 485 ze1(:,:,1) = zcoef 486 ze2(:,:,1) = zcoef 487 ze3(:,:,1) = zcoef 488 zea(:,:,1) = tmask(:,:,1) ! = ( ze0+ze1+z2+ze3 ) * tmask 489 490 DO jk = 2, nksr+1 491 DO jj = 1, jpj 492 DO ji = 1, jpi 493 zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * xsi0r ) 494 zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 495 zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekg(ji,jj) ) 496 zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekr(ji,jj) ) 497 ze0(ji,jj,jk) = zc0 498 ze1(ji,jj,jk) = zc1 499 ze2(ji,jj,jk) = zc2 500 ze3(ji,jj,jk) = zc3 501 zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,jk) 502 END DO 503 END DO 504 END DO 505 ! 506 DO jk = 1, nksr 507 ! (ISF) no light penetration below the ice shelves 508 etot3(:,:,jk) = r1_rau0_rcp * ( zea(:,:,jk) - zea(:,:,jk+1) ) * tmask(:,:,1) 509 END DO 510 etot3(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 511 ENDIF 512 ENDIF 513 ! 514 ENDIF 515 ! ! ---------------------------------- ! 516 IF( ln_qsr_2bd ) THEN ! 2 bands light penetration ! 517 ! ! ---------------------------------- ! 518 ! 519 ! ! level of light extinction 520 nksr = trc_oce_ext_lev( rn_si1, 1.e2 ) 521 IF(lwp) THEN 522 WRITE(numout,*) 523 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 524 ENDIF 525 ! 526 IF( .NOT.ln_linssh ) THEN ! variable volume 527 IF(lwp) WRITE(numout,*) ' non-linear free surface: light distribution will be computed at each time step' 528 ELSE ! constant volume: computes one for all 529 zz0 = rn_abs * r1_rau0_rcp 530 zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 531 DO jk = 1, nksr !* solar heat absorbed at T-point computed once for all 532 DO jj = 1, jpj ! top 400 meters 533 DO ji = 1, jpi 534 zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk )*xsi1r ) 535 zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r ) 536 etot3(ji,jj,jk) = ( zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1) ) * tmask(ji,jj,1) 537 END DO 538 END DO 539 END DO 540 etot3(:,:,nksr+1:jpk) = 0._wp ! below 400m set to zero 541 ! 542 ENDIF 543 ENDIF 544 ! ! ===================================== ! 545 ELSE ! No light penetration ! 546 ! ! ===================================== ! 547 IF(lwp) THEN 548 WRITE(numout,*) 549 WRITE(numout,*) 'tra_qsr_init : NO solar flux penetration' 550 WRITE(numout,*) '~~~~~~~~~~~~' 551 ENDIF 552 ENDIF 553 ! 554 ! initialisation of fraqsr_1lev used in sbcssm 390 CASE( np_2BD ) !== 2 bands light penetration ==! 391 ! 392 IF(lwp) WRITE(numout,*) ' 2 bands light penetration' 393 ! 394 nksr = trc_oce_ext_lev( rn_si1, 100._wp ) ! level of light extinction 395 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 396 ! 397 CASE( np_BIO ) !== BIO light penetration ==! 398 ! 399 IF(lwp) WRITE(numout,*) ' bio-model light penetration' 400 IF( .NOT.lk_qsr_bio ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) 401 ! 402 END SELECT 403 ! 404 qsr_hc(:,:,:) = 0._wp ! now qsr heat content set to zero where it will not be computed 405 ! 406 ! 1st ocean level attenuation coefficient (used in sbcssm) 555 407 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 556 408 CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev ) 557 409 ELSE 558 fraqsr_1lev(:,:) = 1._wp ! default definition 559 ENDIF 560 ! 561 CALL wrk_dealloc( jpi,jpj, zekb, zekg, zekr ) 562 CALL wrk_dealloc( jpi,jpj,jpk, ze0, ze1, ze2, ze3, zea ) 563 ! 564 IF( nn_timing == 1 ) CALL timing_stop('tra_qsr_init') 410 fraqsr_1lev(:,:) = 1._wp ! default : no penetration 411 ENDIF 412 ! 413 IF( nn_timing == 1 ) CALL timing_stop('tra_qsr_init') 565 414 ! 566 415 END SUBROUTINE tra_qsr_init -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r5866 r5883 13 13 14 14 !!---------------------------------------------------------------------- 15 !! tra_sbc : update the tracer trend at ocean surface 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and active tracers 18 USE sbc_oce ! surface boundary condition: ocean 19 USE dom_oce ! ocean space domain variables 20 USE phycst ! physical constant 21 USE sbcmod ! ln_rnf 22 USE sbcrnf ! River runoff 23 USE sbcisf ! Ice shelf 24 USE traqsr ! solar radiation penetration 25 USE trd_oce ! trends: ocean variables 26 USE trdtra ! trends manager: tracers 15 !! tra_sbc : update the tracer trend at ocean surface 16 !!---------------------------------------------------------------------- 17 USE oce ! ocean dynamics and active tracers 18 USE sbc_oce ! surface boundary condition: ocean 19 USE dom_oce ! ocean space domain variables 20 USE phycst ! physical constant 21 USE eosbn2 ! Equation Of State 22 USE sbcmod ! ln_rnf 23 USE sbcrnf ! River runoff 24 USE sbcisf ! Ice shelf 25 USE traqsr ! solar radiation penetration 26 USE trd_oce ! trends: ocean variables 27 USE trdtra ! trends manager: tracers 27 28 ! 28 USE in_out_manager ! I/O manager 29 USE prtctl ! Print control 30 USE iom 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE wrk_nemo ! Memory Allocation 33 USE timing ! Timing 34 USE eosbn2 29 USE in_out_manager ! I/O manager 30 USE prtctl ! Print control 31 USE iom ! xIOS server 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 USE wrk_nemo ! Memory Allocation 34 USE timing ! Timing 35 35 36 36 IMPLICIT NONE 37 37 PRIVATE 38 38 39 PUBLIC tra_sbc 39 PUBLIC tra_sbc ! routine called by step.F90 40 40 41 41 !! * Substitutions … … 56 56 !! and add it to the general trend of tracer equations. 57 57 !! 58 !! ** Method : 59 !! Following Roullet and Madec (2000), the air-sea flux can be divided 60 !! into three effects: (1) Fext, external forcing; 61 !! (2) Fwi, concentration/dilution effect due to water exchanged 62 !! at the surface by evaporation, precipitations and runoff (E-P-R); 63 !! (3) Fwe, tracer carried with the water that is exchanged. 64 !! - salinity : salt flux only due to freezing/melting 65 !! sa = sa + sfx / rau0 / e3t for k=1 58 !! ** Method : The (air+ice)-sea flux has two components: 59 !! (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); 60 !! (2) Fwe , tracer carried with the water that is exchanged with air+ice. 61 !! The input forcing fields (emp, rnf, sfx, isf) contain Fext+Fwe, 62 !! they are simply added to the tracer trend (tsa). 63 !! In linear free surface case (ln_linssh=T), the volume of the 64 !! ocean does not change with the water exchanges at the (air+ice)-sea 65 !! interface. Therefore another term has to be added, to mimic the 66 !! concentration/dilution effect associated with water exchanges. 66 67 !! 67 !! Fext, flux through the air-sea interface for temperature and salt: 68 !! - temperature : heat flux q (w/m2). If penetrative solar 69 !! radiation q is only the non solar part of the heat flux, the 70 !! solar part is added in traqsr.F routine. 71 !! ta = ta + q /(rau0 rcp e3t) for k=1 72 !! - salinity : no salt flux 73 !! 74 !! The formulation for Fwb and Fwi vary according to the free 75 !! surface formulation (linear or variable volume). 76 !! * Linear free surface (ln_linssh=T) 77 !! The surface freshwater flux modifies the ocean volume 78 !! and thus the concentration of a tracer and the temperature. 79 !! First order of the effect of surface freshwater exchange 80 !! for salinity, it can be neglected on temperature (especially 81 !! as the temperature of precipitations and runoffs is usually 82 !! unknown). 83 !! - temperature : we assume that the temperature of both 84 !! precipitations and runoffs is equal to the SST, thus there 85 !! is no additional flux since in this case, the concentration 86 !! dilution effect is balanced by the net heat flux associated 87 !! to the freshwater exchange (Fwe+Fwi=0): 88 !! (Tp P - Te E) + SST (P-E) = 0 when Tp=Te=SST 89 !! - salinity : evaporation, precipitation and runoff 90 !! water has a zero salinity but there is a salt flux due to 91 !! freezing/melting, thus: 92 !! sa = sa + emp * sn / rau0 / e3t for k=1 93 !! + sfx / rau0 / e3t 94 !! where emp, the surface freshwater budget (evaporation minus 95 !! precipitation minus runoff) given in kg/m2/s is divided 96 !! by rau0 (density of sea water) to obtain m/s. 97 !! Note: even though Fwe does not appear explicitly for 98 !! temperature in this routine, the heat carried by the water 99 !! exchanged through the surface is part of the total heat flux 100 !! forcing and must be taken into account in the global heat 101 !! balance). 102 !! * nonlinear free surface (ln_linssh=F) 103 !! contrary to the linear free surface case, Fwi is properly 104 !! taken into account by using the true layer thicknesses to 105 !! calculate tracer content and advection. There is no need to 106 !! deal with it in this routine. 107 !! - temperature: Fwe=SST (P-E+R) is added to Fext. 108 !! - salinity: Fwe = 0, there is no surface flux of salt. 109 !! 110 !! ** Action : - Update the 1st level of (ta,sa) with the trend associated 111 !! with the tracer surface boundary condition 112 !! - send trends to trdtra module (l_trdtra=T) 68 !! ** Action : - Update tsa with the surface boundary condition trend 69 !! - send trends to trdtra module for further diagnostics(l_trdtra=T) 113 70 !!---------------------------------------------------------------------- 114 71 INTEGER, INTENT(in) :: kt ! ocean time-step index 115 !! 116 INTEGER :: ji, jj, jk, jn ! dummy loop indices 117 INTEGER :: ikt, ikb 118 INTEGER :: nk_isf 119 REAL(wp) :: zfact, z1_e3t, zdep 120 REAL(wp) :: zalpha, zhk 72 ! 73 INTEGER :: ji, jj, jk, jn ! dummy loop indices 74 INTEGER :: ikt, ikb ! local integers 75 REAL(wp) :: zfact, z1_e3t, zdep ! local scalar 76 REAL(wp) :: zalpha, zhk ! - - 121 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 122 78 !!---------------------------------------------------------------------- … … 129 85 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 130 86 ENDIF 131 87 ! 132 88 IF( l_trdtra ) THEN !* Save ta and sa trends 133 89 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) … … 135 91 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 136 92 ENDIF 137 138 !!gm IF( .NOT.ln_traqsr ) qsr(:,:) = 0.e0 ! no solar radiation penetration93 ! 94 !!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 139 95 IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration 140 96 qns(:,:) = qns(:,:) + qsr(:,:) ! total heat flux in qns 141 qsr(:,:) = 0. e0! qsr set to zero97 qsr(:,:) = 0._wp ! qsr set to zero 142 98 ENDIF 143 99 … … 145 101 ! EMP, SFX and QNS effects 146 102 !---------------------------------------- 147 ! !== Set before sbc tracer content fields ==! 148 ! 149 IF( kt == nit000 ) THEN ! Set the forcing field at nit000 - 1 150 ! 151 IF( ln_rstart .AND. & ! Restart: read in restart file 103 ! !== Set before sbc tracer content fields ==! 104 IF( kt == nit000 ) THEN !* 1st time-step 105 IF( ln_rstart .AND. & ! Restart: read in restart file 152 106 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 153 IF(lwp) WRITE(numout,*) ' nit000-1 s urface tracer content forcing fields red in the restart file'107 IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' 154 108 zfact = 0.5_wp 155 109 CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend 156 110 CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 157 ELSE 111 ELSE ! No restart or restart not found: Euler forward time stepping 158 112 zfact = 1._wp 159 113 sbc_tsc_b(:,:,:) = 0._wp 160 114 ENDIF 161 ELSE ! Swap of forcing fields115 ELSE !* other time-steps: swap of forcing fields 162 116 zfact = 0.5_wp 163 117 sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 164 118 ENDIF 165 ! Compute now sbc tracer content fields 166 ! ************************************* 167 168 ! Concentration dilution effect on (t,s) due to 169 ! evaporation, precipitation and qns, but not river runoff 170 171 IF( .NOT.ln_linssh ) THEN !* Variable Volume case ==>> heat content of mass flux is in qns 172 DO jj = 1, jpj 173 DO ji = 1, jpi 174 sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj) ! non solar heat flux 175 sbc_tsc(ji,jj,jp_sal) = r1_rau0 * sfx(ji,jj) ! salt flux due to freezing/melting 119 ! !== Now sbc tracer content fields ==! 120 DO jj = 2, jpj 121 DO ji = fs_2, fs_jpim1 ! vector opt. 122 sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj) ! non solar heat flux 123 sbc_tsc(ji,jj,jp_sal) = r1_rau0 * sfx(ji,jj) ! salt flux due to freezing/melting 124 END DO 125 END DO 126 IF( ln_linssh ) THEN !* linear free surface 127 DO jj = 2, jpj !==>> add concentration/dilution effect due to constant volume cell 128 DO ji = fs_2, fs_jpim1 ! vector opt. 129 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem) 130 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_sal) 176 131 END DO 177 END DO 178 ELSE !* Constant Volume case ==>> Concentration dilution effect 132 END DO !==>> output c./d. term 133 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) 134 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) 135 ENDIF 136 ! 137 DO jn = 1, jpts !== update tracer trend ==! 179 138 DO jj = 2, jpj 180 DO ji = fs_2, fs_jpim1 ! vector opt. 181 ! temperature : heat flux 182 sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj) & ! non solar heat flux 183 & + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem) ! concent./dilut. effect 184 ! salinity : salt flux + concent./dilut. effect (both in sfx) 185 sbc_tsc(ji,jj,jp_sal) = r1_rau0 * ( sfx(ji,jj) & ! salt flux (freezing/melting) 186 & + emp(ji,jj) * tsn(ji,jj,1,jp_sal) ) ! concent./dilut. effect 187 END DO 188 END DO 189 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) ! c/d term on sst 190 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) ! c/d term on sss 191 ENDIF 192 ! 193 DO jn = 1, jpts 194 DO jj = 2, jpj 195 DO ji = fs_2, fs_jpim1 ! vector opt. 196 z1_e3t = zfact / e3t_n(ji,jj,1) 197 tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) * z1_e3t 139 DO ji = fs_2, fs_jpim1 ! vector opt. 140 tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t_n(ji,jj,1) 198 141 END DO 199 142 END DO 200 143 END DO 201 ! Write in the ocean restart file 202 ! ******************************* 203 IF( lrst_oce ) THEN 204 IF(lwp) WRITE(numout,*) 205 IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in ocean restart file ', & 206 & 'at it= ', kt,' date= ', ndastp 207 IF(lwp) WRITE(numout,*) '~~~~' 144 ! 145 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! 208 146 CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 209 147 CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 210 148 ENDIF 211 149 ! 212 !213 150 !---------------------------------------- 214 151 ! Ice Shelf effects (ISF) 215 152 ! tbl treated as in Losh (2008) JGR 216 153 !---------------------------------------- 154 ! 155 !!gm BUG ? Why no differences between non-linear and linear free surface ? 156 !!gm probably taken into account in r1_hisf_tbl : to be verified 217 157 ! 218 158 IF( nn_isf > 0 ) THEN … … 220 160 DO jj = 2, jpj 221 161 DO ji = fs_2, fs_jpim1 222 162 ! 223 163 ikt = misfkt(ji,jj) 224 164 ikb = misfkb(ji,jj) 225 165 ! 226 166 ! level fully include in the ice shelf boundary layer 227 167 ! if isfdiv, we have to remove heat flux due to inflow at 0oC (as in rnf when you add rnf at sst) … … 246 186 END DO 247 187 IF( lrst_oce ) THEN 248 IF(lwp) WRITE(numout,*) 249 IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', & 250 & 'at it= ', kt,' date= ', ndastp 251 IF(lwp) WRITE(numout,*) '~~~~' 252 CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 188 CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf (:,:) ) 253 189 CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 254 190 CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) … … 267 203 zdep = zfact / h_rnf(ji,jj) 268 204 DO jk = 1, nk_rnf(ji,jj) 269 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) &270 &+ ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep271 IF( ln_rnf_sal ) tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) &272 &+ ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep205 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & 206 & + ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 207 IF( ln_rnf_sal ) tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & 208 & + ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep 273 209 END DO 274 210 ENDIF … … 276 212 END DO 277 213 ENDIF 278 214 ! 279 215 IF( l_trdtra ) THEN ! send trends for further diagnostics 280 216 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90
r5845 r5883 9 9 10 10 !!---------------------------------------------------------------------- 11 !! tra_zdf : Update the tracer trend with the vertical diffusion12 !! tra_zdf_init : initialisation of the computation11 !! tra_zdf : Update the tracer trend with the vertical diffusion 12 !! tra_zdf_init : initialisation of the computation 13 13 !!---------------------------------------------------------------------- 14 USE oce 15 USE dom_oce 16 USE domvvl 17 USE phycst 18 USE zdf_oce 19 USE sbc_oce 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 16 USE domvvl ! variable volume 17 USE phycst ! physical constant 18 USE zdf_oce ! ocean vertical physics variables 19 USE sbc_oce ! surface boundary condition: ocean 20 20 USE dynspg_oce 21 USE ldftra ! lateral diffusion: eddy diffusivity 22 USE ldfslp ! lateral diffusion: iso-neutral slope 23 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 24 USE trazdf_imp ! vertical diffusion: implicit (tra_zdf_imp routine) 25 USE trd_oce ! trends: ocean variables 26 USE trdtra ! trends: tracer trend manager 21 27 ! 22 USE ldftra ! lateral diffusion: eddy diffusivity 23 USE ldfslp ! lateral diffusion: iso-neutral slope 24 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 25 USE trazdf_imp ! vertical diffusion: implicit (tra_zdf_imp routine) 26 ! 27 USE trd_oce ! trends: ocean variables 28 USE trdtra ! trends manager: tracers 29 ! 30 USE in_out_manager ! I/O manager 31 USE prtctl ! Print control 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 USE lib_mpp ! MPP library 34 USE wrk_nemo ! Memory allocation 35 USE timing ! Timing 28 USE in_out_manager ! I/O manager 29 USE prtctl ! Print control 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 USE lib_mpp ! MPP library 32 USE wrk_nemo ! Memory allocation 33 USE timing ! Timing 36 34 37 35 IMPLICIT NONE … … 60 58 !!--------------------------------------------------------------------- 61 59 INTEGER, INTENT( in ) :: kt ! ocean time-step index 62 ! !60 ! 63 61 INTEGER :: jk ! Dummy loop indices 64 62 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace … … 72 70 r2dtra(:) = 2. * rdttra(:) ! = 2 rdttra (leapfrog) 73 71 ENDIF 74 72 ! 75 73 IF( l_trdtra ) THEN !* Save ta and sa trends 76 74 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) … … 78 76 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 79 77 ENDIF 80 78 ! 81 79 SELECT CASE ( nzdf ) ! compute lateral mixing trend and add it to the general trend 82 80 CASE ( 0 ) ; CALL tra_zdf_exp( kt, nit000, 'TRA', r2dtra, nn_zdfexp, tsb, tsa, jpts ) ! explicit scheme … … 87 85 ! JMM avoid negative salinities near river outlet ! Ugly fix 88 86 ! JMM : restore negative salinities to small salinities: 89 WHERE 87 WHERE( tsa(:,:,:,jp_sal) < 0._wp ) tsa(:,:,:,jp_sal) = 0.1_wp 90 88 !!gm 91 89 … … 103 101 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 104 102 ENDIF 105 106 103 ! ! print mean trends (used for debugging) 107 104 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf - Ta: ', mask1=tmask, & … … 128 125 USE zdfgls 129 126 !!---------------------------------------------------------------------- 130 127 ! 131 128 ! Choice from ln_zdfexp already read in namelist in zdfini module 132 129 IF( ln_zdfexp ) THEN ; nzdf = 0 ! use explicit scheme 133 130 ELSE ; nzdf = 1 ! use implicit scheme 134 131 ENDIF 135 132 ! 136 133 ! Force implicit schemes 137 134 IF( lk_zdftke .OR. lk_zdfgls ) nzdf = 1 ! TKE, or GLS physics … … 140 137 IF( ln_zdfexp .AND. nzdf == 1 ) CALL ctl_stop( 'tra_zdf : If using the rotation of lateral mixing operator', & 141 138 & ' GLS or TKE scheme, the implicit scheme is required, set ln_zdfexp = .false.' ) 142 139 ! 143 140 IF(lwp) THEN 144 141 WRITE(numout,*) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_exp.F90
r5866 r5883 20 20 21 21 !!---------------------------------------------------------------------- 22 !! tra_zdf_exp : compute the tracer the vertical diffusion trend using a23 !! split-explicit time stepping and provide the after tracer22 !! tra_zdf_exp : compute the tracer the vertical diffusion trend using a 23 !! split-explicit time stepping and provide the after tracer 24 24 !!---------------------------------------------------------------------- 25 USE oce 26 USE dom_oce 27 USE domvvl 28 USE zdf_oce 29 USE zdfddm 30 USE trc_oce 31 USE in_out_manager 32 USE lib_mpp 33 USE wrk_nemo 34 USE timing 25 USE oce ! ocean dynamics and active tracers 26 USE dom_oce ! ocean space and time domain 27 USE domvvl ! variable volume levels 28 USE zdf_oce ! ocean vertical physics 29 USE zdfddm ! ocean vertical physics: double diffusion 30 USE trc_oce ! share passive tracers/Ocean variables 31 USE in_out_manager ! I/O manager 32 USE lib_mpp ! MPP library 33 USE wrk_nemo ! Memory Allocation 34 USE timing ! Timing 35 35 36 36 IMPLICIT NONE … … 49 49 CONTAINS 50 50 51 SUBROUTINE tra_zdf_exp( kt, kit000, cdtype, p2dt, k n_zdfexp, &52 & ptb , pta, kjpt )51 SUBROUTINE tra_zdf_exp( kt, kit000, cdtype, p2dt, kstp, & 52 & ptb , pta , kjpt ) 53 53 !!---------------------------------------------------------------------- 54 54 !! *** ROUTINE tra_zdf_exp *** … … 59 59 !! ** Method : - The after tracer fields due to the vertical diffusion 60 60 !! of tracers alone is given by: 61 !! z wx= ptb + p2dt difft61 !! ztb = ptb + p2dt difft 62 62 !! where difft = dz( avt dz(ptb) ) = 1/e3t dk+1( avt/e3w dk(ptb) ) 63 63 !! (if lk_zdfddm=T use avs on salinity and passive tracers instead of avt) … … 67 67 !! - the after tracer fields due to the whole trend is 68 68 !! obtained in leap-frog environment applied on thickness weighted tracer by : 69 !! pta = [ ptb*e3tb + e3tn*( z wx- ptb + p2dt pta ) ] / e3tn69 !! pta = [ ptb*e3tb + e3tn*( ztb - ptb + p2dt pta ) ] / e3tn 70 70 !! 71 71 !! ** Action : - after tracer fields pta 72 72 !!--------------------------------------------------------------------- 73 INTEGER , INTENT(in ) :: kt 74 INTEGER , INTENT(in ) :: kit000 75 CHARACTER(len=3) , INTENT(in ) :: cdtype 76 INTEGER , INTENT(in ) :: kjpt 77 INTEGER , INTENT(in ) :: k n_zdfexp! number of sub-time step78 REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt 79 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb 80 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend73 INTEGER , INTENT(in ) :: kt ! ocean time-step index 74 INTEGER , INTENT(in ) :: kit000 ! first time step index 75 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 76 INTEGER , INTENT(in ) :: kjpt ! number of tracers 77 INTEGER , INTENT(in ) :: kstp ! number of sub-time step 78 REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt ! vertical profile of tracer time-step 79 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 80 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! in: tracer trend ; out: after tracer field 81 81 ! 82 INTEGER :: ji, jj, jk, jn, jl 83 REAL(wp) :: z lavmr, zave3r, ze3tr! local scalars84 REAL(wp) :: ztra, ze3tb 85 REAL(wp), POINTER, DIMENSION(:,:,:) :: z wx, zwy82 INTEGER :: ji, jj, jk, jn, jl ! dummy loop indices 83 REAL(wp) :: z1_kstp, ze3tr ! local scalars 84 REAL(wp) :: ztra, ze3tb, z2dt ! - - 85 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztb, zwf 86 86 !!--------------------------------------------------------------------- 87 87 ! 88 88 IF( nn_timing == 1 ) CALL timing_start('tra_zdf_exp') 89 89 ! 90 CALL wrk_alloc( jpi,jpj,jpk, z wx, zwy)90 CALL wrk_alloc( jpi,jpj,jpk, ztb, zwf ) 91 91 ! 92 93 92 IF( kt == kit000 ) THEN 94 93 IF(lwp) WRITE(numout,*) … … 99 98 ! Initializations 100 99 ! --------------- 101 zlavmr = 1. / float( kn_zdfexp ) ! Local constant 100 z1_kstp = 1._wp / REAL( kstp, wp ) 101 zwf(:,:, 1 ) = 0._wp ! no flux at the surface and at bottom level 102 zwf(:,:,jpk) = 0._wp 102 103 ! 103 104 ! 104 DO jn = 1, kjpt ! loop over tracers105 DO jn = 1, kjpt !== loop over tracers ==! 105 106 ! 106 zwy(:,:, 1 ) = 0.e0 ! surface boundary conditions: no flux 107 zwy(:,:,jpk) = 0.e0 ! bottom boundary conditions: no flux 108 ! 109 zwx(:,:,:) = ptb(:,:,:,jn) ! zwx array set to before tracer values 110 111 ! Split-explicit loop (after tracer due to the vertical diffusion alone) 112 ! ------------------- 113 ! 114 DO jl = 1, kn_zdfexp 115 ! ! first vertical derivative 116 DO jk = 2, jpk 107 ztb(:,:,:) = ptb(:,:,:,jn) ! initial before value for tracer 108 ! 109 DO jl = 1, kstp !== Split-explicit loop ==! 110 ! 111 DO jk = 2, jpk ! 1st vertical derivative (w-flux) 117 112 DO jj = 2, jpjm1 118 113 DO ji = fs_2, fs_jpim1 ! vector opt. 119 zave3r = 1.e0 / e3w_n(ji,jj,jk) !!gm here it should be e3w_b ????120 114 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ! temperature : use of avt 121 zw y(ji,jj,jk) = avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r115 zwf(ji,jj,jk) = avt(ji,jj,jk) * ( ztb(ji,jj,jk-1) - ztb(ji,jj,jk) ) / e3w_b(ji,jj,jk) 122 116 ELSE ! salinity or pass. tracer : use of avs 123 zw y(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r117 zwf(ji,jj,jk) = fsavs(ji,jj,jk) * ( ztb(ji,jj,jk-1) - ztb(ji,jj,jk) ) / e3w_b(ji,jj,jk) 124 118 END IF 125 119 END DO … … 127 121 END DO 128 122 ! 129 DO jk = 1, jpkm1 ! second vertical derivative ==> tracer at kt+l*2*rdt/nn_zdfexp 123 DO jk = 1, jpkm1 ! 2nd vertical derivative ==> tracer at kt+l*2*rdt/nn_zdfexp 124 z2dt = z1_kstp * p2dt(jk) 130 125 DO jj = 2, jpjm1 131 126 DO ji = fs_2, fs_jpim1 ! vector opt. 132 ze3tr = zlavmr / e3t_n(ji,jj,jk) 133 zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 127 ztb(ji,jj,jk) = ztb(ji,jj,jk) + z2dt * ( zwf(ji,jj,jk) - zwf(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) 134 128 END DO 135 129 END DO 136 130 END DO 137 131 ! 138 END DO 132 END DO ! end sub-time stepping 139 133 140 ! After tracer due to all trends 141 ! ------------------------------ 142 IF( .NOT.ln_linssh ) THEN ! variable level thickness : leap-frog on tracer*e3t 143 DO jk = 1, jpkm1 144 DO jj = 2, jpjm1 145 DO ji = fs_2, fs_jpim1 ! vector opt. 146 ze3tb = e3t_b(ji,jj,jk) / e3t_n(ji,jj,jk) ! before e3t 147 ztra = zwx(ji,jj,jk) - ptb(ji,jj,jk,jn) + p2dt(jk) * pta(ji,jj,jk,jn) ! total trends * 2*rdt 148 pta(ji,jj,jk,jn) = ( ze3tb * ptb(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk) 149 END DO 134 DO jk = 1, jpkm1 !== After tracer due to all trends 135 DO jj = 2, jpjm1 136 DO ji = fs_2, fs_jpim1 ! vector opt. 137 ze3tb = e3t_b(ji,jj,jk) / e3t_n(ji,jj,jk) 138 ztra = ( ztb(ji,jj,jk) - ptb(ji,jj,jk,jn) ) + p2dt(jk) * pta(ji,jj,jk,jn) ! total trend * 2dt 139 pta(ji,jj,jk,jn) = ( ze3tb * ptb(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk) ! after tracer 150 140 END DO 151 141 END DO 152 ELSE ! fixed level thickness : leap-frog on tracers 153 DO jk = 1, jpkm1 154 DO jj = 2, jpjm1 155 DO ji = fs_2, fs_jpim1 ! vector opt. 156 pta(ji,jj,jk,jn) = ( zwx(ji,jj,jk) + p2dt(jk) * pta(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 157 END DO 158 END DO 159 END DO 160 ENDIF 142 END DO 161 143 ! 162 END DO 144 END DO ! end of tracer loop 163 145 ! 164 CALL wrk_dealloc( jpi,jpj,jpk, z wx, zwy)146 CALL wrk_dealloc( jpi,jpj,jpk, ztb, zwf ) 165 147 ! 166 148 IF( nn_timing == 1 ) CALL timing_stop('tra_zdf_exp') -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90
r5866 r5883 19 19 20 20 !!---------------------------------------------------------------------- 21 !! tra_zdf_imp : Update the tracer trend with the diagonal vertical part of the mixing tensor.21 !! tra_zdf_imp : Update the tracer trend with vertical mixing, nad compute the after tracer field 22 22 !!---------------------------------------------------------------------- 23 23 USE oce ! ocean dynamics and tracers variables … … 42 42 PUBLIC tra_zdf_imp ! routine called by step.F90 43 43 44 REAL(wp) :: r_vvl ! variable volume indicator, =1 if ln_linssh=F, =0 otherwise45 46 44 !! * Substitutions 47 45 # include "zdfddm_substitute.h90" … … 63 61 !! it is already computed and add to the general trend in traldf) 64 62 !! 65 !! ** Method : The vertical diffusion of the tracer t is given by: 66 !! difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 67 !! It is computed using a backward time scheme (t=ta). 63 !! ** Method : The vertical diffusion of a tracer ,t , is given by: 64 !! difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 65 !! It is computed using a backward time scheme (t=after field) 66 !! which provide directly the after tracer field. 68 67 !! If lk_zdfddm=T, use avs for salinity or for passive tracers 69 68 !! Surface and bottom boundary conditions: no diffusive flux on … … 74 73 !!--------------------------------------------------------------------- 75 74 INTEGER , INTENT(in ) :: kt ! ocean time-step index 76 INTEGER , INTENT(in ) :: kit000 75 INTEGER , INTENT(in ) :: kit000 ! first time step index 77 76 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 78 77 INTEGER , INTENT(in ) :: kjpt ! number of tracers 79 78 REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt ! vertical profile of tracer time-step 80 79 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 81 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend80 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! in: tracer trend ; out: after tracer field 82 81 ! 83 82 INTEGER :: ji, jj, jk, jn ! dummy loop indices 84 REAL(wp) :: zrhs , ze3tb, ze3tn, ze3ta! local scalars83 REAL(wp) :: zrhs ! local scalars 85 84 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwt, zwd, zws 86 85 !!--------------------------------------------------------------------- … … 94 93 IF(lwp)WRITE(numout,*) 'tra_zdf_imp : implicit vertical mixing on ', cdtype 95 94 IF(lwp)WRITE(numout,*) '~~~~~~~~~~~ ' 96 !97 IF( .NOT.ln_linssh ) THEN ; r_vvl = 1._wp ! Variable volume indicator98 ELSE ; r_vvl = 0._wp99 ENDIF100 95 ENDIF 101 !102 96 ! ! ============= ! 103 97 DO jn = 1, kjpt ! tracer loop ! 104 98 ! ! ============= ! 105 !106 99 ! Matrix construction 107 100 ! -------------------- … … 141 134 DO jj = 2, jpjm1 142 135 DO ji = fs_2, fs_jpim1 ! vector opt. 143 ze3ta = ( 1. - r_vvl ) + r_vvl * e3t_a(ji,jj,jk) ! after scale factor at T-point 144 ze3tn = r_vvl + ( 1. - r_vvl ) * e3t_n(ji,jj,jk) ! now scale factor at T-point 145 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * e3w_n(ji,jj,jk ) ) 146 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_n(ji,jj,jk+1) ) 147 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 136 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / e3w_n(ji,jj,jk ) 137 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) 138 zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zwi(ji,jj,jk) - zws(ji,jj,jk) 148 139 END DO 149 140 END DO … … 169 160 ! used as a work space array: its value is modified. 170 161 ! 171 ! first recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) 172 ! done once for all passive tracers (so included in the IF instruction) 173 DO jj = 2, jpjm1 174 DO ji = fs_2, fs_jpim1 162 DO jj = 2, jpjm1 !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) 163 DO ji = fs_2, fs_jpim1 ! done one for all passive tracers (so included in the IF instruction) 175 164 zwt(ji,jj,1) = zwd(ji,jj,1) 176 165 END DO … … 184 173 END DO 185 174 ! 186 END 175 ENDIF 187 176 ! 188 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 189 DO jj = 2, jpjm1 177 DO jj = 2, jpjm1 !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 190 178 DO ji = fs_2, fs_jpim1 191 ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_b(ji,jj,1) 192 ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_n(ji,jj,1) 193 pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 179 pta(ji,jj,1,jn) = e3t_b(ji,jj,1) * ptb(ji,jj,1,jn) + p2dt(1) * e3t_n(ji,jj,1) * pta(ji,jj,1,jn) 194 180 END DO 195 181 END DO … … 197 183 DO jj = 2, jpjm1 198 184 DO ji = fs_2, fs_jpim1 199 ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_b(ji,jj,jk) 200 ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_n(ji,jj,jk) 201 zrhs = ze3tb * ptb(ji,jj,jk,jn) + p2dt(jk) * ze3tn * pta(ji,jj,jk,jn) ! zrhs=right hand side 185 zrhs = e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt(jk) * e3t_n(ji,jj,jk) * pta(ji,jj,jk,jn) ! zrhs=right hand side 202 186 pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 203 187 END DO 204 188 END DO 205 189 END DO 206 207 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 208 DO jj = 2, jpjm1 190 ! 191 DO jj = 2, jpjm1 !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 209 192 DO ji = fs_2, fs_jpim1 210 193 pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/step.F90
r5866 r5883 179 179 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 180 180 CALL ssh_nxt ( kstp ) ! after ssh (includes call to div_hor) 181 IF( .NOT.ln_linssh )CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors181 CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors 182 182 CALL wzv ( kstp ) ! now cross-level velocity 183 183 … … 217 217 218 218 CALL div_hor( kstp ) ! Horizontal divergence (2nd call in time-split case) 219 IF( .NOT.ln_linssh )CALL dom_vvl_sf_nxt( kstp, kcall=2 ) ! after vertical scale factors (update depth average component)219 CALL dom_vvl_sf_nxt( kstp, kcall=2 ) ! after vertical scale factors (update depth average component) 220 220 CALL wzv ( kstp ) ! now cross-level velocity 221 221 ENDIF … … 331 331 332 332 CALL ssh_swp( kstp ) ! swap of sea surface height 333 IF( .NOT.ln_linssh )CALL dom_vvl_sf_swp( kstp ) ! swap of vertical scale factors333 CALL dom_vvl_sf_swp( kstp ) ! swap of vertical scale factors 334 334 ! 335 335 -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90
r5845 r5883 12 12 !! 'key_top' TOP models 13 13 !!---------------------------------------------------------------------- 14 !! trc_ldf : update the tracer trend with the lateral diffusion 15 !! trc_ldf_ini : initialization, namelist read, and parameters control 16 !!---------------------------------------------------------------------- 17 USE trc ! ocean passive tracers variables 18 USE oce_trc ! ocean dynamics and active tracers 19 USE ldfslp ! lateral diffusion: iso-neutral slope 20 USE traldf_lap ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap routine) 21 USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine) 22 USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine) 23 USE traldf_blp ! lateral diffusion (iso-level lap/blp) (tra_ldf_lap routine) 24 USE trd_oce ! trends: ocean variables 25 USE trdtra ! trends manager: tracers 26 ! 27 USE prtctl_trc ! Print control 14 !! trc_ldf : update the tracer trend with the lateral diffusion 15 !! trc_ldf_ini : initialization, namelist read, and parameters control 16 !!---------------------------------------------------------------------- 17 USE trc ! ocean passive tracers variables 18 USE oce_trc ! ocean dynamics and active tracers 19 USE ldfslp ! lateral diffusion: iso-neutral slope 20 USE traldf_lap_blp ! lateral diffusion: lap/bilaplacian iso-level operator (tra_ldf_lap/_blp routine) 21 USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine) 22 USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_ triad routine) 23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 USE prtctl_trc ! Print control 28 26 29 27 IMPLICIT NONE … … 42 40 REAL(wp), PUBLIC :: rn_bhtrc_0 !: bilaplacian - -- - - [m4/s] 43 41 ! 44 !!: ** lateral mixing namelist (nam_trcldf) ** 45 REAL(wp) :: rldf ! ratio between active and passive tracers diffusive coefficient 42 ! !!: ** lateral mixing namelist (nam_trcldf) ** 43 REAL(wp) :: rldf ! ratio between active and passive tracers diffusive coefficient 44 46 45 INTEGER :: nldf = 0 ! type of lateral diffusion used defined from ln_trcldf_... namlist logicals) 47 46 … … 63 62 !!---------------------------------------------------------------------- 64 63 INTEGER, INTENT( in ) :: kt ! ocean time-step index 65 ! !64 ! 66 65 INTEGER :: jn 67 66 CHARACTER (len=22) :: charout … … 98 97 END SELECT 99 98 ! 100 IF( l_trdtrc ) THEN ! s ave the horizontal diffusive trends for further diagnostics99 IF( l_trdtrc ) THEN ! send the trends for further diagnostics 101 100 DO jn = 1, jptra 102 101 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) … … 105 104 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) 106 105 ENDIF 107 ! ! print mean trends (used for debugging) 108 IF( ln_ctl ) THEN 109 WRITE(charout, FMT="('ldf ')") ; CALL prt_ctl_trc_info(charout) 110 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) 106 ! 107 IF( ln_ctl ) THEN ! print mean trends (used for debugging) 108 WRITE(charout, FMT="('ldf ')") 109 CALL prt_ctl_trc_info(charout) 110 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) 111 111 ENDIF 112 112 ! … … 132 132 INTEGER :: ioptio, ierr ! temporary integers 133 133 INTEGER :: ios ! Local integer output status for namelist read 134 ! 134 !! 135 135 NAMELIST/namtrc_ldf/ ln_trcldf_lap, ln_trcldf_blp, & 136 136 & ln_trcldf_lev, ln_trcldf_hor, ln_trcldf_iso, ln_trcldf_triad, & 137 137 & rn_ahtrc_0 , rn_bhtrc_0 138 138 !!---------------------------------------------------------------------- 139 REWIND( numnat_ref ) ! namtrc_ldf in reference namelist 139 ! 140 REWIND( numnat_ref ) ! namtrc_ldf in reference namelist 140 141 READ ( numnat_ref, namtrc_ldf, IOSTAT = ios, ERR = 903) 141 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in reference namelist', lwp )142 143 REWIND( numnat_cfg ) 142 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in reference namelist', lwp ) 143 ! 144 REWIND( numnat_cfg ) ! namtrc_ldf in configuration namelist 144 145 READ ( numnat_cfg, namtrc_ldf, IOSTAT = ios, ERR = 904 ) 145 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in configuration namelist', lwp )146 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrc_ldf in configuration namelist', lwp ) 146 147 IF(lwm) WRITE ( numont, namtrc_ldf ) 147 148 IF(lwp) THEN ! Namelist print148 ! 149 IF(lwp) THEN ! Namelist print 149 150 WRITE(numout,*) 150 151 WRITE(numout,*) 'trc_ldf_ini : lateral tracer diffusive operator' … … 173 174 IF( ln_trcldf_lap .AND. ln_trcldf_blp ) CALL ctl_stop( 'trc_ldf_ctl: bilaplacian should be used on both TRC and TRA' ) 174 175 IF( ln_trcldf_blp .AND. ln_trcldf_lap ) CALL ctl_stop( 'trc_ldf_ctl: laplacian should be used on both TRC and TRA' ) 175 176 ! 176 177 ioptio = 0 177 178 IF( ln_trcldf_lev ) ioptio = ioptio + 1 … … 179 180 IF( ln_trcldf_iso ) ioptio = ioptio + 1 180 181 IF( ioptio /= 1 ) CALL ctl_stop( 'trc_ldf_ctl: use only ONE direction (level/hor/iso)' ) 181 182 ! 182 183 ! defined the type of lateral diffusion from ln_trcldf_... logicals 183 184 ! CAUTION : nldf = 1 is used in trazdf_imp, change it carefully … … 203 204 ENDIF 204 205 ! ! diffusivity ratio: passive / active tracers 205 IF( ABS(rn_aht_0) < 2._wp*TINY(1. e0) ) THEN206 IF( ABS(rn_ahtrc_0) < 2._wp*TINY(1. e0) ) THEN206 IF( ABS(rn_aht_0) < 2._wp*TINY(1._wp) ) THEN 207 IF( ABS(rn_ahtrc_0) < 2._wp*TINY(1._wp) ) THEN 207 208 rldf = 1.0_wp 208 209 ELSE 209 CALL ctl_stop( ' STOP', 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' )210 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 210 211 ENDIF 211 212 ELSE … … 234 235 ENDIF 235 236 ! ! diffusivity ratio: passive / active tracers 236 IF( ABS(rn_bht_0) < 2._wp*TINY(1. e0) ) THEN237 IF( ABS(rn_bhtrc_0) < 2._wp*TINY(1. e0) ) THEN237 IF( ABS(rn_bht_0) < 2._wp*TINY(1._wp) ) THEN 238 IF( ABS(rn_bhtrc_0) < 2._wp*TINY(1._wp) ) THEN 238 239 rldf = 1.0_wp 239 240 ELSE 240 CALL ctl_stop( ' STOP', 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' )241 CALL ctl_stop( 'trc_ldf_ctl : cannot define rldf, rn_aht_0==0, rn_ahtrc_0 /=0' ) 241 242 ENDIF 242 243 ELSE … … 245 246 ENDIF 246 247 ! 247 IF( ierr == 1 ) CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 248 IF( ln_ldfeiv .AND. .NOT.ln_trcldf_iso ) & 249 CALL ctl_stop( ' eddy induced velocity on tracers', & 250 & ' the eddy induced velocity on tracers requires isopycnal laplacian diffusion' ) 251 IF( nldf == 1 .OR. nldf == 3 ) THEN ! rotation 252 IF( .NOT.l_ldfslp ) CALL ctl_stop( ' the rotation of the diffusive tensor require l_ldfslp' ) 253 ENDIF 248 IF( ierr == 1 ) CALL ctl_stop( 'trc_ldf_ctl: iso-level in z-partial step, not allowed' ) 249 IF( ln_ldfeiv .AND. .NOT.ln_trcldf_iso ) CALL ctl_stop( 'trc_ldf_ctl: eiv requires isopycnal laplacian diffusion' ) 250 IF( nldf == 1 .OR. nldf == 3 ) l_ldfslp = .TRUE. ! slope of neutral surfaces required 254 251 ! 255 252 IF(lwp) THEN 256 253 WRITE(numout,*) 257 IF( nldf == np_no_ldf ) WRITE(numout,*) ' NO lateral diffusion' 258 IF( nldf == np_lap ) WRITE(numout,*) ' laplacian iso-level operator' 259 IF( nldf == np_lap_i ) WRITE(numout,*) ' Rotated laplacian operator (standard)' 260 IF( nldf == np_lap_it ) WRITE(numout,*) ' Rotated laplacian operator (triad)' 261 IF( nldf == np_blp ) WRITE(numout,*) ' bilaplacian iso-level operator' 262 IF( nldf == np_blp_i ) WRITE(numout,*) ' Rotated bilaplacian operator (standard)' 263 IF( nldf == np_blp_it ) WRITE(numout,*) ' Rotated bilaplacian operator (triad)' 254 SELECT CASE( nldf ) 255 CASE( np_no_ldf ) ; WRITE(numout,*) ' NO lateral diffusion' 256 CASE( np_lap ) ; WRITE(numout,*) ' laplacian iso-level operator' 257 CASE( np_lap_i ) ; WRITE(numout,*) ' Rotated laplacian operator (standard)' 258 CASE( np_lap_it ) ; WRITE(numout,*) ' Rotated laplacian operator (triad)' 259 CASE( np_blp ) ; WRITE(numout,*) ' bilaplacian iso-level operator' 260 CASE( np_blp_i ) ; WRITE(numout,*) ' Rotated bilaplacian operator (standard)' 261 CASE( np_blp_it ) ; WRITE(numout,*) ' Rotated bilaplacian operator (triad)' 262 END SELECT 264 263 ENDIF 265 264 ! -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90
r5866 r5883 101 101 WRITE(numout,*) 'trc_nxt : time stepping on passive tracers' 102 102 ENDIF 103 103 ! 104 104 #if defined key_agrif 105 105 CALL Agrif_trc ! AGRIF zoom boundaries 106 106 #endif 107 ! Update after tracer on domain lateral boundaries 108 DO jn = 1, jptra 107 DO jn = 1, jptra ! Update after tracer on domain lateral boundaries 109 108 CALL lbc_lnk( tra(:,:,:,jn), 'T', 1. ) 110 109 END DO 111 112 113 110 #if defined key_bdy 114 !! CALL bdy_trc( kt ) 111 !! CALL bdy_trc( kt ) ! BDY open boundaries 115 112 #endif 116 113 117 118 ! set time step size (Euler/Leapfrog) 114 ! ! set time step size (Euler/Leapfrog) 119 115 IF( neuler == 0 .AND. kt == nittrc000 ) THEN ; r2dt(:) = rdttrc(:) ! at nittrc000 (Euler) 120 116 ELSEIF( kt <= nittrc000 + nn_dttrc ) THEN ; r2dt(:) = 2.* rdttrc(:) ! at nit000 or nit000+1 (Leapfrog) 121 117 ENDIF 122 118 123 ! trends computation initialisation 124 IF( l_trdtrc ) THEN 125 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrdt ) !* store now fields before applying the Asselin filter 119 IF( l_trdtrc ) THEN ! trends: store now fields before the Asselin filter application 120 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrdt ) 126 121 ztrdt(:,:,:,:) = trn(:,:,:,:) 127 122 ENDIF 128 ! Leap-Frog + Asselin filter time stepping 129 IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! Euler time-stepping at first time-step 130 ! ! (only swap) 123 ! ! Leap-Frog + Asselin filter time stepping 124 IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! Euler time-stepping at first time-step (only swap) 131 125 DO jn = 1, jptra 132 126 DO jk = 1, jpkm1 … … 134 128 END DO 135 129 END DO 136 ! 137 ELSE 138 ! Leap-Frog + Asselin filter time stepping 130 ELSE ! Asselin filter + swap 139 131 IF( ln_linssh ) THEN ; CALL tra_nxt_fix( kt, nittrc000, 'TRC', trb, trn, tra, jptra ) ! linear ssh 140 132 ELSE ; CALL tra_nxt_vvl( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra, & … … 142 134 ENDIF 143 135 ENDIF 144 145 ! trends computation 146 IF( l_trdtrc ) THEN ! trends 136 ! 137 IF( l_trdtrc ) THEN ! trends: send Asselin filter trends to trdtra manager for further diagnostics 147 138 DO jn = 1, jptra 148 139 DO jk = 1, jpkm1 149 zfact = 1. e0/ r2dt(jk)140 zfact = 1._wp / r2dt(jk) 150 141 ztrdt(:,:,jk,jn) = ( trb(:,:,jk,jn) - ztrdt(:,:,jk,jn) ) * zfact 151 142 CALL trd_tra( kt, 'TRC', jn, jptra_atf, ztrdt ) -
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r5866 r5883 114 114 END SUBROUTINE trc_stp 115 115 116 116 117 SUBROUTINE trc_mean_qsr( kt ) 117 118 !!---------------------------------------------------------------------- … … 128 129 INTEGER, INTENT(in) :: kt 129 130 INTEGER :: jn 130 131 !!---------------------------------------------------------------------- 132 ! 131 133 IF( kt == nittrc000 ) THEN 132 134 IF( ln_cpl ) THEN … … 163 165 DO jn = 1, nb_rec_per_days - 1 164 166 qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 165 END DO167 END DO 166 168 qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 167 169 qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days
Note: See TracChangeset
for help on using the changeset viewer.