Changeset 4946 for branches/2014/dev_MERGE_2014/NEMOGCM/NEMO
- Timestamp:
- 2014-12-02T10:38:20+01:00 (10 years ago)
- Location:
- branches/2014/dev_MERGE_2014/NEMOGCM/NEMO
- Files:
-
- 14 deleted
- 122 edited
- 14 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_2/limhdf_2.F90
r3625 r4946 86 86 zdiv0(:, 1 ) = 0._wp 87 87 zdiv0(:,jpj) = 0._wp 88 IF( .NOT.lk_vopt_loop ) THEN 89 zflu (jpi,:) = 0._wp 90 zflv (jpi,:) = 0._wp 91 zdiv0(1, :) = 0._wp 92 zdiv0(jpi,:) = 0._wp 93 ENDIF 88 zflu (jpi,:) = 0._wp 89 zflv (jpi,:) = 0._wp 90 zdiv0(1, :) = 0._wp 91 zdiv0(jpi,:) = 0._wp 94 92 95 93 zconv = 1._wp !== horizontal diffusion using a Crant-Nicholson scheme ==! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_2/limistate_2.F90
r4624 r4946 14 14 !! 'key_lim2' : LIM 2.0 sea-ice model 15 15 !!---------------------------------------------------------------------- 16 !!----------------------------------------------------------------------17 16 !! lim_istate_2 : Initialisation of diagnostics ice variables 18 17 !! lim_istate_init_2 : initialization of ice state and namelist read … … 34 33 PUBLIC lim_istate_2 ! routine called by lim_init_2.F90 35 34 36 ! !! ** namelist (namiceini) **37 LOGICAL :: ln_limini ! :Ice initialization state35 ! !! ** namelist (namiceini) ** 36 LOGICAL :: ln_limini ! Ice initialization state 38 37 REAL(wp) :: ttest ! threshold water temperature for initial sea ice 39 38 REAL(wp) :: hninn ! initial snow thickness in the north … … 51 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 52 51 !!---------------------------------------------------------------------- 53 54 52 CONTAINS 55 53 … … 71 69 IF( .NOT. ln_limini ) THEN 72 70 73 tfu(:,:) = tfreez( tsn(:,:,1,jp_sal) ) * tmask(:,:,1) ! freezing/melting point of sea water [Celcius]71 tfu(:,:) = eos_fzp( tsn(:,:,1,jp_sal) ) * tmask(:,:,1) ! freezing/melting point of sea water [Celcius] 74 72 75 73 DO jj = 1, jpj -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_2/limsbc_2.F90
r4306 r4946 30 30 USE sbc_oce ! surface boundary condition: ocean 31 31 USE sbccpl 32 USE cpl_oasis3, ONLY : lk_cpl33 32 USE oce , ONLY : sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 34 33 USE albedo ! albedo parameters … … 97 96 !! - emp : freshwater budget: mass flux 98 97 !! - sfx : freshwater budget: salt flux due to Freezing/Melting 99 !! - utau : sea surface i-stress (ocean referential)100 !! - vtau : sea surface j-stress (ocean referential)101 98 !! - fr_i : ice fraction 102 99 !! - tn_ice : sea-ice surface temperature 103 !! - alb_ice : sea-ice albe rdo (lk_cpl=T)100 !! - alb_ice : sea-ice albedo (lk_cpl=T) 104 101 !! 105 102 !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. … … 183 180 184 181 ! computation the solar flux at ocean surface 185 #if defined key_coupled 186 zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) )187 #else 188 zqsr = pfrld(ji,jj) * qsr(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj)189 #endif 182 IF( lk_cpl ) THEN 183 zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) ) 184 ELSE 185 zqsr = pfrld(ji,jj) * qsr(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj) 186 ENDIF 190 187 ! computation the non solar heat flux at ocean surface 191 188 zqns = - ( 1. - thcm(ji,jj) ) * zqsr & ! part of the solar energy used in leads … … 206 203 ! 207 204 ! mass flux at the ocean-atmosphere interface (open ocean fraction = leads area) 208 #if defined key_coupled209 205 ! ! coupled mode: 210 zemp = + emp_tot(ji,jj) & ! net mass flux over the grid cell (ice+ocean area) 211 & - emp_ice(ji,jj) * ( 1. - pfrld(ji,jj) ) ! minus the mass flux intercepted by sea-ice 212 #else 213 ! ! forced mode: 214 zemp = + emp(ji,jj) * frld(ji,jj) & ! mass flux over open ocean fraction 215 & - tprecip(ji,jj) * ( 1. - frld(ji,jj) ) & ! liquid precip. over ice reaches directly the ocean 216 & + sprecip(ji,jj) * ( 1. - pfrld(ji,jj) ) ! snow is intercepted by sea-ice (previous frld) 217 #endif 206 IF( lk_cpl ) THEN 207 zemp = + emp_tot(ji,jj) & ! net mass flux over the grid cell (ice+ocean area) 208 & - emp_ice(ji,jj) * ( 1. - pfrld(ji,jj) ) ! minus the mass flux intercepted by sea-ice 209 ELSE 210 ! ! forced mode: 211 zemp = + emp(ji,jj) * frld(ji,jj) & ! mass flux over open ocean fraction 212 & - tprecip(ji,jj) * ( 1. - frld(ji,jj) ) & ! liquid precip. over ice reaches directly the ocean 213 & + sprecip(ji,jj) * ( 1. - pfrld(ji,jj) ) ! snow is intercepted by sea-ice (previous frld) 214 ENDIF 218 215 ! 219 216 ! mass flux at the ocean/ice interface (sea ice fraction) … … 259 256 !-----------------------------------------------! 260 257 261 #if defined key_coupled 262 tn_ice(:,:,1) = sist(:,:) ! sea-ice surface temperature263 ht_i(:,:,1) = hicif(:,:)264 ht_s(:,:,1) = hsnif(:,:)265 a_i(:,:,1) = fr_i(:,:)266 ! ! Computation of snow/ice and ocean albedo267 CALL albedo_ice( tn_ice, ht_i, ht_s, zalbp, zalb )268 alb_ice(:,:,1) = 0.5 * ( zalbp(:,:,1) + zalb (:,:,1) ) ! Ice albedo (mean clear and overcast skys)269 CALL iom_put( "icealb_cea", alb_ice(:,:,1) * fr_i(:,:) ) ! ice albedo270 #endif 258 IF( lk_cpl) THEN 259 tn_ice(:,:,1) = sist(:,:) ! sea-ice surface temperature 260 ht_i(:,:,1) = hicif(:,:) 261 ht_s(:,:,1) = hsnif(:,:) 262 a_i(:,:,1) = fr_i(:,:) 263 ! ! Computation of snow/ice and ocean albedo 264 CALL albedo_ice( tn_ice, ht_i, ht_s, zalbp, zalb ) 265 alb_ice(:,:,1) = 0.5 * ( zalbp(:,:,1) + zalb (:,:,1) ) ! Ice albedo (mean clear and overcast skys) 266 CALL iom_put( "icealb_cea", alb_ice(:,:,1) * fr_i(:,:) ) ! ice albedo 267 ENDIF 271 268 272 269 IF(ln_ctl) THEN ! control print 273 270 CALL prt_ctl(tab2d_1=qsr , clinfo1=' lim_sbc: qsr : ', tab2d_2=qns , clinfo2=' qns : ') 274 271 CALL prt_ctl(tab2d_1=emp , clinfo1=' lim_sbc: emp : ', tab2d_2=sfx , clinfo2=' sfx : ') 275 CALL prt_ctl(tab2d_1=utau , clinfo1=' lim_sbc: utau : ', mask1=umask, &276 & tab2d_2=vtau , clinfo2=' vtau : ' , mask2=vmask )277 272 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' lim_sbc: fr_i : ', tab2d_2=tn_ice(:,:,1), clinfo2=' tn_ice : ') 278 273 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_2/limthd_2.F90
r4924 r4946 33 33 USE limtab_2 34 34 USE prtctl ! Print control 35 USE cpl_oasis3, ONLY : lk_cpl36 35 USE diaar5 , ONLY : lk_diaar5 37 36 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 219 218 220 219 ! partial computation of the lead energy budget (qldif) 221 #if defined key_coupled222 qldif(ji,jj) = tms(ji,jj) * rdt_ice &223 & * ( ( qsr_tot(ji,jj) - qsr_ice(ji,jj,1) * zfricp ) * ( 1.0 - thcm(ji,jj) ) &224 & + ( qns_tot(ji,jj) - qns_ice(ji,jj,1) * zfricp ) &225 & + frld(ji,jj) * ( fdtcn(ji,jj) + ( 1.0 - zindb ) * fsbbq(ji,jj) ) )226 #else 227 qldif(ji,jj) = tms(ji,jj) * rdt_ice * frld(ji,jj) &228 & * ( qsr(ji,jj) * ( 1.0 - thcm(ji,jj) ) &229 & + qns(ji,jj) + fdtcn(ji,jj) &230 & + ( 1.0 - zindb ) * fsbbq(ji,jj) )231 #endif 220 IF( lk_cpl ) THEN 221 qldif(ji,jj) = tms(ji,jj) * rdt_ice & 222 & * ( ( qsr_tot(ji,jj) - qsr_ice(ji,jj,1) * zfricp ) * ( 1.0 - thcm(ji,jj) ) & 223 & + ( qns_tot(ji,jj) - qns_ice(ji,jj,1) * zfricp ) & 224 & + frld(ji,jj) * ( fdtcn(ji,jj) + ( 1.0 - zindb ) * fsbbq(ji,jj) ) ) 225 ELSE 226 qldif(ji,jj) = tms(ji,jj) * rdt_ice * frld(ji,jj) & 227 & * ( qsr(ji,jj) * ( 1.0 - thcm(ji,jj) ) & 228 & + qns(ji,jj) + fdtcn(ji,jj) & 229 & + ( 1.0 - zindb ) * fsbbq(ji,jj) ) 230 ENDIF 232 231 ! parlat : percentage of energy used for lateral ablation (0.0) 233 232 zfntlat = 1.0 - MAX( rzero , SIGN( rone , - qldif(ji,jj) ) ) … … 449 448 zztmp = 1.0 / rdt_ice 450 449 CALL iom_put( 'iceprod_cea' , hicifp (:,:) * zztmp ) ! Ice produced [m/s] 450 CALL iom_put( 'iiceconc' , fr_i(:,:) ) ! Ice concentration [-] 451 451 IF( lk_diaar5 ) THEN 452 452 CALL iom_put( 'snowmel_cea' , rdm_snw(:,:) * zztmp ) ! Snow melt [kg/m2/s] -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_2/limthd_zdf_2.F90
r4306 r4946 18 18 USE ice_2 19 19 USE limistate_2 20 USE cpl_oasis3, ONLY : lk_cpl20 USE sbc_oce, ONLY : lk_cpl 21 21 USE in_out_manager 22 22 USE lib_mpp ! MPP library -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90
r4932 r4946 75 75 76 76 ! 1/area 77 z1_area = 1. d0/ MAX( glob_sum( area(:,:) * tms(:,:) ), epsi06 )77 z1_area = 1._wp / MAX( glob_sum( area(:,:) * tms(:,:) ), epsi06 ) 78 78 79 79 zinda = MAX( 0._wp , SIGN( 1._wp , glob_sum( area(:,:) * tms(:,:) ) - epsi06 ) ) … … 244 244 ! 2 - initial conservation variables ! 245 245 ! ---------------------------------- ! 246 !frc_vol = 0. d0! volume trend due to forcing247 !frc_sal = 0. d0! salt content - - - -248 !bg_grme = 0. d0! ice growth + melt volume trend246 !frc_vol = 0._wp ! volume trend due to forcing 247 !frc_sal = 0._wp ! salt content - - - - 248 !bg_grme = 0._wp ! ice growth + melt volume trend 249 249 ! 250 250 CALL lim_diahsb_rst( nstart, 'READ' ) !* read or initialize all required files … … 280 280 IF(lwp) WRITE(numout,*) ' lim_diahsb at initial state ' 281 281 IF(lwp) WRITE(numout,*) '~~~~~~~' 282 frc_vol = 0. d0283 frc_sal = 0. d0284 bg_grme = 0. d0285 ENDIF 282 frc_vol = 0._wp 283 frc_sal = 0._wp 284 bg_grme = 0._wp 285 ENDIF 286 286 287 287 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90
r4333 r4946 83 83 zdiv0(:, 1 ) = 0._wp 84 84 zdiv0(:,jpj) = 0._wp 85 IF( .NOT.lk_vopt_loop ) THEN 86 zflu (jpi,:) = 0._wp 87 zflv (jpi,:) = 0._wp 88 zdiv0(1, :) = 0._wp 89 zdiv0(jpi,:) = 0._wp 90 ENDIF 85 zflu (jpi,:) = 0._wp 86 zflv (jpi,:) = 0._wp 87 zdiv0(1, :) = 0._wp 88 zdiv0(jpi,:) = 0._wp 91 89 92 90 zconv = 1._wp !== horizontal diffusion using a Crant-Nicholson scheme ==! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90
r4932 r4946 6 6 !! History : 2.0 ! 2004-01 (C. Ethe, G. Madec) Original code 7 7 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation 8 !! - ! 201 2 (C. Rousset) add par_oce (for jp_sal)...bug?8 !! - ! 2014 (C. Rousset) add N/S initializations 9 9 !!---------------------------------------------------------------------- 10 10 #if defined key_lim3 … … 29 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 30 30 USE wrk_nemo ! work arrays 31 USE cpl_oasis3, ONLY : lk_cpl32 31 33 32 IMPLICIT NONE … … 36 35 PUBLIC lim_istate ! routine called by lim_init.F90 37 36 38 !! * Module variables39 37 ! !!** init namelist (namiceini) ** 40 38 REAL(wp) :: thres_sst ! threshold water temperature for initial sea ice … … 56 54 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 57 55 !!---------------------------------------------------------------------- 58 59 56 CONTAINS 60 57 … … 80 77 !! 81 78 !! ** Notes : o_i, t_su, t_s, t_i, s_i must be filled everywhere, even 82 !! where there is no ice (clem: I do not know why but it is mandatory)79 !! where there is no ice (clem: I do not know why, is it mandatory?) 83 80 !! 84 81 !! History : … … 116 113 CALL lim_istate_init ! reading the initials parameters of the ice 117 114 118 # if defined key_coupled119 albege(:,:) = 0.8 * tms(:,:)120 # endif121 122 115 ! surface temperature 123 116 DO jl = 1, jpl ! loop over categories … … 125 118 tn_ice(:,:,jl) = rtt * tms(:,:) 126 119 END DO 127 ! Basal temperature is set to the freezing point of seawater in Kelvin 128 t_bo(:,:) = ( tfreez( tsn(:,:,1,jp_sal) ) + rt0 ) * tms(:,:) 120 121 ! basal temperature (considered at freezing point) 122 t_bo(:,:) = ( eos_fzp( tsn(:,:,1,jp_sal) ) + rt0 ) * tms(:,:) 129 123 130 124 IF( ln_limini ) THEN … … 133 127 ! 2) Basal temperature, ice mask and hemispheric index 134 128 !-------------------------------------------------------------------- 135 ! ice if sst <= t-freez + thres_sst 136 DO jj = 1, jpj 129 130 DO jj = 1, jpj ! ice if sst <= t-freez + ttest 137 131 DO ji = 1, jpi 138 132 IF( ( tsn(ji,jj,1,jp_tem) - ( t_bo(ji,jj) - rt0 ) ) * tms(ji,jj) >= thres_sst ) THEN … … 146 140 147 141 ! Hemispheric index 148 ! MV 2011 new initialization149 142 DO jj = 1, jpj 150 143 DO ji = 1, jpi … … 156 149 END DO 157 150 END DO 158 ! END MV 2011 new initialization159 151 160 152 !-------------------------------------------------------------------- -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90
r4924 r4946 32 32 USE sbc_oce ! Surface boundary condition: ocean fields 33 33 USE sbccpl 34 USE cpl_oasis3, ONLY : lk_cpl 35 USE oce , ONLY : iatte, oatte, sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 34 USE oce , ONLY : fraqsr_1lev, sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 36 35 USE albedo ! albedo parameters 37 36 USE lbclnk ! ocean lateral boundary condition - MPP exchanges … … 98 97 !! - fr_i : ice fraction 99 98 !! - tn_ice : sea-ice surface temperature 100 !! - alb_ice : sea-ice albe rdo (lk_cpl=T)99 !! - alb_ice : sea-ice albedo (lk_cpl=T) 101 100 !! 102 101 !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 103 102 !! Tartinville et al. 2001 Ocean Modelling, 3, 95-108. 103 !! These refs are now obsolete since everything has been revised 104 !! The ref should be Rousset et al., 2015? 104 105 !!--------------------------------------------------------------------- 105 INTEGER, INTENT(in) :: kt ! number of iteration 106 ! 107 INTEGER :: ji, jj, jl, jk ! dummy loop indices 108 REAL(wp) :: zinda, zemp ! local scalars 109 REAL(wp) :: zf_mass ! Heat flux associated with mass exchange ice->ocean (W.m-2) 110 REAL(wp) :: zfcm1 ! New solar flux received by the ocean 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb, zalbp ! 2D/3D workspace 106 INTEGER, INTENT(in) :: kt ! number of iteration 107 ! 108 INTEGER :: ji, jj, jl, jk ! dummy loop indices 109 ! 110 REAL(wp) :: zinda, zemp ! local scalars 111 REAL(wp) :: zf_mass ! Heat flux associated with mass exchange ice->ocean (W.m-2) 112 REAL(wp) :: zfcm1 ! New solar flux received by the ocean 113 ! 114 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 2D/3D workspace 112 115 !!--------------------------------------------------------------------- 113 114 IF( lk_cpl ) CALL wrk_alloc( jpi, jpj, jpl, zalb, zalbp )115 116 116 117 ! make calls for heat fluxes before it is modified … … 134 135 ! Solar heat flux reaching the ocean = zfcm1 (W.m-2) 135 136 !--------------------------------------------------- 136 IF( lk_cpl ) THEN ! be carfeful: not been tested yet137 ! original line137 IF( lk_cpl ) THEN 138 !!! LIM2 version zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) ) 138 139 zfcm1 = qsr_tot(ji,jj) 139 !!!zfcm1 = qsr_tot(ji,jj) + ftr_ice(ji,jj) * ( 1._wp - pfrld(ji,jj) ) / ( 1._wp - zinda + zinda * iatte(ji,jj) )140 140 DO jl = 1, jpl 141 zfcm1 = zfcm1 - ( qsr_ice(ji,jj,jl) - ftr_ice(ji,jj,jl) ) * a_i_b(ji,jj,jl)141 zfcm1 = zfcm1 + ( ftr_ice(ji,jj,jl) - qsr_ice(ji,jj,jl) ) * a_i_b(ji,jj,jl) 142 142 END DO 143 143 ELSE 144 !!!zfcm1 = pfrld(ji,jj) * qsr(ji,jj) + & 145 !!! & ( 1._wp - pfrld(ji,jj) ) * ftr_ice(ji,jj) / ( 1._wp - zinda + zinda * iatte(ji,jj) ) 144 !!! LIM2 version zqsr = pfrld(ji,jj) * qsr(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj) 146 145 zfcm1 = pfrld(ji,jj) * qsr(ji,jj) 147 146 DO jl = 1, jpl … … 217 216 218 217 !------------------------------------------------! 219 ! Computation of snow/ice and ocean albedo!218 ! Snow/ice albedo (only if sent to coupler) ! 220 219 !------------------------------------------------! 221 220 IF( lk_cpl ) THEN ! coupled case 222 CALL albedo_ice( t_su, ht_i, ht_s, zalbp, zalb ) ! snow/ice albedo 223 alb_ice(:,:,:) = 0.5_wp * zalbp(:,:,:) + 0.5_wp * zalb (:,:,:) ! Ice albedo (mean clear and overcast skys) 221 222 CALL wrk_alloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 223 224 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 225 226 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 227 228 CALL wrk_dealloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 229 224 230 ENDIF 225 231 … … 231 237 CALL prt_ctl( tab3d_1=tn_ice, clinfo1=' lim_sbc: tn_ice : ', kdim=jpl ) 232 238 ENDIF 233 ! 234 IF( lk_cpl ) CALL wrk_dealloc( jpi, jpj, jpl, zalb, zalbp ) 235 ! 239 236 240 END SUBROUTINE lim_sbc_flx 237 241 … … 346 350 ! clem modif 347 351 IF( .NOT. ln_rstart ) THEN 348 iatte(:,:) = 1._wp 349 oatte(:,:) = 1._wp 352 fraqsr_1lev(:,:) = 1._wp 350 353 ENDIF 351 354 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r4924 r4946 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain variables 24 USE oce , ONLY : iatte, oatte24 USE oce , ONLY : fraqsr_1lev 25 25 USE ice ! LIM: sea-ice variables 26 26 USE par_ice ! LIM: sea-ice parameters … … 43 43 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 44 44 USE timing ! Timing 45 USE cpl_oasis3, ONLY : lk_cpl46 45 USE limcons ! conservation tests 47 46 … … 68 67 !! *** ROUTINE lim_thd *** 69 68 !! 70 !! ** Purpose : This routine manages the ice thermodynamic.69 !! ** Purpose : This routine manages ice thermodynamics 71 70 !! 72 71 !! ** Action : - Initialisation of some variables … … 74 73 !! at the ice base, snow acc.,heat budget of the leads) 75 74 !! - selection of the icy points and put them in an array 76 !! - call lim_vert_ther for vert ice thermodynamic 77 !! - back to the geographic grid 78 !! - selection of points for lateral accretion 79 !! - call lim_lat_acc for the ice accretion 75 !! - call lim_thd_dif for vertical heat diffusion 76 !! - call lim_thd_dh for vertical ice growth and melt 77 !! - call lim_thd_ent for enthalpy remapping 78 !! - call lim_thd_sal for ice desalination 79 !! - call lim_thd_temp to retrieve temperature from ice enthalpy 80 80 !! - back to the geographic grid 81 81 !! 82 !! ** References : H. Goosse et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-9082 !! ** References : 83 83 !!--------------------------------------------------------------------- 84 84 INTEGER, INTENT(in) :: kt ! number of iteration … … 93 93 ! 94 94 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 95 ! 96 REAL(wp), POINTER, DIMENSION(:,:) :: zqsr, zqns 95 97 !!------------------------------------------------------------------- 98 CALL wrk_alloc( jpi, jpj, zqsr, zqns ) 99 96 100 IF( nn_timing == 1 ) CALL timing_start('limthd') 97 101 … … 137 141 !-----------------------------------------------------------------------------! 138 142 143 !--- Ocean solar and non solar fluxes to be used in zqld 144 IF ( .NOT. lk_cpl ) THEN ! --- forced case, fluxes to the lead are the same as over the ocean 145 ! 146 zqsr(:,:) = qsr(:,:) ; zqns(:,:) = qns(:,:) 147 ! 148 ELSE ! --- coupled case, fluxes to the lead are total - intercepted 149 ! 150 zqsr(:,:) = qsr_tot(:,:) ; zqns(:,:) = qns_tot(:,:) 151 ! 152 DO jl = 1, jpl 153 DO jj = 1, jpj 154 DO ji = 1, jpi 155 zqsr(ji,jj) = zqsr(ji,jj) - qsr_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 156 zqns(ji,jj) = zqns(ji,jj) - qns_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 157 END DO 158 END DO 159 END DO 160 ! 161 ENDIF 162 139 163 !CDIR NOVERRCHK 140 164 DO jj = 1, jpj … … 149 173 ! ! temperature and turbulent mixing (McPhee, 1992) 150 174 ! 175 151 176 ! --- Energy received in the lead, zqld is defined everywhere (J.m-2) --- ! 152 zqld = tms(ji,jj) * rdt_ice * & 153 & ( pfrld(ji,jj) * ( qsr(ji,jj) * oatte(ji,jj) & ! solar heat + clem modif 154 & + qns(ji,jj) ) & ! non solar heat 155 ! latent heat of precip (note that precip is included in qns but not in qns_ice) 156 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) & 157 & * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 158 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) & 159 & * rcp * ( tatm_ice(ji,jj) - rtt ) ) 177 ! REMARK valid at least in forced mode from clem 178 ! precip is included in qns but not in qns_ice 179 IF ( lk_cpl ) THEN 180 zqld = tms(ji,jj) * rdt_ice * & 181 & ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) & ! pfrld already included in coupled mode 182 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) * & ! heat content of precip 183 & ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 184 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 185 ELSE 186 zqld = tms(ji,jj) * rdt_ice * & 187 & ( pfrld(ji,jj) * ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) ) & 188 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) * & ! heat content of precip 189 & ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 190 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 191 ENDIF 160 192 161 193 !-- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- ! … … 187 219 hfx_in(ji,jj) = hfx_in(ji,jj) & 188 220 ! heat flux above the ocean 189 & + pfrld(ji,jj) * ( qns(ji,jj) + qsr(ji,jj) )&221 & + pfrld(ji,jj) * ( zqns(ji,jj) + zqsr(ji,jj) ) & 190 222 ! latent heat of precip (note that precip is included in qns but not in qns_ice) 191 223 & + ( 1._wp - pfrld(ji,jj) ) * sprecip(ji,jj) * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & … … 198 230 ! Second step in limthd_dh : heat remaining if total melt (zq_rema) 199 231 ! Third step in limsbc : heat from ice-ocean mass exchange (zf_mass) + solar 200 hfx_out(ji,jj) = hfx_out(ji,jj) &232 hfx_out(ji,jj) = hfx_out(ji,jj) & 201 233 ! Non solar heat flux received by the ocean 202 & + pfrld(ji,jj) * qns(ji,jj) &234 & + pfrld(ji,jj) * qns(ji,jj) & 203 235 ! latent heat of precip (note that precip is included in qns but not in qns_ice) 204 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) 205 & * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus )&206 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) &236 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) & 237 & * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 238 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) & 207 239 ! heat flux taken from the ocean where there is open water ice formation 208 & - qlead(ji,jj) * r1_rdtice &240 & - qlead(ji,jj) * r1_rdtice & 209 241 ! heat flux taken from the ocean during bottom growth/melt (fhld should be 0 while bott growth) 210 & - at_i(ji,jj) * fhtur(ji,jj) &242 & - at_i(ji,jj) * fhtur(ji,jj) & 211 243 & - at_i(ji,jj) * fhld(ji,jj) 212 244 … … 309 341 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 310 342 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 311 312 CALL tab_2d_1d( nbpb, iatte_1d (1:nbpb), iatte , jpi, jpj, npb(1:nbpb) )313 CALL tab_2d_1d( nbpb, oatte_1d (1:nbpb), oatte , jpi, jpj, npb(1:nbpb) )314 343 315 344 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) … … 485 514 ENDIF 486 515 ! 516 ! 517 CALL wrk_dealloc( jpi, jpj, zqsr, zqns ) 518 519 ! 487 520 ! conservation test 488 521 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 489 522 ! 490 523 IF( nn_timing == 1 ) CALL timing_stop('limthd') 524 491 525 END SUBROUTINE lim_thd 492 526 … … 555 589 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicethd in configuration namelist', lwp ) 556 590 IF(lwm) WRITE ( numoni, namicethd ) 591 592 IF( lk_cpl .AND. parsub /= 0.0 ) CALL ctl_stop( 'In coupled mode, use parsub = 0. or send dqla' ) 557 593 ! 558 594 IF(lwp) THEN ! control print -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90
r4924 r4946 26 26 USE wrk_nemo ! work arrays 27 27 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 28 USE cpl_oasis3, ONLY : lk_cpl29 28 30 29 IMPLICIT NONE … … 169 168 ztmelts = zinda * rtt + ( 1._wp - zinda ) * rtt 170 169 171 zfdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)172 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)170 zfdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 171 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 173 172 174 173 zq_su (ji) = MAX( 0._wp, zfdum * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - ztmelts ) ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90
r4924 r4946 25 25 USE wrk_nemo ! work arrays 26 26 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 27 USE cpl_oasis3, ONLY : lk_cpl27 USE sbc_oce, ONLY : lk_cpl 28 28 29 29 IMPLICIT NONE … … 146 146 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrid ! tridiagonal system terms 147 147 ! diag errors on heat 148 REAL(wp), POINTER, DIMENSION(:) :: zdq, zq_ini 149 REAL(wp) :: zhfx_err 148 REAL(wp), POINTER, DIMENSION(:) :: zdq, zq_ini, zhfx_err 150 149 !!------------------------------------------------------------------ 151 150 ! … … 158 157 CALL wrk_alloc( jpij, nlay_i+3, 3, ztrid ) 159 158 160 CALL wrk_alloc( jpij, zdq, zq_ini )159 CALL wrk_alloc( jpij, zdq, zq_ini, zhfx_err ) 161 160 162 161 ! --- diag error on heat diffusion - PART 1 --- ! … … 272 271 273 272 DO ji = kideb, kiut ! Radiation transmitted below the ice 274 !!!ftr_ice_1d(ji) = ftr_ice_1d(ji) + iatte_1d(ji) * zradtr_i(ji,nlay_i) * a_i_1d(ji) / at_i_1d(ji) ! clem modif275 273 ftr_ice_1d(ji) = zradtr_i(ji,nlay_i) 276 274 END DO … … 408 406 !------------------------------------------------------------------------------| 409 407 ! 410 DO ji = kideb , kiut 411 ! update of the non solar flux according to the update in T_su 412 qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsubit(ji) ) 413 408 IF( .NOT. lk_cpl ) THEN !--- forced atmosphere case 409 DO ji = kideb , kiut 410 ! update of the non solar flux according to the update in T_su 411 qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsubit(ji) ) 412 END DO 413 ENDIF 414 415 ! Update incoming flux 416 DO ji = kideb , kiut 414 417 ! update incoming flux 415 418 zf(ji) = zfsw(ji) & ! net absorbed solar radiation 416 + qns_ice_1d(ji) ! non solar total flux419 + qns_ice_1d(ji) ! non solar total flux 417 420 ! (LWup, LWdw, SH, LH) 418 421 END DO … … 740 743 CALL lim_thd_enmelt( kideb, kiut ) 741 744 742 ! --- diag erroron heat diffusion - PART 2 --- !745 ! --- diag conservation imbalance on heat diffusion - PART 2 --- ! 743 746 DO ji = kideb, kiut 744 747 zdq(ji) = - zq_ini(ji) + ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) / REAL( nlay_i ) + & 745 748 & SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) / REAL( nlay_s ) ) 746 zhfx_err = ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice ) 747 hfx_err_1d(ji) = hfx_err_1d(ji) + zhfx_err * a_i_1d(ji) 748 ! --- correction of qns_ice and surface conduction flux --- ! 749 qns_ice_1d(ji) = qns_ice_1d(ji) - zhfx_err 750 fc_su (ji) = fc_su (ji) - zhfx_err 751 ! --- Heat flux at the ice surface in W.m-2 --- ! 749 zhfx_err(ji) = ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice ) 750 hfx_err_1d(ji) = hfx_err_1d(ji) + zhfx_err(ji) * a_i_1d(ji) 751 END DO 752 753 ! diagnose external surface (forced case) or bottom (forced case) from heat conservation 754 IF( .NOT. lk_cpl ) THEN ! --- forced case: qns_ice and fc_su are diagnosed 755 ! 756 DO ji = kideb, kiut 757 qns_ice_1d(ji) = qns_ice_1d(ji) - zhfx_err(ji) 758 fc_su (ji) = fc_su(ji) - zhfx_err(ji) 759 END DO 760 ! 761 ELSE ! --- coupled case: ocean turbulent heat flux is diagnosed 762 ! 763 DO ji = kideb, kiut 764 fhtur_1d (ji) = fhtur_1d(ji) - zhfx_err(ji) 765 END DO 766 ! 767 ENDIF 768 769 ! --- compute diagnostic net heat flux at the surface of the snow-ice system (W.m2) 770 DO ji = kideb, kiut 752 771 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 753 772 hfx_in (ii,ij) = hfx_in (ii,ij) + a_i_1d(ji) * ( qsr_ice_1d(ji) + qns_ice_1d(ji) ) … … 763 782 CALL wrk_dealloc( jpij, nlay_i+3, zindterm, zindtbis, zdiagbis ) 764 783 CALL wrk_dealloc( jpij, nlay_i+3, 3, ztrid ) 765 CALL wrk_dealloc( jpij, zdq, zq_ini )784 CALL wrk_dealloc( jpij, zdq, zq_ini, zhfx_err ) 766 785 767 786 END SUBROUTINE lim_thd_dif -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r4924 r4946 112 112 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_1d ! 1-D version of smv_i 113 113 114 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i114 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i 115 115 116 116 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel ! relative ice / frazil velocity … … 133 133 !Energy of melting q(S,T) [J.m-3] 134 134 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , -v_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 135 e_i(ji,jj,jk,jl) = zindb * e_i(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i, wp ) 135 e_i(ji,jj,jk,jl) = zindb * e_i(ji,jj,jk,jl) & 136 & / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i, wp ) 136 137 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac 137 138 END DO … … 478 479 qh_i_old(ji,nlay_i+1) = ze_newice(ji) * zv_newfra 479 480 ENDDO 480 481 481 ! --- Ice enthalpy remapping --- ! 482 482 CALL lim_thd_ent( 1, nbpac, ze_i_1d(1:nbpac,:,jl) ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r4924 r4946 114 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_i_new !: Salinity of new ice at the bottom 115 115 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: iatte_1d !: attenuation coef of the input solar flux (unitless)117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: oatte_1d !: attenuation coef of the input solar flux (unitless)118 119 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_1d !: corresponding to the 2D var t_s 120 117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_i_1d !: corresponding to the 2D var t_i … … 148 145 & qsr_ice_1d (jpij) , & 149 146 & fr1_i0_1d(jpij) , fr2_i0_1d(jpij) , qns_ice_1d(jpij) , & 150 & t_bo_1d (jpij) , iatte_1d (jpij) , oatte_1d (jpij) ,&151 & hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) , &147 & t_bo_1d (jpij) , & 148 & hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) , & 152 149 & hfx_dif_1d(jpij) ,hfx_opw_1d(jpij) , & 153 150 & hfx_thd_1d(jpij) , hfx_spr_1d(jpij) , & -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90
r4812 r4946 535 535 !!--------------------------------------------------------------------- 536 536 #if defined key_ldfslp && ! defined key_c1d 537 CALL eos ( pts, rhd, rhop, gdept_0(:,:,:) ) ! Time-filtered in situ density538 CALL bn2 ( pts, rn2 ) ! before Brunt-Vaisala frequency537 CALL eos_rab( pts, rab_n ) ! now local thermal/haline expension ratio at T-points 538 CALL bn2 ( pts, rab_n, rn2 ) ! now Brunt-Vaisala 539 539 IF( ln_zps ) & ! Partial steps: before Horizontal DErivative 540 540 & CALL zps_hde( kt, jpts, pts, gtsu, gtsv, & ! Partial steps: before horizontal gradient -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OOO_SRC/nemogcm.F90
r4624 r4946 54 54 USE icbini ! handle bergs, initialisation 55 55 USE icbstp ! handle bergs, calving, themodynamics and transport 56 #if defined key_oasis357 56 USE cpl_oasis3 ! OASIS3 coupling 58 #elif defined key_oasis459 USE cpl_oasis4 ! OASIS4 coupling (not working)60 #endif61 57 USE lib_mpp ! distributed memory computing 62 58 #if defined key_iomput … … 166 162 #if defined key_iomput 167 163 IF( Agrif_Root() ) THEN 168 # if defined key_oasis3 || defined key_oasis4 169 CALL cpl_prism_init( ilocal_comm ) ! nemo local communicator given by oasis 170 CALL xios_initialize( "oceanx",local_comm=ilocal_comm ) 171 # else 172 CALL xios_initialize( "nemo",return_comm=ilocal_comm ) 173 # endif 164 IF( lk_cpl ) THEN 165 CALL cpl_init( ilocal_comm ) ! nemo local communicator given by oasis 166 CALL xios_initialize( "oceanx",local_comm=ilocal_comm ) ! send nemo communicator to xios 167 ELSE 168 CALL xios_initialize( "nemo",return_comm=ilocal_comm ) ! nemo local communicator given by xios 169 ENDIF 170 ENDIF 174 171 ENDIF 175 172 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection 176 173 #else 177 # if defined key_oasis3 || defined key_oasis4 178 IF( Agrif_Root() ) THEN179 CALL cpl_prism_init( ilocal_comm )! nemo local communicator given by oasis180 ENDIF181 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)182 # else 183 ilocal_comm = 0184 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt)185 # endif 174 IF( lk_cpl ) THEN 175 IF( Agrif_Root() ) THEN 176 CALL cpl_init( ilocal_comm ) ! nemo local communicator given by oasis 177 ENDIF 178 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt) 179 ELSE 180 ilocal_comm = 0 181 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt) 182 ENDIF 186 183 #endif 187 184 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r4932 r4946 109 109 !! ** Action : 110 110 !!---------------------------------------------------------------------- 111 INTEGER :: ji, jj, jk 112 INTEGER :: jt 113 INTEGER :: imid 114 INTEGER :: inum 111 INTEGER :: ji, jj, jk, jt ! dummy loop indices 112 INTEGER :: imid, inum ! local integers 113 INTEGER :: ios ! Local integer output status for namelist read 115 114 INTEGER :: iiauper ! Number of time steps in the IAU period 116 115 INTEGER :: icycper ! Number of time steps in the cycle … … 120 119 INTEGER :: iitiaustr_date ! Date YYYYMMDD of IAU interval start time step 121 120 INTEGER :: iitiaufin_date ! Date YYYYMMDD of IAU interval final time step 122 INTEGER :: ios ! Local integer output status for namelist read 123 121 ! 124 122 REAL(wp) :: znorm ! Normalization factor for IAU weights 125 REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights 126 ! (should be equal to one) 123 REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) 127 124 REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid 128 125 REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid 129 126 REAL(wp) :: zdate_bkg ! Date in background state file for DI 130 127 REAL(wp) :: zdate_inc ! Time axis in increments file 131 132 REAL(wp), POINTER, DIMENSION(:,:) :: hdiv128 ! 129 REAL(wp), POINTER, DIMENSION(:,:) :: hdiv ! 2D workspace 133 130 !! 134 131 NAMELIST/nam_asminc/ ln_bkgwri, & … … 136 133 & ln_asmdin, ln_asmiau, & 137 134 & nitbkg, nitdin, nitiaustr, nitiaufin, niaufn, & 138 & ln_salfix, salfixmin, & 139 & nn_divdmp 135 & ln_salfix, salfixmin, nn_divdmp 140 136 !!---------------------------------------------------------------------- 141 137 … … 143 139 ! Read Namelist nam_asminc : assimilation increment interface 144 140 !----------------------------------------------------------------------- 145 146 141 ln_seaiceinc = .FALSE. 147 142 ln_temnofreeze = .FALSE. … … 186 181 icycper = nitend - nit000 + 1 ! Cycle interval length 187 182 188 ! Date of final time step 189 CALL calc_date( nit000, nitend, ndate0, iitend_date ) 190 191 ! Background time for Jb referenced to ndate0 192 CALL calc_date( nit000, nitbkg_r, ndate0, iitbkg_date ) 193 194 ! Background time for DI referenced to ndate0 195 CALL calc_date( nit000, nitdin_r, ndate0, iitdin_date ) 196 197 ! IAU start time referenced to ndate0 198 CALL calc_date( nit000, nitiaustr_r, ndate0, iitiaustr_date ) 199 200 ! IAU end time referenced to ndate0 201 CALL calc_date( nit000, nitiaufin_r, ndate0, iitiaufin_date ) 202 183 CALL calc_date( nit000, nitend , ndate0, iitend_date ) ! Date of final time step 184 CALL calc_date( nit000, nitbkg_r , ndate0, iitbkg_date ) ! Background time for Jb referenced to ndate0 185 CALL calc_date( nit000, nitdin_r , ndate0, iitdin_date ) ! Background time for DI referenced to ndate0 186 CALL calc_date( nit000, nitiaustr_r, ndate0, iitiaustr_date ) ! IAU start time referenced to ndate0 187 CALL calc_date( nit000, nitiaufin_r, ndate0, iitiaufin_date ) ! IAU end time referenced to ndate0 188 ! 203 189 IF(lwp) THEN 204 190 WRITE(numout,*) … … 671 657 ! used to prevent the applied increments taking the temperature below the local freezing point 672 658 673 DO jk =1, jpkm1674 fzptnz (:,:,jk) = tfreez( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) )675 END DO659 DO jk = 1, jpkm1 660 fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 661 END DO 676 662 677 663 IF ( ln_asmiau ) THEN … … 688 674 IF(lwp) THEN 689 675 WRITE(numout,*) 690 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', & 691 & kt,' with IAU weight = ', wgtiau(it) 676 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 692 677 WRITE(numout,*) '~~~~~~~~~~~~' 693 678 ENDIF … … 737 722 IF (ln_temnofreeze) THEN 738 723 ! Do not apply negative increments if the temperature will fall below freezing 739 WHERE(t_bkginc(:,:,:) > 0.0_wp .OR. & 740 & tsn(:,:,:,jp_tem) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 724 WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. tsn(:,:,:,jp_tem) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 741 725 tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:) 742 726 END WHERE … … 747 731 ! Do not apply negative increments if the salinity will fall below a specified 748 732 ! minimum value salfixmin 749 WHERE(s_bkginc(:,:,:) > 0.0_wp .OR. & 750 & tsn(:,:,:,jp_sal) + s_bkginc(:,:,:) > salfixmin ) 733 WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. tsn(:,:,:,jp_sal) + s_bkginc(:,:,:) > salfixmin ) 751 734 tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:) 752 735 END WHERE … … 758 741 759 742 CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities 760 743 !!gm fabien 744 ! CALL eos( tsb, rhd, rhop ) ! Before potential and in situ densities 745 !!gm 746 747 761 748 IF( ln_zps .AND. .NOT. lk_c1d ) & 762 749 & CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient … … 766 753 #if defined key_zdfkpp 767 754 CALL eos( tsn, rhd, fsdept_n(:,:,:) ) ! Compute rhd 755 !!gm fabien CALL eos( tsn, rhd ) ! Compute rhd 768 756 #endif 769 757 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90
r4624 r4946 15 15 USE dom_oce ! ocean: domain variables 16 16 USE c1d ! 1D vertical configuration 17 USE trdmod ! ocean: trends18 USE trdmod_oce ! ocean: trends variables19 17 USE tradmp ! ocean: internal damping 20 18 USE zdf_oce ! ocean: vertical physics … … 164 162 !! ** Action : - (ua,va) momentum trends updated with the damping trend 165 163 !!---------------------------------------------------------------------- 166 !167 164 INTEGER, INTENT(in) :: kt ! ocean time-step index 168 165 !! … … 236 233 END SELECT 237 234 ! 238 ! ! Trend diagnostic239 IF( l_trddyn ) CALL trd_mod( utrdmp, vtrdmp, jpdyn_trd_dat, 'DYN', kt )235 !!gm ! ! Trend diagnostic 236 !!gm IF( l_trddyn ) CALL trd_mod( utrdmp, vtrdmp, jpdyn_trd_dat, 'DYN', kt ) 240 237 ! 241 238 ! ! Control print -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90
r4313 r4946 72 72 ! Ocean physics update (ua, va, ta, sa used as workspace) 73 73 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 74 CALL bn2( tsb, r n2b )! before Brunt-Vaisala frequency75 CALL bn2( tsn, r n2 )! now Brunt-Vaisala frequency74 CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 75 CALL bn2( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency 76 76 ! VERTICAL PHYSICS 77 77 CALL zdf_bfr( kstp ) ! bottom friction … … 115 115 ! Passive Tracer Model 116 116 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 117 CALL trc_stp( kstp )! time-stepping117 CALL trc_stp( kstp ) ! time-stepping 118 118 #endif 119 119 … … 121 121 ! Active tracers (ua, va used as workspace) 122 122 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 123 tsa(:,:,:,:) = 0.e0! set tracer trends to zero123 tsa(:,:,:,:) = 0._wp ! set tracer trends to zero 124 124 125 CALL tra_sbc ( kstp )! surface boundary condition126 IF( ln_traqsr ) CALL tra_qsr ( kstp )! penetrative solar radiation qsr127 IF( ln_tradmp ) CALL tra_dmp ( kstp )! internal damping trends- tracers128 IF( lk_zdfkpp ) CALL tra_kpp ( kstp )! KPP non-local tracer fluxes129 CALL tra_zdf ( kstp )! vertical mixing130 CALL tra_nxt ( kstp ) ! tracer fields at next time step131 IF( ln_zdfnpc ) CALL tra_npc ( kstp )! applied non penetrative convective adjustment on (t,s)132 CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) ) ! now (swap=before) in situ density for dynhpg module125 CALL tra_sbc( kstp ) ! surface boundary condition 126 IF( ln_traqsr ) CALL tra_qsr( kstp ) ! penetrative solar radiation qsr 127 IF( ln_tradmp ) CALL tra_dmp( kstp ) ! internal damping trends- tracers 128 IF( lk_zdfkpp ) CALL tra_kpp( kstp ) ! KPP non-local tracer fluxes 129 CALL tra_zdf( kstp ) ! vertical mixing 130 CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) ) ! now potential density for zdfmxl 131 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! applied non penetrative convective adjustment on (t,s) 132 CALL tra_nxt( kstp ) ! tracer fields at next time step 133 133 134 134 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 135 135 ! Dynamics (ta, sa used as workspace) 136 136 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 137 ua(:,:,:) = 0.e0! set dynamics trends to zero138 va(:,:,:) = 0.e0137 ua(:,:,:) = 0._wp ! set dynamics trends to zero 138 va(:,:,:) = 0._wp 139 139 140 IF( ln_dyndmp ) CALL dyn_dmp ( kstp )! internal damping trends- momentum141 CALL dyn_cor_c1d( kstp )! vorticity term including Coriolis142 CALL dyn_zdf ( kstp )! vertical diffusion143 CALL dyn_nxt_c1d( kstp )! lateral velocity at next time step140 IF( ln_dyndmp ) CALL dyn_dmp ( kstp ) ! internal damping trends- momentum 141 CALL dyn_cor_c1d( kstp ) ! vorticity term including Coriolis 142 CALL dyn_zdf ( kstp ) ! vertical diffusion 143 CALL dyn_nxt_c1d( kstp ) ! lateral velocity at next time step 144 144 145 145 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 146 146 ! Control and restarts 147 147 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 148 149 IF( kstp == nit000 ) CALL iom_close( numror )! close input ocean restart file150 IF( lrst_oce ) CALL rst_write ( kstp )! write output ocean restart file148 CALL stp_ctl( kstp, indic ) 149 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 150 IF( lrst_oce ) CALL rst_write( kstp ) ! write output ocean restart file 151 151 ! 152 152 END SUBROUTINE stp_c1d -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90
r4147 r4946 7 7 !! 8.5 ! 02-06 (G. Madec) F90: Free form and module 8 8 !! 9.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 9 !!---------------------------------------------------------------------- 10 #if ! defined key_coupled 11 9 !!---------------------------------------------------------------------- 12 10 !!---------------------------------------------------------------------- 13 11 !! Only for ORCA2 ORCA1 and ORCA025 … … 29 27 30 28 PUBLIC dia_fwb ! routine called by step.F90 31 32 LOGICAL, PUBLIC, PARAMETER :: lk_diafwb = .TRUE. !: fresh water budget flag33 29 34 30 REAL(wp) :: a_fwf , & … … 453 449 END SUBROUTINE dia_fwb 454 450 455 #else456 !!----------------------------------------------------------------------457 !! Default option : Dummy Module458 !!----------------------------------------------------------------------459 LOGICAL, PUBLIC, PARAMETER :: lk_diafwb = .FALSE. !: fresh water budget flag460 CONTAINS461 SUBROUTINE dia_fwb( kt ) ! Empty routine462 WRITE(*,*) 'dia_fwb: : You should not have seen this print! error?', kt463 END SUBROUTINE dia_fwb464 #endif465 466 451 !!====================================================================== 467 452 END MODULE diafwb -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r4724 r4946 96 96 ! Add geothermal ice shelf 97 97 IF( nn_isf .GE. 1 ) THEN 98 z_frc_trd_t = z_frc_trd_t + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * -1.9 * r1_rau0 ) * surf(:,:) ) 99 z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 98 z_frc_trd_t = z_frc_trd_t & 99 & + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 100 z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 100 101 ENDIF 101 102 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r4726 r4946 573 573 !!-------------------------------------------------------------------- 574 574 ! 575 CALL wrk_alloc( jpj , zphi , zfoo )576 CALL wrk_alloc( jpj , jpk , z_1)575 CALL wrk_alloc( jpj , zphi , zfoo ) 576 CALL wrk_alloc( jpj , jpk , z_1 ) 577 577 578 578 ! define time axis -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r4924 r4946 88 88 INTEGER, DIMENSION(2) :: ierr 89 89 !!---------------------------------------------------------------------- 90 !91 90 ierr = 0 92 !93 91 ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , & 94 92 & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , & … … 193 191 CALL iom_put( "sss2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface salinity 194 192 END IF 195 ! multiply by umask to prevent not numerical value error in the ioserver sometimes196 193 IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 197 194 CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) * fse3u_n(:,:,:) ) ! i-transport … … 580 577 ENDIF 581 578 582 #if ! defined key_coupled 583 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 584 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 585 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 586 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 587 CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn 588 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 589 #endif 590 591 592 593 #if ( defined key_coupled && ! defined key_lim3 && ! defined key_lim2 ) 594 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 595 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 596 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 597 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 598 CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping" , "Kg/m2/s", & ! erp * sn 599 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 600 #endif 579 IF( .NOT. lk_cpl ) THEN 580 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 581 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 582 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 583 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 584 CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn 585 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 586 ENDIF 587 588 IF( lk_cpl .AND. nn_ice <= 1 ) THEN 589 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 590 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 591 CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp 592 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 593 CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping" , "Kg/m2/s", & ! erp * sn 594 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 595 ENDIF 596 601 597 clmx ="l_max(only(x))" ! max index on a period 602 598 CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX … … 613 609 #endif 614 610 615 #if defined key_coupled 616 # if defined key_lim3 617 Must be adapted to LIM3 618 # endif 619 # if defined key_lim2 620 CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature" , "K" , & ! tn_ice 621 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 622 CALL histdef( nid_T,"soicealb" , "Ice Albedo" , "[0,1]" , & ! alb_ice 623 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 624 # endif 625 #endif 611 IF( lk_cpl .AND. nn_ice == 2 ) THEN 612 CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature" , "K" , & ! tn_ice 613 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 614 CALL histdef( nid_T,"soicealb" , "Ice Albedo" , "[0,1]" , & ! alb_ice 615 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 616 ENDIF 626 617 627 618 CALL histend( nid_T, snc4chunks=snc4set ) … … 773 764 ENDIF 774 765 775 #if ! defined key_coupled 776 ! CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 777 ! CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 778 ! IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 779 ! CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 780 #endif 781 #if ( defined key_coupled && ! defined key_lim3 && ! defined key_lim2 ) 782 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 783 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 766 IF( .NOT. lk_cpl ) THEN 767 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 768 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 784 769 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 785 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 786 #endif 770 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 771 ENDIF 772 IF( lk_cpl .AND. nn_ice <= 1 ) THEN 773 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 774 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 775 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 776 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 777 ENDIF 787 778 ! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) 788 779 ! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ??? … … 795 786 #endif 796 787 797 #if defined key_coupled 798 # if defined key_lim3 799 Must be adapted for LIM3 800 CALL histwrite( nid_T, "soicetem", it, tn_ice , ndim_hT, ndex_hT ) ! surf. ice temperature 801 CALL histwrite( nid_T, "soicealb", it, alb_ice , ndim_hT, ndex_hT ) ! ice albedo 802 # endif 803 # if defined key_lim2 804 CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT ) ! surf. ice temperature 805 CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT ) ! ice albedo 806 # endif 807 #endif 808 ! Write fields on U grid 788 IF( lk_cpl .AND. nn_ice == 2 ) THEN 789 CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT ) ! surf. ice temperature 790 CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT ) ! ice albedo 791 ENDIF 792 809 793 CALL histwrite( nid_U, "vozocrtx", it, un , ndim_U , ndex_U ) ! i-current 810 794 IF( ln_traldf_gdia ) THEN -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r4924 r4946 1003 1003 1004 1004 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) 1005 IF( .NOT. ln_vvl_zstar .AND. nn_isf .NE. 0) CALL ctl_stop( 'vvl_ztilde, vvl_layer, vvl_ztilde_as_zstar, vvl_zstar_at_eqtor not tested with ice shelf cavity (only vvl_zstar was tested)' )1005 IF( .NOT. ln_vvl_zstar .AND. nn_isf .NE. 0) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) 1006 1006 1007 1007 IF(lwp) THEN ! Print the choice -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r4924 r4946 1082 1082 ! test bathy 1083 1083 IF (risfdep(ji,jj) .GT. 1) THEN 1084 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1085 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1084 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) & 1085 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1086 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) & 1087 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1086 1088 1087 1089 IF (bathy(ji,jj) .GT. risfdep(ji,jj) .AND. mbathy(ji,jj) .LT. misfdep(ji,jj)) THEN … … 1104 1106 ! test bathy 1105 1107 IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1106 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1107 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1108 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1)& 1109 & + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1110 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) & 1111 & - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1108 1112 IF (zbathydiff .LE. zrisfdepdiff) THEN 1109 1113 mbathy(ji,jj) = mbathy(ji,jj) + 1 … … 1121 1125 DO ji = 1, jpim1 1122 1126 IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1123 zbathydiff =ABS(bathy(ji,jj ) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) 1124 zrisfdepdiff=ABS(risfdep(ji,jj+1) - (gdepw_1d(misfdep(ji,jj+1)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 1127 zbathydiff =ABS(bathy(ji,jj ) - (gdepw_1d(mbathy (ji,jj)+1) & 1128 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) 1129 zrisfdepdiff=ABS(risfdep(ji,jj+1) - (gdepw_1d(misfdep(ji,jj+1)) & 1130 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 1125 1131 IF (zbathydiff .LE. zrisfdepdiff) THEN 1126 1132 mbathy(ji,jj) = mbathy(ji,jj) + 1 1127 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) 1133 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) & 1134 & + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) 1128 1135 ELSE 1129 1136 misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 1130 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1137 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) & 1138 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1131 1139 END IF 1132 1140 ENDIF … … 1148 1156 DO ji = 1, jpim1 1149 1157 IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) .GT. 1) THEN 1150 zbathydiff =ABS( bathy(ji,jj+1) - (gdepw_1d(mbathy (ji,jj+1)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 1151 zrisfdepdiff=ABS(risfdep(ji,jj ) - (gdepw_1d(misfdep(ji,jj ) ) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) 1158 zbathydiff =ABS( bathy(ji,jj+1) - (gdepw_1d(mbathy (ji,jj+1)+1) & 1159 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 1160 zrisfdepdiff=ABS(risfdep(ji,jj ) - (gdepw_1d(misfdep(ji,jj ) ) & 1161 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) 1152 1162 IF (zbathydiff .LE. zrisfdepdiff) THEN 1153 1163 mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 … … 1177 1187 DO ji = 1, jpim1 1178 1188 IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1179 zbathydiff =ABS( bathy(ji ,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) 1180 zrisfdepdiff=ABS(risfdep(ji+1,jj) - (gdepw_1d(misfdep(ji+1,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 1189 zbathydiff =ABS( bathy(ji ,jj) - (gdepw_1d(mbathy (ji,jj)+1) & 1190 & + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) 1191 zrisfdepdiff=ABS(risfdep(ji+1,jj) - (gdepw_1d(misfdep(ji+1,jj)) & 1192 & - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 1181 1193 IF (zbathydiff .LE. zrisfdepdiff) THEN 1182 1194 mbathy(ji,jj) = mbathy(ji,jj) + 1 … … 1205 1217 DO ji = 1, jpim1 1206 1218 IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1207 zbathydiff =ABS( bathy(ji+1,jj) - (gdepw_1d(mbathy (ji+1,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 1208 zrisfdepdiff=ABS(risfdep(ji ,jj) - (gdepw_1d(misfdep(ji ,jj) ) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) 1219 zbathydiff =ABS( bathy(ji+1,jj) - (gdepw_1d(mbathy (ji+1,jj)+1) & 1220 & + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 1221 zrisfdepdiff=ABS(risfdep(ji ,jj) - (gdepw_1d(misfdep(ji ,jj) ) & 1222 & - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) 1209 1223 IF (zbathydiff .LE. zrisfdepdiff) THEN 1210 1224 mbathy(ji+1,jj) = mbathy (ji+1,jj) + 1 1211 bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 1225 bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) & 1226 & + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 1212 1227 ELSE 1213 1228 misfdep(ji,jj) = misfdep(ji ,jj) - 1 1214 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1229 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) & 1230 & - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1215 1231 END IF 1216 1232 ENDIF … … 1591 1607 DO jj = 1, jpjm1 1592 1608 DO ji = 1, fs_jpim1 ! vector opt. 1593 e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj ,jk) ) - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj ,jk-1) ) 1594 e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji ,jj+1,jk) ) - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji ,jj+1,jk-1) ) 1609 e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj ,jk) ) & 1610 & - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj ,jk-1) ) 1611 e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji ,jj+1,jk) ) & 1612 & - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji ,jj+1,jk-1) ) 1595 1613 END DO 1596 1614 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r4666 r4946 34 34 USE dtatsd ! data temperature and salinity (dta_tsd routine) 35 35 USE dtauvd ! data: U & V current (dta_uvd routine) 36 USE in_out_manager ! I/O manager37 USE iom ! I/O library38 36 USE zpshde ! partial step: hor. derivative (zps_hde routine) 39 37 USE eosbn2 ! equation of state (eos bn2 routine) … … 42 40 USE dynspg_flt ! filtered free surface 43 41 USE sol_oce ! ocean solver variables 42 ! 43 USE in_out_manager ! I/O manager 44 USE iom ! I/O library 44 45 USE lib_mpp ! MPP library 45 46 USE restart ! restart … … 56 57 # include "vectopt_loop_substitute.h90" 57 58 !!---------------------------------------------------------------------- 58 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)59 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 59 60 !! $Id$ 60 61 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 73 74 !!---------------------------------------------------------------------- 74 75 ! 75 IF( nn_timing == 1 ) CALL timing_start('istate_init')76 IF( nn_timing == 1 ) CALL timing_start('istate_init') 76 77 ! 77 78 … … 83 84 IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 84 85 85 rhd (:,:,: ) = 0.e0 86 rhop (:,:,: ) = 0.e0 87 rn2 (:,:,: ) = 0.e0 88 tsa (:,:,:,:) = 0.e0 86 rhd (:,:,: ) = 0._wp 87 rhop (:,:,: ) = 0._wp 88 rn2 (:,:,: ) = 0._wp 89 tsa (:,:,:,:) = 0._wp 90 rab_b(:,:,:,:) = 0._wp 91 rab_n(:,:,:,:) = 0._wp 89 92 90 93 IF( ln_rstart ) THEN ! Restart from a file … … 168 171 ! 169 172 DO jk = 1, jpkm1 170 #if defined key_vectopt_loop171 DO jj = 1, 1 !Vector opt. => forced unrolling172 DO ji = 1, jpij173 #else174 173 DO jj = 1, jpj 175 174 DO ji = 1, jpi 176 #endif177 175 un_b(ji,jj) = un_b(ji,jj) + fse3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 178 176 vn_b(ji,jj) = vn_b(ji,jj) + fse3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) … … 191 189 ! 192 190 ! 193 IF( nn_timing == 1 ) CALL timing_stop('istate_init')191 IF( nn_timing == 1 ) CALL timing_stop('istate_init') 194 192 ! 195 193 END SUBROUTINE istate_init 194 196 195 197 196 SUBROUTINE istate_t_s … … 225 224 END SUBROUTINE istate_t_s 226 225 226 227 227 SUBROUTINE istate_eel 228 228 !!---------------------------------------------------------------------- … … 239 239 USE divcur ! hor. divergence & rel. vorticity (div_cur routine) 240 240 USE iom 241 241 ! 242 242 INTEGER :: inum ! temporary logical unit 243 243 INTEGER :: ji, jj, jk ! dummy loop indices … … 250 250 REAL(wp), DIMENSION(jpiglo,jpjglo) :: zssh ! initial ssh over the global domain 251 251 !!---------------------------------------------------------------------- 252 252 ! 253 253 SELECT CASE ( jp_cfg ) 254 254 ! ! ==================== … … 381 381 INTEGER, PARAMETER :: ntsinit = 0 ! (0/1) (analytical/input data files) T&S initialization 382 382 !!---------------------------------------------------------------------- 383 383 ! 384 384 SELECT CASE ( ntsinit) 385 385 ! 386 386 CASE ( 0 ) ! analytical T/S profil deduced from LEVITUS 387 387 IF(lwp) WRITE(numout,*) 388 388 IF(lwp) WRITE(numout,*) 'istate_gyre : initial analytical T and S profil deduced from LEVITUS ' 389 389 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 390 390 ! 391 391 DO jk = 1, jpk 392 392 DO jj = 1, jpj … … 413 413 END DO 414 414 END DO 415 415 ! 416 416 CASE ( 1 ) ! T/S data fields read in dta_tem.nc/data_sal.nc files 417 417 IF(lwp) WRITE(numout,*) … … 437 437 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:) 438 438 tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) 439 439 ! 440 440 END SELECT 441 441 ! 442 442 IF(lwp) THEN 443 443 WRITE(numout,*) … … 446 446 WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_1d(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) 447 447 ENDIF 448 448 ! 449 449 END SUBROUTINE istate_gyre 450 450 451 451 452 SUBROUTINE istate_uvg … … 463 464 USE divcur ! hor. divergence & rel. vorticity (div_cur routine) 464 465 USE lbclnk ! ocean lateral boundary condition (or mpp link) 465 466 ! 466 467 INTEGER :: ji, jj, jk ! dummy loop indices 467 468 INTEGER :: indic ! ??? … … 573 574 !!===================================================================== 574 575 END MODULE istate 575 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r4924 r4946 47 47 REAL(wp), PUBLIC :: rt0_ice = 273.05_wp !: melting point of ice [Kelvin] 48 48 #endif 49 #if defined key_cice 50 REAL(wp), PUBLIC :: rau0 = 1026._wp !: volumic mass of reference [kg/m3] 51 #else 52 REAL(wp), PUBLIC :: rau0 = 1035._wp !: volumic mass of reference [kg/m3] 53 #endif 49 REAL(wp), PUBLIC :: rau0 !: volumic mass of reference [kg/m3] 54 50 REAL(wp), PUBLIC :: r1_rau0 !: = 1. / rau0 [m3/kg] 55 REAL(wp), PUBLIC :: rauw = 1000._wp !: volumic mass of pure water [m3/kg] 56 REAL(wp), PUBLIC :: rcp = 4.e3_wp !: ocean specific heat [J/kg/K] 57 REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [kg.K/J] 51 REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] 52 REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] 58 53 REAL(wp), PUBLIC :: r1_rau0_rcp !: = 1. / ( rau0 * rcp ) 59 54 … … 69 64 #if defined key_lim3 || defined key_cice 70 65 REAL(wp), PUBLIC :: rhoic = 917._wp !: volumic mass of sea ice [kg/m3] 71 REAL(wp), PUBLIC :: rcdic = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K]72 REAL(wp), PUBLIC :: rcdsn = 0.31_wp !: thermal conductivity of snow [W/m/K]73 REAL(wp), PUBLIC :: cpic = 2067.0_wp !: specific heat for ice [J/kg/K]66 REAL(wp), PUBLIC :: rcdic = 2.034396_wp !: thermal conductivity of fresh ice 67 REAL(wp), PUBLIC :: rcdsn = 0.31_wp !: thermal conductivity of snow 68 REAL(wp), PUBLIC :: cpic = 2067.0_wp !: specific heat for ice 74 69 REAL(wp), PUBLIC :: lsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] 75 70 REAL(wp), PUBLIC :: lfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] 76 REAL(wp), PUBLIC :: tmut = 0.054_wp !: decrease of seawater meltpoint with salinity [degC/ppt]71 REAL(wp), PUBLIC :: tmut = 0.054_wp !: decrease of seawater meltpoint with salinity 77 72 REAL(wp), PUBLIC :: xlsn !: = lfus*rhosn (volumetric latent heat fusion of snow) [J/m3] 78 73 #else … … 163 158 IF(lwp) WRITE(numout,*) ' melting point of ice rt0_ice = ', rt0_ice , ' K' 164 159 165 r1_rau0 = 1._wp / rau0 166 r1_rcp = 1._wp / rcp 167 r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 168 IF(lwp) WRITE(numout,*) 169 IF(lwp) WRITE(numout,*) ' volumic mass of pure water rauw = ', rauw , ' kg/m^3' 170 IF(lwp) WRITE(numout,*) ' volumic mass of reference rau0 = ', rau0 , ' kg/m^3' 171 IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' 172 IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' 173 IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp 174 175 160 IF(lwp) WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90' 161 176 162 #if defined key_lim3 || defined key_cice 177 163 xlsn = lfus * rhosn ! volumetric latent heat fusion of snow [J/m3] -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_cen2.F90
r3294 r4946 15 15 USE oce ! ocean dynamics and tracers 16 16 USE dom_oce ! ocean space and time domain 17 USE trdmod_oce ! ocean variables trends 18 USE trdmod ! ocean dynamics trends 17 USE trd_oce ! trends: ocean variables 18 USE trddyn ! trend manager: dynamics 19 ! 19 20 USE in_out_manager ! I/O manager 20 21 USE lib_mpp ! MPP library 21 22 USE prtctl ! Print control 22 USE wrk_nemo 23 USE timing 23 USE wrk_nemo ! Memory Allocation 24 USE timing ! Timing 24 25 25 26 IMPLICIT NONE … … 103 104 zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 104 105 zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) 105 CALL trd_ mod( zfu_uw, zfv_vw, jpdyn_trd_had, 'DYN', kt )106 CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) 106 107 zfu_t(:,:,:) = ua(:,:,:) 107 108 zfv_t(:,:,:) = va(:,:,:) … … 153 154 zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 154 155 zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 155 CALL trd_ mod( zfu_t, zfv_t, jpdyn_trd_zad, 'DYN', kt )156 CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 156 157 ENDIF 157 158 ! ! Control print -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90
r4153 r4946 16 16 USE oce ! ocean dynamics and tracers 17 17 USE dom_oce ! ocean space and time domain 18 USE trdmod ! ocean dynamics trends 19 USE trdmod_oce ! ocean variables trends 18 USE trd_oce ! trends: ocean variables 19 USE trddyn ! trend manager: dynamics 20 ! 20 21 USE in_out_manager ! I/O manager 21 22 USE prtctl ! Print control 22 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 23 24 USE lib_mpp ! MPP library 24 USE wrk_nemo 25 USE timing 25 USE wrk_nemo ! Memory Allocation 26 USE timing ! Timing 26 27 27 28 IMPLICIT NONE … … 196 197 zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 197 198 zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) 198 CALL trd_ mod( zfu_uw, zfv_vw, jpdyn_trd_had, 'DYN', kt )199 CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) 199 200 zfu_t(:,:,:) = ua(:,:,:) 200 201 zfv_t(:,:,:) = va(:,:,:) … … 245 246 zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 246 247 zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 247 CALL trd_ mod( zfu_t, zfv_t, jpdyn_trd_zad, 'DYN', kt )248 CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 248 249 ENDIF 249 250 ! ! Control print -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90
r4666 r4946 10 10 11 11 !!---------------------------------------------------------------------- 12 !! dyn_bfr : Update the momentum trend with the bottom friction contribution12 !! dyn_bfr : Update the momentum trend with the bottom friction contribution 13 13 !!---------------------------------------------------------------------- 14 USE oce 15 USE dom_oce 16 USE zdf_oce 17 USE zdfbfr 18 USE trd mod ! ocean active dynamics and tracers trends19 USE trd mod_oce ! ocean variables trends20 USE in_out_manager 21 USE prtctl 22 USE timing 23 USE wrk_nemo 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 16 USE zdf_oce ! ocean vertical physics variables 17 USE zdfbfr ! ocean bottom friction variables 18 USE trd_oce ! trends: ocean variables 19 USE trddyn ! trend manager: dynamics 20 USE in_out_manager ! I/O manager 21 USE prtctl ! Print control 22 USE timing ! Timing 23 USE wrk_nemo ! Memory Allocation 24 24 25 25 IMPLICIT NONE 26 26 PRIVATE 27 27 28 PUBLIC dyn_bfr 28 PUBLIC dyn_bfr ! routine called by step.F90 29 29 30 30 !! * Substitutions … … 57 57 IF( nn_timing == 1 ) CALL timing_start('dyn_bfr') 58 58 ! 59 !!gm issue: better to put the logical in step to control the call of zdf_bfr 60 !! ==> change the logical from ln_bfrimp to ln_bfr_exp !! 59 61 IF( .NOT.ln_bfrimp) THEN ! only for explicit bottom friction form 60 62 ! implicit bfr is implemented in dynzdf_imp 61 63 64 !!gm bug : time step is only rdt (not 2 rdt if euler start !) 62 65 zm1_2dt = - 1._wp / ( 2._wp * rdt ) 63 66 … … 69 72 70 73 71 # if defined key_vectopt_loop72 DO jj = 1, 173 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)74 # else75 74 DO jj = 2, jpjm1 76 75 DO ji = 2, jpim1 77 # endif78 76 ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels 79 77 ikbv = mbkv(ji,jj) … … 101 99 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 102 100 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 103 CALL trd_ mod( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_trd_bfr, 'DYN', kt )101 CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt ) 104 102 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 105 103 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r4747 r4946 32 32 USE dom_oce ! ocean space and time domain 33 33 USE phycst ! physical constants 34 USE trdmod ! ocean dynamics trends 35 USE trdmod_oce ! ocean variables trends 34 USE trd_oce ! trends: ocean variables 35 USE trddyn ! trend manager: dynamics 36 ! 36 37 USE in_out_manager ! I/O manager 37 38 USE prtctl ! Print control 38 USE lbclnk ! lateral boundary condition 39 USE lbclnk ! lateral boundary condition 39 40 USE lib_mpp ! MPP library 40 41 USE eosbn2 ! compute density … … 76 77 !! 77 78 !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 78 !! - Save the trend(l_trddyn=T)79 !! - send trends to trd_dyn for futher diagnostics (l_trddyn=T) 79 80 !!---------------------------------------------------------------------- 80 81 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 101 102 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 102 103 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 103 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_hpg, 'DYN', kt )104 CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt ) 104 105 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 105 106 ENDIF … … 177 178 IF( ln_hpg_prj ) ioptio = ioptio + 1 178 179 IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 179 IF( (ln_hpg_zco .OR. ln_hpg_zps .OR. ln_hpg_djc .OR. ln_hpg_prj ) .AND. nn_isf .NE. 0 ) CALL ctl_stop( 'Only hpg_sco has been corrected to work with ice shelf cavity. Comparison in a GYRE simulation with bump in the middle show similar result than hpg_zps' ) 180 IF( (ln_hpg_zco .OR. ln_hpg_zps .OR. ln_hpg_djc .OR. ln_hpg_prj ) .AND. nn_isf .NE. 0 ) & 181 & CALL ctl_stop( 'Only hpg_sco has been corrected to work with ice shelf cavity.' ) 180 182 ! 181 183 END SUBROUTINE dyn_hpg_init … … 318 320 319 321 ! partial steps correction at the last level (use gru & grv computed in zpshde.F90) 320 # if defined key_vectopt_loop321 jj = 1322 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)323 # else324 322 DO jj = 2, jpjm1 325 323 DO ji = 2, jpim1 326 # endif327 324 iku = mbku(ji,jj) 328 325 ikv = mbkv(ji,jj) … … 341 338 va (ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend 342 339 ENDIF 343 # if ! defined key_vectopt_loop 344 END DO 345 # endif 340 END DO 346 341 END DO 347 342 ! … … 617 612 END SUBROUTINE hpg_sco 618 613 614 619 615 SUBROUTINE hpg_djc( kt ) 620 616 !!--------------------------------------------------------------------- … … 854 850 !! 855 851 !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 856 !! - Save the trend (l_trddyn=T)857 !!858 852 !!---------------------------------------------------------------------- 859 853 INTEGER, PARAMETER :: polynomial_type = 1 ! 1: cubic spline, 2: linear … … 907 901 908 902 ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" 909 DO jj = 1, jpj; DO ji = 1, jpi 910 zdept(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) - sshn(ji,jj) * znad 911 END DO ; END DO 912 913 DO jk = 2, jpk; DO jj = 1, jpj; DO ji = 1, jpi 914 zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + fse3w(ji,jj,jk) 915 END DO ; END DO ; END DO 916 917 fsp(:,:,:) = zrhh(:,:,:) 903 DO jj = 1, jpj 904 DO ji = 1, jpi 905 zdept(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) - sshn(ji,jj) * znad 906 END DO 907 END DO 908 909 DO jk = 2, jpk 910 DO jj = 1, jpj 911 DO ji = 1, jpi 912 zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + fse3w(ji,jj,jk) 913 END DO 914 END DO 915 END DO 916 917 fsp(:,:,:) = zrhh (:,:,:) 918 918 xsp(:,:,:) = zdept(:,:,:) 919 919 … … 1116 1116 END SUBROUTINE hpg_prj 1117 1117 1118 1118 1119 SUBROUTINE cspline(fsp, xsp, asp, bsp, csp, dsp, polynomial_type) 1119 1120 !!---------------------------------------------------------------------- … … 1123 1124 !! 1124 1125 !! ** Method : f(x) = asp + bsp*x + csp*x^2 + dsp*x^3 1126 !! 1125 1127 !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation 1126 !!1127 1128 !!---------------------------------------------------------------------- 1128 1129 IMPLICIT NONE … … 1132 1133 INTEGER, INTENT(in) :: polynomial_type ! 1: cubic spline 1133 1134 ! 2: Linear 1134 1135 ! Local Variables 1135 ! 1136 1136 INTEGER :: ji, jj, jk ! dummy loop indices 1137 1137 INTEGER :: jpi, jpj, jpkm1 … … 1223 1223 ENDIF 1224 1224 1225 1226 1225 END SUBROUTINE cspline 1227 1226 … … 1233 1232 !! ** Purpose : 1-d linear interpolation 1234 1233 !! 1235 !! ** Method : 1236 !! interpolation is straight forward 1234 !! ** Method : interpolation is straight forward 1237 1235 !! extrapolation is also permitted (no value limit) 1238 !!1239 1236 !!---------------------------------------------------------------------- 1240 1237 IMPLICIT NONE … … 1253 1250 END FUNCTION interp1 1254 1251 1252 1255 1253 FUNCTION interp2(x, a, b, c, d) RESULT(f) 1256 1254 !!---------------------------------------------------------------------- … … 1316 1314 END FUNCTION integ_spline 1317 1315 1318 1319 1316 !!====================================================================== 1320 1317 END MODULE dynhpg -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynkeg.F90
r3294 r4946 14 14 USE oce ! ocean dynamics and tracers 15 15 USE dom_oce ! ocean space and time domain 16 USE trdmod ! ocean dynamics trends 17 USE trdmod_oce ! ocean variables trends 16 USE trd_oce ! trends: ocean variables 17 USE trddyn ! trend manager: dynamics 18 ! 18 19 USE in_out_manager ! I/O manager 19 20 USE lib_mpp ! MPP library … … 52 53 !! 53 54 !! ** Action : - Update the (ua, va) with the hor. ke gradient trend 54 !! - s ave this trends(l_trddyn=T) for post-processing55 !! - send this trends to trd_dyn (l_trddyn=T) for post-processing 55 56 !!---------------------------------------------------------------------- 56 57 INTEGER, INTENT( in ) :: kt ! ocean time-step index 57 ! !58 ! 58 59 INTEGER :: ji, jj, jk ! dummy loop indices 59 60 REAL(wp) :: zu, zv ! temporary scalars … … 131 132 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 132 133 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 133 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_keg, 'DYN', kt )134 CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 134 135 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 135 136 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf.F90
r4522 r4946 15 15 USE phycst ! physical constants 16 16 USE ldfdyn_oce ! ocean dynamics lateral physics 17 USE ldftra_oce ! ocean tracers lateral physics 17 18 USE ldfslp ! lateral mixing: slopes of mixing orientation 18 19 USE dynldf_bilapg ! lateral mixing (dyn_ldf_bilapg routine) … … 20 21 USE dynldf_iso ! lateral mixing (dyn_ldf_iso routine) 21 22 USE dynldf_lap ! lateral mixing (dyn_ldf_lap routine) 22 USE ldftra_oce, ONLY: ln_traldf_hor ! ocean tracers lateral physics23 USE trd mod ! ocean dynamics and tracer trends24 USE trdmod_oce ! ocean variables trends23 USE trd_oce ! trends: ocean variables 24 USE trddyn ! trend manager: dynamics (trd_dyn routine) 25 ! 25 26 USE prtctl ! Print control 26 27 USE in_out_manager ! I/O manager … … 30 31 USE timing ! Timing 31 32 32 33 33 IMPLICIT NONE 34 34 PRIVATE … … 55 55 !! ** Purpose : compute the lateral ocean dynamics physics. 56 56 !!---------------------------------------------------------------------- 57 !58 57 INTEGER, INTENT(in) :: kt ! ocean time-step index 59 58 ! … … 107 106 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 108 107 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 109 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_ldf, 'DYN', kt )108 CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt ) 110 109 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) 111 110 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilap.F90
r3634 r4946 19 19 USE dom_oce ! ocean space and time domain 20 20 USE ldfdyn_oce ! ocean dynamics: lateral physics 21 ! 21 22 USE in_out_manager ! I/O manager 22 USE trdmod ! ocean dynamics trends23 USE trdmod_oce ! ocean variables trends24 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 25 24 USE wrk_nemo ! Memory Allocation … … 70 69 !! Add this before trend to the general trend (ua,va): 71 70 !! (ua,va) = (ua,va) + (diffu,diffv) 72 !! 'key_trddyn' defined: the two components of the horizontal73 !! diffusion trend are saved.74 71 !! 75 72 !! ** Action : - Update (ua,va) with the before iso-level biharmonic 76 73 !! mixing trend. 77 74 !!---------------------------------------------------------------------- 78 !79 75 INTEGER, INTENT(in) :: kt ! ocean time-step index 80 76 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90
r4488 r4946 19 19 USE dom_oce ! ocean space and time domain 20 20 USE ldfdyn_oce ! ocean dynamics lateral physics 21 USE zdf_oce ! ocean vertical physics 22 USE ldfslp ! iso-neutral slopes available 21 23 USE ldftra_oce, ONLY: ln_traldf_iso 22 USE zdf_oce ! ocean vertical physics 23 USE trdmod ! ocean dynamics trends 24 USE trdmod_oce ! ocean variables trends 25 USE ldfslp ! iso-neutral slopes available 24 ! 26 25 USE in_out_manager ! I/O manager 27 26 USE lib_mpp ! MPP library … … 81 80 !! -3- Add this trend to the general trend (ta,sa): 82 81 !! (ua,va) = (ua,va) + (zwk3,zwk4) 83 !! 'key_trddyn' defined: the trend is saved for diagnostics.84 82 !! 85 83 !! ** Action : - Update (ua,va) arrays with the before geopotential 86 84 !! biharmonic mixing trend. 87 !! - save the trend in (zwk3,zwk4) ('key_trddyn')88 85 !!---------------------------------------------------------------------- 89 86 INTEGER, INTENT( in ) :: kt ! ocean time-step index … … 201 198 !! pu and pv (all the components except 202 199 !! second order vertical derivative term) 203 !! 'key_trddyn' defined: the trend is saved for diagnostics. 204 !!---------------------------------------------------------------------- 205 !! 200 !!---------------------------------------------------------------------- 206 201 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu , pv ! 1st call: before horizontal velocity 207 202 ! ! 2nd call: ahm x these fields -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90
r4488 r4946 22 22 USE ldftra_oce ! ocean tracer lateral physics 23 23 USE zdf_oce ! ocean vertical physics 24 USE trdmod ! ocean dynamics trends25 USE trdmod_oce ! ocean variables trends26 24 USE ldfslp ! iso-neutral slopes 25 ! 27 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 28 27 USE in_out_manager ! I/O manager -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_lap.F90
r3294 r4946 19 19 USE ldfdyn_oce ! ocean dynamics: lateral physics 20 20 USE zdf_oce ! ocean vertical physics 21 ! 21 22 USE in_out_manager ! I/O manager 22 USE trdmod ! ocean dynamics trends23 USE trdmod_oce ! ocean variables trends24 USE ldfslp ! iso-neutral slopes25 23 USE timing ! Timing 26 24 … … 57 55 !! Add this before trend to the general trend (ua,va): 58 56 !! (ua,va) = (ua,va) + (diffu,diffv) 59 !! 'key_trddyn' activated: the two components of the horizontal60 !! diffusion trend are saved.61 57 !! 62 !! ** Action : - Update (ua,va) with the before iso-level harmonic 63 !! mixing trend. 58 !! ** Action : - Update (ua,va) with the iso-level harmonic mixing trend 64 59 !!---------------------------------------------------------------------- 65 60 INTEGER, INTENT( in ) :: kt ! ocean time-step index -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r4666 r4946 18 18 !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL 19 19 !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes 20 !! 3.7 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends 20 21 !!------------------------------------------------------------------------- 21 22 … … 34 35 USE bdydyn ! ocean open boundary conditions 35 36 USE bdyvol ! ocean open boundary condition (bdy_vol routines) 37 USE trd_oce ! trends: ocean variables 38 USE trddyn ! trend manager: dynamics 39 USE trdken ! trend manager: kinetic energy 40 ! 36 41 USE in_out_manager ! I/O manager 42 USE iom ! I/O manager library 37 43 USE lbclnk ! lateral boundary condition (or mpp link) 38 44 USE lib_mpp ! MPP library 39 45 USE wrk_nemo ! Memory Allocation 40 46 USE prtctl ! Print control 41 47 USE timing ! Timing 42 48 #if defined key_agrif 43 49 USE agrif_opa_interp 44 50 #endif 45 USE timing ! Timing46 51 47 52 IMPLICIT NONE … … 79 84 !! at the local domain boundaries through lbc_lnk call, 80 85 !! at the one-way open boundaries (lk_bdy=T), 81 !! at the AGRIF zoom 86 !! at the AGRIF zoom boundaries (lk_agrif=T) 82 87 !! 83 88 !! * Apply the time filter applied and swap of the dynamics … … 99 104 REAL(wp) :: z2dt ! temporary scalar 100 105 #endif 101 REAL(wp) :: zue3a, zue3n, zue3b, zuf, zec ! local scalars102 REAL(wp) :: zve3a, zve3n, zve3b, zvf 103 REAL(wp), POINTER, DIMENSION(:,:) :: zu a, zva104 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3u_f, ze3v_f 106 REAL(wp) :: zue3a, zue3n, zue3b, zuf, zec ! local scalars 107 REAL(wp) :: zve3a, zve3n, zve3b, zvf, z1_2dt ! - - 108 REAL(wp), POINTER, DIMENSION(:,:) :: zue, zve 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3u_f, ze3v_f, zua, zva 105 110 !!---------------------------------------------------------------------- 106 111 ! 107 IF( nn_timing == 1 ) CALL timing_start('dyn_nxt')108 ! 109 CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f)110 IF ( lk_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zua, zva)112 IF( nn_timing == 1 ) CALL timing_start('dyn_nxt') 113 ! 114 CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f, zua, zva ) 115 IF( lk_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zue, zve ) 111 116 ! 112 117 IF( kt == nit000 ) THEN … … 152 157 153 158 # if defined key_dynspg_ts 159 !!gm IF ( lk_dynspg_ts ) THEN .... 154 160 ! Ensure below that barotropic velocities match time splitting estimate 155 161 ! Compute actual transport and replace it with ts estimate at "after" time step 156 zu a(:,:) = 0._wp157 zv a(:,:) = 0._wp158 DO jk = 1, jpkm1159 zu a(:,:) = zua(:,:) + fse3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk)160 zv a(:,:) = zva(:,:) + fse3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)162 zue(:,:) = fse3u_a(:,:,1) * ua(:,:,1) * umask(:,:,1) 163 zve(:,:) = fse3v_a(:,:,1) * va(:,:,1) * vmask(:,:,1) 164 DO jk = 2, jpkm1 165 zue(:,:) = zue(:,:) + fse3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 166 zve(:,:) = zve(:,:) + fse3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) 161 167 END DO 162 168 DO jk = 1, jpkm1 163 ua(:,:,jk) = ( ua(:,:,jk) - zu a(:,:) * hur_a(:,:) + ua_b(:,:) ) * umask(:,:,jk)164 va(:,:,jk) = ( va(:,:,jk) - zv a(:,:) * hvr_a(:,:) + va_b(:,:) ) * vmask(:,:,jk)169 ua(:,:,jk) = ( ua(:,:,jk) - zue(:,:) * hur_a(:,:) + ua_b(:,:) ) * umask(:,:,jk) 170 va(:,:,jk) = ( va(:,:,jk) - zve(:,:) * hvr_a(:,:) + va_b(:,:) ) * vmask(:,:,jk) 165 171 END DO 166 172 … … 175 181 END DO 176 182 ENDIF 183 !!gm ENDIF 177 184 # endif 178 185 … … 195 202 # endif 196 203 #endif 204 205 IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics 206 z1_2dt = 1._wp / (2. * rdt) ! Euler or leap-frog time step 207 IF( neuler == 0 .AND. kt == nit000 ) z1_2dt = 1._wp / rdt 208 ! 209 ! ! Kinetic energy and Conversion 210 IF( ln_KE_trd ) CALL trd_dyn( ua, va, jpdyn_ken, kt ) 211 ! 212 IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends 213 zua(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) * z1_2dt 214 zva(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) * z1_2dt 215 CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter 216 CALL iom_put( "vtrd_tot", zva ) 217 ENDIF 218 ! 219 zua(:,:,:) = un(:,:,:) ! save the now velocity before the asselin filter 220 zva(:,:,:) = vn(:,:,:) ! (caution: there will be a shift by 1 timestep in the 221 ! ! computation of the asselin filter trends) 222 ENDIF 197 223 198 224 ! Time filter and swap of dynamics arrays … … 217 243 DO jj = 1, jpj 218 244 DO ji = 1, jpi 219 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2. e0_wp * un(ji,jj,jk) + ua(ji,jj,jk) )220 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2. e0_wp * vn(ji,jj,jk) + va(ji,jj,jk) )245 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) ) 246 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) ) 221 247 ! 222 248 ub(ji,jj,jk) = zuf ! ub <-- filtered velocity … … 301 327 ! Revert "before" velocities to time split estimate 302 328 ! Doing it here also means that asselin filter contribution is removed 303 zu a(:,:) = 0._wp304 zv a(:,:) = 0._wp305 DO jk = 1, jpkm1306 zu a(:,:) = zua(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk)307 zv a(:,:) = zva(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)329 zue(:,:) = fse3u_b(:,:,1) * ub(:,:,1) * umask(:,:,1) 330 zve(:,:) = fse3v_b(:,:,1) * vb(:,:,1) * vmask(:,:,1) 331 DO jk = 2, jpkm1 332 zue(:,:) = zue(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 333 zve(:,:) = zve(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) 308 334 END DO 309 335 DO jk = 1, jpkm1 310 ub(:,:,jk) = ub(:,:,jk) - (zu a(:,:) * hur(:,:) - un_b(:,:)) * umask(:,:,jk)311 vb(:,:,jk) = vb(:,:,jk) - (zv a(:,:) * hvr(:,:) - vn_b(:,:)) * vmask(:,:,jk)336 ub(:,:,jk) = ub(:,:,jk) - (zue(:,:) * hur(:,:) - un_b(:,:)) * umask(:,:,jk) 337 vb(:,:,jk) = vb(:,:,jk) - (zve(:,:) * hvr(:,:) - vn_b(:,:)) * vmask(:,:,jk) 312 338 END DO 313 339 ENDIF … … 335 361 ! 336 362 DO jk = 1, jpkm1 337 #if defined key_vectopt_loop338 DO jj = 1, 1 !Vector opt. => forced unrolling339 DO ji = 1, jpij340 #else341 363 DO jj = 1, jpj 342 364 DO ji = 1, jpi 343 #endif344 365 un_b(ji,jj) = un_b(ji,jj) + fse3u_a(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 345 366 vn_b(ji,jj) = vn_b(ji,jj) + fse3v_a(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) … … 358 379 ! 359 380 ! 381 382 IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum 383 zua(:,:,:) = ( ub(:,:,:) - zua(:,:,:) ) * z1_2dt 384 zva(:,:,:) = ( vb(:,:,:) - zva(:,:,:) ) * z1_2dt 385 CALL trd_dyn( zua, zva, jpdyn_atf, kt ) 386 ENDIF 387 ! 360 388 IF(ln_ctl) CALL prt_ctl( tab3d_1=un, clinfo1=' nxt - Un: ', mask1=umask, & 361 389 & tab3d_2=vn, clinfo2=' Vn: ' , mask2=vmask ) 362 390 ! 363 CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f)364 IF ( lk_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zua, zva)391 CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f, zua, zva ) 392 IF( lk_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zue, zve ) 365 393 ! 366 394 IF( nn_timing == 1 ) CALL timing_stop('dyn_nxt') … … 370 398 !!========================================================================= 371 399 END MODULE dynnxt 372 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r4724 r4946 26 26 USE sbctide 27 27 USE updtide 28 USE trdmod ! ocean dynamics trends 29 USE trdmod_oce ! ocean variables trends 28 USE trd_oce ! trends: ocean variables 29 USE trddyn ! trend manager: dynamics 30 ! 30 31 USE prtctl ! Print control (prt_ctl routine) 31 32 USE in_out_manager ! I/O manager 32 33 USE lib_mpp ! MPP library 33 USE solver 34 USE wrk_nemo 35 USE timing 34 USE solver ! solver initialization 35 USE wrk_nemo ! Memory Allocation 36 USE timing ! Timing 36 37 37 38 … … 163 164 END DO 164 165 END DO 165 END DO 166 END DO 167 168 !!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ???? 169 166 170 ENDIF 167 171 … … 191 195 CASE( 2 ) 192 196 z2dt = 2. * rdt 193 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt197 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 194 198 ztrdu(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) / z2dt - ztrdu(:,:,:) 195 199 ztrdv(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) / z2dt - ztrdv(:,:,:) 196 200 END SELECT 197 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_spg, 'DYN', kt )201 CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt ) 198 202 ! 199 203 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r4328 r4946 19 19 USE sbc_oce ! surface boundary condition: ocean 20 20 USE phycst ! physical constants 21 ! 21 22 USE in_out_manager ! I/O manager 22 23 USE lib_mpp ! distributed memory computing library -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r4328 r4946 13 13 !! - ! 2006-08 (J.Chanut, A.Sellar) Calls to BDY routines. 14 14 !! 3.2 ! 2009-03 (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module 15 !! 3.7 ! 2014-04 (F. Roquet, G. Madec) add some trends diag 15 16 !!---------------------------------------------------------------------- 16 17 #if defined key_dynspg_flt || defined key_esopa … … 36 37 USE bdyvol ! ocean open boundary condition (bdy_vol routine) 37 38 USE cla ! cross land advection 39 USE trd_oce ! trends: ocean variables 40 USE trddyn ! trend manager: dynamics 41 ! 38 42 USE in_out_manager ! I/O manager 39 43 USE lib_mpp ! distributed memory computing library … … 43 47 USE iom 44 48 USE lib_fortran 49 USE timing ! Timing 45 50 #if defined key_agrif 46 51 USE agrif_opa_interp 47 52 #endif 48 USE timing ! Timing49 53 50 54 IMPLICIT NONE … … 99 103 !! ** Action : - Update (ua,va) with the surf. pressure gradient trend 100 104 !! 101 !! References : Roullet and Madec 1999, JGR.105 !! References : Roullet and Madec, JGR, 2000. 102 106 !!--------------------------------------------------------------------- 103 107 INTEGER, INTENT(in ) :: kt ! ocean time-step index 104 108 INTEGER, INTENT( out) :: kindic ! solver convergence flag (<0 if not converge) 105 ! !109 ! 106 110 INTEGER :: ji, jj, jk ! dummy loop indices 107 111 REAL(wp) :: z2dt, z2dtg, zgcb, zbtd, ztdgu, ztdgv ! local scalars 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdu, ztrdv 113 REAL(wp), POINTER, DIMENSION(:,:) :: zpw 108 114 !!---------------------------------------------------------------------- 109 115 ! 110 116 IF( nn_timing == 1 ) CALL timing_start('dyn_spg_flt') 111 !112 117 ! 113 118 IF( kt == nit000 ) THEN … … 179 184 END DO 180 185 ! 186 IF( l_trddyn ) THEN ! temporary save of spg trends 187 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv ) 188 DO jk = 1, jpkm1 ! unweighted time stepping 189 DO jj = 2, jpjm1 190 DO ji = fs_2, fs_jpim1 ! vector opt. 191 ztrdu(ji,jj,jk) = spgu(ji,jj) * umask(ji,jj,jk) 192 ztrdv(ji,jj,jk) = spgv(ji,jj) * vmask(ji,jj,jk) 193 END DO 194 END DO 195 END DO 196 CALL trd_dyn( ztrdu, ztrdv, jpdyn_spgexp, kt ) 197 ENDIF 198 ! 181 199 ENDIF 182 200 … … 194 212 DO jj = 2, jpjm1 195 213 DO ji = fs_2, fs_jpim1 ! vector opt. 196 spgu(ji,jj) = 0._wp 197 spgv(ji,jj) = 0._wp 198 END DO 199 END DO 200 201 ! vertical sum 202 !CDIR NOLOOPCHG 203 IF( lk_vopt_loop ) THEN ! vector opt., forced unroll 204 DO jk = 1, jpkm1 205 DO ji = 1, jpij 206 spgu(ji,1) = spgu(ji,1) + fse3u_a(ji,1,jk) * ua(ji,1,jk) 207 spgv(ji,1) = spgv(ji,1) + fse3v_a(ji,1,jk) * va(ji,1,jk) 208 END DO 209 END DO 210 ELSE ! No vector opt. 211 DO jk = 1, jpkm1 212 DO jj = 2, jpjm1 213 DO ji = 2, jpim1 214 spgu(ji,jj) = spgu(ji,jj) + fse3u_a(ji,jj,jk) * ua(ji,jj,jk) 215 spgv(ji,jj) = spgv(ji,jj) + fse3v_a(ji,jj,jk) * va(ji,jj,jk) 216 END DO 217 END DO 218 END DO 219 ENDIF 220 221 ! transport: multiplied by the horizontal scale factor 222 DO jj = 2, jpjm1 214 spgu(ji,jj) = fse3u_a(ji,jj,1) * ua(ji,jj,1) 215 spgv(ji,jj) = fse3v_a(ji,jj,1) * va(ji,jj,1) 216 END DO 217 END DO 218 DO jk = 2, jpkm1 ! vertical sum 219 DO jj = 2, jpjm1 220 DO ji = fs_2, fs_jpim1 ! vector opt. 221 spgu(ji,jj) = spgu(ji,jj) + fse3u_a(ji,jj,jk) * ua(ji,jj,jk) 222 spgv(ji,jj) = spgv(ji,jj) + fse3v_a(ji,jj,jk) * va(ji,jj,jk) 223 END DO 224 END DO 225 END DO 226 227 DO jj = 2, jpjm1 ! transport: multiplied by the horizontal scale factor 223 228 DO ji = fs_2, fs_jpim1 ! vector opt. 224 229 spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj) … … 322 327 ENDIF 323 328 #endif 329 330 IF( l_trddyn ) THEN 331 ztrdu(:,:,:) = ua(:,:,:) ! save the after velocity before the filtered SPG 332 ztrdv(:,:,:) = va(:,:,:) 333 ! 334 CALL wrk_alloc( jpi, jpj, zpw ) 335 ! 336 zpw(:,:) = - z2dt * gcx(:,:) 337 CALL iom_put( "ssh_flt" , zpw ) ! output equivalent ssh modification due to implicit filter 338 ! 339 ! ! save surface pressure flux: -pw at z=0 340 zpw(:,:) = - rau0 * grav * sshn(:,:) * wn(:,:,1) * tmask(:,:,1) 341 CALL iom_put( "pw0_exp" , zpw ) 342 zpw(:,:) = wn(:,:,1) 343 CALL iom_put( "w0" , zpw ) 344 zpw(:,:) = rau0 * z2dtg * gcx(:,:) * wn(:,:,1) * tmask(:,:,1) 345 CALL iom_put( "pw0_flt" , zpw ) 346 ! 347 CALL wrk_dealloc( jpi, jpj, zpw ) 348 ! 349 ENDIF 350 324 351 ! Add the trends multiplied by z2dt to the after velocity 325 352 ! ------------------------------------------------------- … … 336 363 END DO 337 364 338 ! write filtered free surface arrays in restart file 339 ! -------------------------------------------------- 340 IF( lrst_oce ) CALL flt_rst( kt, 'WRITE' ) 341 ! 342 ! 343 IF( nn_timing == 1 ) CALL timing_stop('dyn_spg_flt') 365 IF( l_trddyn ) THEN ! save the explicit SPG trends for further diagnostics 366 ztrdu(:,:,:) = ( ua(:,:,:) - ztrdu(:,:,:) ) / z2dt 367 ztrdv(:,:,:) = ( va(:,:,:) - ztrdv(:,:,:) ) / z2dt 368 CALL trd_dyn( ztrdu, ztrdv, jpdyn_spgflt, kt ) 369 ! 370 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) 371 ENDIF 372 373 IF( lrst_oce ) CALL flt_rst( kt, 'WRITE' ) ! write filtered free surface arrays in restart file 374 ! 375 IF( nn_timing == 1 ) CALL timing_stop('dyn_spg_flt') 344 376 ! 345 377 END SUBROUTINE dyn_spg_flt … … 352 384 !! ** Purpose : Read or write filtered free surface arrays in restart file 353 385 !!---------------------------------------------------------------------- 354 INTEGER , INTENT(in) :: kt 355 CHARACTER(len=*), INTENT(in) :: cdrw 386 INTEGER , INTENT(in) :: kt ! ocean time-step 387 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 356 388 !!---------------------------------------------------------------------- 357 389 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r4624 r4946 15 15 !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme 16 16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity 17 18 !!---------------------------------------------------------------------- 18 19 … … 29 30 USE dommsk ! ocean mask 30 31 USE dynadv ! momentum advection (use ln_dynadv_vec value) 31 USE trd mod ! ocean dynamics trends32 USE trd mod_oce ! ocean variables trends32 USE trd_oce ! trends: ocean variables 33 USE trddyn ! trend manager: dynamics 33 34 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 34 35 USE prtctl ! Print control … … 73 74 !! ** Action : - Update (ua,va) with the now vorticity term trend 74 75 !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative 75 !! and planetary vorticity trends) ('key_trddyn') 76 !! and planetary vorticity trends) and send them to trd_dyn 77 !! for futher diagnostics (l_trddyn=T) 76 78 !!---------------------------------------------------------------------- 77 79 INTEGER, INTENT( in ) :: kt ! ocean time-step index … … 108 110 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 109 111 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 110 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_rvo, 'DYN', kt )112 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 111 113 ztrdu(:,:,:) = ua(:,:,:) 112 114 ztrdv(:,:,:) = va(:,:,:) … … 114 116 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 115 117 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 116 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_pvo, 'DYN', kt ) 117 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_dat, 'DYN', kt ) 118 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 118 119 ELSE 119 120 CALL vor_ene( kt, ntot, ua, va ) ! total vorticity … … 127 128 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 128 129 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 129 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_rvo, 'DYN', kt )130 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 130 131 ztrdu(:,:,:) = ua(:,:,:) 131 132 ztrdv(:,:,:) = va(:,:,:) … … 133 134 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 134 135 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 135 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_pvo, 'DYN', kt ) 136 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_dat, 'DYN', kt ) 136 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 137 137 ELSE 138 138 CALL vor_ens( kt, ntot, ua, va ) ! total vorticity … … 146 146 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 147 147 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 148 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_rvo, 'DYN', kt )148 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 149 149 ztrdu(:,:,:) = ua(:,:,:) 150 150 ztrdv(:,:,:) = va(:,:,:) … … 152 152 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 153 153 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 154 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_pvo, 'DYN', kt ) 155 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_dat, 'DYN', kt ) 154 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 156 155 ELSE 157 156 CALL vor_mix( kt ) ! total vorticity (mix=ens-ene) … … 165 164 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 166 165 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 167 CALL trd_ mod( ztrdu, ztrdv, jpdyn_trd_rvo, 'DYN', kt )166 CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 168 167 ztrdu(:,:,:) = ua(:,:,:) 169 168 ztrdv(:,:,:) = va(:,:,:) … … 171 170 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 172 171 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 173 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_pvo, 'DYN', kt ) 174 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_dat, 'DYN', kt ) 172 CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 175 173 ELSE 176 174 CALL vor_een( kt, ntot, ua, va ) ! total vorticity … … 211 209 !! 212 210 !! ** Action : - Update (ua,va) with the now vorticity term trend 213 !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative214 !! and planetary vorticity trends) ('key_trddyn')215 211 !! 216 212 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. … … 328 324 !! 329 325 !! ** Action : - Update (ua,va) arrays with the now vorticity term trend 330 !! - Save the trends in (ztrdu,ztrdv) in 2 parts (relative331 !! and planetary vorticity trends) ('key_trddyn')332 326 !! 333 327 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. … … 444 438 !! 445 439 !! ** Action : - Update (ua,va) arrays with the now vorticity term trend 446 !! - Save the trends in (ztrdu,ztrdv) in 2 parts (relative447 !! and planetary vorticity trends) ('key_trddyn')448 440 !! 449 441 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. … … 557 549 !! 558 550 !! ** Action : - Update (ua,va) with the now vorticity term trend 559 !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative560 !! and planetary vorticity trends) ('key_trddyn')561 551 !! 562 552 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 … … 601 591 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'dyn:vor_een : unable to allocate arrays' ) 602 592 ENDIF 603 ze3f(:,:,:) = 0. d0593 ze3f(:,:,:) = 0._wp 604 594 #endif 605 595 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90
r4934 r4946 16 16 USE dom_oce ! ocean space and time domain 17 17 USE sbc_oce ! surface boundary condition: ocean 18 USE trdmod_oce ! ocean variables trends 19 USE trdmod ! ocean dynamics trends 18 USE trd_oce ! trends: ocean variables 19 USE trddyn ! trend manager: dynamics 20 ! 20 21 USE in_out_manager ! I/O manager 21 USE lib_mpp 22 USE lib_mpp ! MPP library 22 23 USE prtctl ! Print control 23 USE wrk_nemo 24 USE timing 24 USE wrk_nemo ! Memory Allocation 25 USE timing ! Timing 25 26 26 27 IMPLICIT NONE … … 54 55 !! 55 56 !! ** Action : - Update (ua,va) with the vert. momentum adv. trends 56 !! - S ave the trends in (ztrdu,ztrdv) ('key_trddyn')57 !! - Send the trends to trddyn for diagnostics (l_trddyn=T) 57 58 !!---------------------------------------------------------------------- 58 59 INTEGER, INTENT(in) :: kt ! ocean time-step inedx … … 119 120 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 120 121 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 121 CALL trd_ mod(ztrdu, ztrdv, jpdyn_trd_zad, 'DYN', kt)122 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) 122 123 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) 123 124 ENDIF … … 261 262 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 262 263 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 263 CALL trd_ mod(ztrdu, ztrdv, jpdyn_trd_zad, 'DYN', kt)264 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) 264 265 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) 265 266 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf.F90
r3294 r4946 20 20 21 21 USE ldfdyn_oce ! ocean dynamics: lateral physics 22 USE trd mod ! ocean active dynamics and tracers trends23 USE trd mod_oce ! ocean variables trends22 USE trd_oce ! trends: ocean variables 23 USE trddyn ! trend manager: dynamics 24 24 USE in_out_manager ! I/O manager 25 25 USE lib_mpp ! MPP library … … 91 91 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 92 92 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 93 CALL trd_mod( ztrdu, ztrdv, jpdyn_trd_zdf, 'DYN', kt ) 94 ! 93 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) 95 94 CALL wrk_dealloc( jpi, jpj, jpk, ztrdu, ztrdv ) 96 95 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90
r4812 r4946 70 70 REAL(wp) :: z1_p2dt, zcoef, zzwi, zzws, zrhs ! local scalars 71 71 REAL(wp) :: ze3ua, ze3va 72 !!----------------------------------------------------------------------73 74 72 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwd, zws 75 73 !!---------------------------------------------------------------------- … … 101 99 102 100 IF( ln_bfrimp ) THEN 103 # if defined key_vectopt_loop104 DO jj = 1, 1105 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)106 # else107 101 DO jj = 2, jpjm1 108 102 DO ji = 2, jpim1 109 # endif110 103 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 111 104 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) … … 142 135 ua(:,:,jk) = (ua(:,:,jk) - ua_b(:,:)) * umask(:,:,jk) 143 136 va(:,:,jk) = (va(:,:,jk) - va_b(:,:)) * vmask(:,:,jk) 144 END DO137 END DO 145 138 ! Add bottom/top stress due to barotropic component only: 146 139 DO jj = 2, jpjm1 … … 220 213 & / ( ze3ua * rau0 ) 221 214 #else 222 ua(ji,jj,miku(ji,jj)) = ub(ji,jj,miku(ji,jj)) + p2dt *(ua(ji,jj,miku(ji,jj)) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 223 & / ( fse3u(ji,jj,miku(ji,jj)) * rau0 ) ) 215 ua(ji,jj,miku(ji,jj)) = ub(ji,jj,miku(ji,jj)) & 216 & + p2dt *(ua(ji,jj,miku(ji,jj)) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 217 & / ( fse3u(ji,jj,miku(ji,jj)) * rau0 ) ) 224 218 #endif 225 219 DO jk = miku(ji,jj)+1, jpkm1 … … 311 305 & / ( ze3va * rau0 ) 312 306 #else 313 va(ji,jj,mikv(ji,jj)) = vb(ji,jj,mikv(ji,jj)) + p2dt *(va(ji,jj,mikv(ji,jj)) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 307 va(ji,jj,mikv(ji,jj)) = vb(ji,jj,mikv(ji,jj)) & 308 & + p2dt *(va(ji,jj,mikv(ji,jj)) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 314 309 & / ( fse3v(ji,jj,mikv(ji,jj)) * rau0 ) ) 315 310 #endif … … 348 343 !! restore bottom layer avmu(v) 349 344 IF( ln_bfrimp ) THEN 350 # if defined key_vectopt_loop351 DO jj = 1, 1352 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)353 # else354 345 DO jj = 2, jpjm1 355 346 DO ji = 2, jpim1 356 # endif357 347 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 358 348 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90
r4624 r4946 111 111 INTEGER :: numstp = -1 !: logical unit for time step 112 112 INTEGER :: numtime = -1 !: logical unit for timing 113 INTEGER :: numout = 6 !: logical unit for output print 113 INTEGER :: numout = 6 !: logical unit for output print; Set to stdout to ensure any early 114 ! output can be collected; do not change 114 115 INTEGER :: numnam_ref = -1 !: logical unit for reference namelist 115 116 INTEGER :: numnam_cfg = -1 !: logical unit for configuration specific namelist 116 INTEGER :: numond = 7!: logical unit for Output Namelist Dynamics117 INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics 117 118 INTEGER :: numnam_ice_ref = -1 !: logical unit for ice reference namelist 118 119 INTEGER :: numnam_ice_cfg = -1 !: logical unit for ice reference namelist 119 INTEGER :: numoni = 8!: logical unit for Output Namelist Ice120 INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice 120 121 INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) 121 122 INTEGER :: numsol = -1 !: logical unit for solver statistics -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90
r4924 r4946 22 22 USE iom ! I/O module 23 23 USE eosbn2 ! equation of state (eos bn2 routine) 24 USE trdm ld_oce ! ocean active mixed layer tracers trends variables24 USE trdmxl_oce ! ocean active mixed layer tracers trends variables 25 25 USE divcur ! hor. divergence and curl (div & cur routines) 26 26 USE sbc_ice, ONLY : lk_lim3 … … 140 140 #endif 141 141 IF( lk_lim3 ) THEN 142 CALL iom_rstput( kt, nitrst, numrow, 'iatte' , iatte ) !clem modif 143 CALL iom_rstput( kt, nitrst, numrow, 'oatte' , oatte ) !clem modif 142 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev' , fraqsr_1lev ) !clem modif 144 143 ENDIF 145 144 IF( kt == nitrst ) THEN 146 145 CALL iom_close( numrow ) ! close the restart file (only at last time step) 147 IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. 146 !!gm IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. 147 !!gm not sure what to do here ===>>> ask to Sebastian 148 lrst_oce = .FALSE. 148 149 ENDIF 149 150 ! 150 151 END SUBROUTINE rst_write 152 151 153 152 154 SUBROUTINE rst_read_open … … 162 164 LOGICAL :: llok 163 165 !!---------------------------------------------------------------------- 164 165 IF( numror .LE.0 ) THEN166 ! 167 IF( numror <= 0 ) THEN 166 168 IF(lwp) THEN ! Contol prints 167 169 WRITE(numout,*) … … 269 271 ! 270 272 IF( lk_lim3 ) THEN 271 CALL iom_get( numror, jpdom_autoglo, 'iatte' , iatte ) ! clem modif 272 CALL iom_get( numror, jpdom_autoglo, 'oatte' , oatte ) ! clem modif 273 CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev ) 273 274 ENDIF 274 275 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90
r4726 r4946 84 84 IF( ln_traldf_grif ) THEN 85 85 DO jk = 1, jpk 86 # if defined key_vectopt_loop87 !CDIR NOVERRCHK88 DO ji = 1, jpij ! vector opt.89 ! Take the max of N^2 and zero then take the vertical sum90 ! of the square root of the resulting N^2 ( required to compute91 ! internal Rossby radius Ro = .5 * sum_jpk(N) / f92 zn2 = MAX( rn2b(ji,1,jk), 0._wp )93 zn(ji,1) = zn(ji,1) + SQRT( zn2 ) * fse3w(ji,1,jk)94 ! Compute elements required for the inverse time scale of baroclinic95 ! eddies using the isopycnal slopes calculated in ldfslp.F :96 ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w))97 ze3w = fse3w(ji,1,jk) * tmask(ji,1,jk)98 zah(ji,1) = zah(ji,1) + zn2 * wslp2(ji,1,jk) * ze3w99 zhw(ji,1) = zhw(ji,1) + ze3w100 END DO101 # else102 86 DO jj = 2, jpjm1 103 !CDIR NOVERRCHK104 87 DO ji = 2, jpim1 105 88 ! Take the max of N^2 and zero then take the vertical sum … … 116 99 END DO 117 100 END DO 118 # endif119 101 END DO 120 102 ELSE 121 103 DO jk = 1, jpk 122 # if defined key_vectopt_loop123 !CDIR NOVERRCHK124 DO ji = 1, jpij ! vector opt.125 ! Take the max of N^2 and zero then take the vertical sum126 ! of the square root of the resulting N^2 ( required to compute127 ! internal Rossby radius Ro = .5 * sum_jpk(N) / f128 zn2 = MAX( rn2b(ji,1,jk), 0._wp )129 zn(ji,1) = zn(ji,1) + SQRT( zn2 ) * fse3w(ji,1,jk)130 ! Compute elements required for the inverse time scale of baroclinic131 ! eddies using the isopycnal slopes calculated in ldfslp.F :132 ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w))133 ze3w = fse3w(ji,1,jk) * tmask(ji,1,jk)134 zah(ji,1) = zah(ji,1) + zn2 * ( wslpi(ji,1,jk) * wslpi(ji,1,jk) &135 & + wslpj(ji,1,jk) * wslpj(ji,1,jk) ) * ze3w136 zhw(ji,1) = zhw(ji,1) + ze3w137 END DO138 # else139 104 DO jj = 2, jpjm1 140 !CDIR NOVERRCHK141 105 DO ji = 2, jpim1 142 106 ! Take the max of N^2 and zero then take the vertical sum … … 154 118 END DO 155 119 END DO 156 # endif157 120 END DO 158 121 END IF 159 122 160 123 DO jj = 2, jpjm1 161 !CDIR NOVERRCHK162 124 DO ji = fs_2, fs_jpim1 ! vector opt. 163 125 zfw = MAX( ABS( 2. * omega * SIN( rad * gphit(ji,jj) ) ) , 1.e-10 ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r4812 r4946 28 28 USE zdfmxl ! mixed layer depth 29 29 USE eosbn2 ! equation of states 30 ! 31 USE in_out_manager ! I/O manager 30 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 USE in_out_manager ! I/O manager32 33 USE prtctl ! Print control 33 34 USE wrk_nemo ! work arrays … … 139 140 END DO 140 141 IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level 141 # if defined key_vectopt_loop142 DO jj = 1, 1143 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling)144 # else145 142 DO jj = 1, jpjm1 146 143 DO ji = 1, jpim1 147 # endif148 144 ! IF should be useless check zpshde (PM) 149 145 IF ( mbku(ji,jj) > 1 ) zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) … … 304 300 zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) ! zfk=1 in the ML otherwise zfk=0 305 301 zck = ( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj), 10._wp ) 306 zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 307 zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 302 zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) & 303 & + zck * wslpiml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 304 zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) & 305 & + zck * wslpjml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 308 306 309 307 !!gm modif to suppress omlmask.... (as in Griffies operator) … … 415 413 uslp(ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept_b(ji+1,jj,jk) - fsdept_b(ji ,jj ,jk) ) * umask(ji,jj,jk) 416 414 vslp(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk) 417 wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5 418 wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5 415 wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) & 416 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5 417 wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) & 418 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5 419 419 END DO 420 420 END DO … … 469 469 REAL(wp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim 470 470 REAL(wp) :: zdzrho_raw 471 REAL(wp) :: zbeta0472 471 REAL(wp), POINTER, DIMENSION(:,:) :: z1_mlbw 473 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbet474 472 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 475 473 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb ! for Griffies operator only … … 479 477 ! 480 478 CALL wrk_alloc( jpi,jpj, z1_mlbw ) 481 CALL wrk_alloc( jpi,jpj,jpk, zalbet )482 479 CALL wrk_alloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 483 480 CALL wrk_alloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) … … 486 483 ! Some preliminary calculation ! 487 484 !--------------------------------! 488 !489 CALL eos_alpbet( tsb, zalbet, zbeta0 ) !== before local thermal/haline expension ratio at T-points ==!490 485 ! 491 486 DO jl = 0, 1 !== unmasked before density i- j-, k-gradients ==! … … 499 494 zdjt = ( tsb(ji,jj+1,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) ! j-gradient of T & S at v-point 500 495 zdjs = ( tsb(ji,jj+1,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 501 zdxrho_raw = ( - zalbet(ji+ip,jj ,jk) * zdit + zbeta0*zdis ) / e1u(ji,jj)502 zdyrho_raw = ( - zalbet(ji ,jj+jp,jk) * zdjt + zbeta0*zdjs ) / e2v(ji,jj)503 zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( 496 zdxrho_raw = ( - rab_b(ji+ip,jj ,jk,jp_tem) * zdit + rab_b(ji+ip,jj ,jk,jp_sal) * zdis ) / e1u(ji,jj) 497 zdyrho_raw = ( - rab_b(ji ,jj+jp,jk,jp_tem) * zdjt + rab_b(ji ,jj+jp,jk,jp_sal) * zdjs ) / e2v(ji,jj) 498 zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign 504 499 zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) 505 500 END DO … … 507 502 END DO 508 503 ! 509 IF( ln_zps.and.l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom 510 # if defined key_vectopt_loop 511 DO jj = 1, 1 512 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 513 # else 504 IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom 514 505 DO jj = 1, jpjm1 515 506 DO ji = 1, jpim1 516 # endif517 507 iku = mbku(ji,jj) ; ikv = mbkv(ji,jj) ! last ocean level (u- & v-points) 518 508 zdit = gtsu(ji,jj,jp_tem) ; zdjt = gtsv(ji,jj,jp_tem) ! i- & j-gradient of Temperature 519 509 zdis = gtsu(ji,jj,jp_sal) ; zdjs = gtsv(ji,jj,jp_sal) ! i- & j-gradient of Salinity 520 zdxrho_raw = ( - zalbet(ji+ip,jj ,iku) * zdit + zbeta0*zdis ) / e1u(ji,jj)521 zdyrho_raw = ( - zalbet(ji ,jj+jp,ikv) * zdjt + zbeta0*zdjs ) / e2v(ji,jj)510 zdxrho_raw = ( - rab_b(ji+ip,jj ,iku,jp_tem) * zdit + rab_b(ji+ip,jj ,iku,jp_sal) * zdis ) / e1u(ji,jj) 511 zdyrho_raw = ( - rab_b(ji ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji ,jj+jp,ikv,jp_sal) * zdjs ) / e2v(ji,jj) 522 512 zdxrho(ji+ip,jj ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign 523 513 zdyrho(ji ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) … … 539 529 zdks = 0._wp 540 530 ENDIF 541 zdzrho_raw = ( - zalbet(ji ,jj ,jk) * zdkt + zbeta0*zdks ) / fse3w(ji,jj,jk+kp)542 zdzrho(ji ,jj ,jk, kp) = - MIN( - repsln,zdzrho_raw ) ! force zdzrho >= repsln531 zdzrho_raw = ( - rab_b(ji,jj,jk,jp_tem) * zdkt + rab_b(ji,jj,jk,jp_sal) * zdks ) / fse3w(ji,jj,jk+kp) 532 zdzrho(ji,jj,jk,kp) = - MIN( - repsln, zdzrho_raw ) ! force zdzrho >= repsln 543 533 END DO 544 534 END DO … … 684 674 ! 685 675 CALL wrk_dealloc( jpi,jpj, z1_mlbw ) 686 CALL wrk_dealloc( jpi,jpj,jpk, zalbet )687 676 CALL wrk_dealloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 ) 688 677 CALL wrk_dealloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 ) … … 735 724 ! !== surface mixed layer mask ! 736 725 DO jk = 1, jpk ! =1 inside the mixed layer, =0 otherwise 737 # if defined key_vectopt_loop738 DO jj = 1, 1739 DO ji = 1, jpij ! vector opt. (forced unrolling)740 # else741 726 DO jj = 1, jpj 742 727 DO ji = 1, jpi 743 # endif744 728 ik = nmln(ji,jj) - 1 745 729 IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN ; omlmask(ji,jj,jk) = 1._wp … … 761 745 !----------------------------------------------------------------------- 762 746 ! 763 # if defined key_vectopt_loop764 DO jj = 1, 1765 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)766 # else767 747 DO jj = 2, jpjm1 768 748 DO ji = 2, jpim1 769 # endif770 749 ! !== Slope at u- & v-points just below the Mixed Layer ==! 771 750 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90
r4924 r4946 2 2 !!====================================================================== 3 3 !! *** MODULE cpl_oasis *** 4 !! Coupled O/A : coupled ocean-atmosphere case using OASIS3 V. prism_2_4 5 !! special case: NEMO OPA/LIM coupled to ECHAM5 4 !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT 6 5 !!===================================================================== 7 6 !! History : … … 15 14 !! 3.4 ! 11-11 (C. Harris) Changes to allow mutiple category fields 16 15 !!---------------------------------------------------------------------- 16 !!---------------------------------------------------------------------- 17 !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3 18 !!---------------------------------------------------------------------- 19 !! cpl_init : initialization of coupled mode communication 20 !! cpl_define : definition of grid and fields 21 !! cpl_snd : snd out fields in coupled mode 22 !! cpl_rcv : receive fields in coupled mode 23 !! cpl_finalize : finalize the coupled mode communication 24 !!---------------------------------------------------------------------- 17 25 #if defined key_oasis3 18 !!---------------------------------------------------------------------- 19 !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3 20 !!---------------------------------------------------------------------- 21 !! cpl_prism_init : initialization of coupled mode communication 22 !! cpl_prism_define : definition of grid and fields 23 !! cpl_prism_snd : snd out fields in coupled mode 24 !! cpl_prism_rcv : receive fields in coupled mode 25 !! cpl_prism_finalize : finalize the coupled mode communication 26 !!---------------------------------------------------------------------- 27 USE mod_prism_proto ! OASIS3 prism module 28 USE mod_prism_def_partition_proto! OASIS3 prism module for partitioning 29 USE mod_prism_put_proto ! OASIS3 prism module for snding 30 USE mod_prism_get_proto ! OASIS3 prism module for receiving 31 USE mod_comprism_proto ! OASIS3 prism module to get coupling frequency 26 USE mod_oasis ! OASIS3-MCT module 27 #endif 32 28 USE par_oce ! ocean parameters 33 29 USE dom_oce ! ocean space and time domain … … 38 34 PRIVATE 39 35 40 PUBLIC cpl_prism_init 41 PUBLIC cpl_prism_define 42 PUBLIC cpl_prism_snd 43 PUBLIC cpl_prism_rcv 44 PUBLIC cpl_prism_freq 45 PUBLIC cpl_prism_finalize 46 47 LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE. !: coupled flag 36 PUBLIC cpl_init 37 PUBLIC cpl_define 38 PUBLIC cpl_snd 39 PUBLIC cpl_rcv 40 PUBLIC cpl_freq 41 PUBLIC cpl_finalize 42 48 43 INTEGER, PUBLIC :: OASIS_Rcv = 1 !: return code if received field 49 44 INTEGER, PUBLIC :: OASIS_idle = 0 !: return code if nothing done by oasis 50 INTEGER :: ncomp_id ! id returned by prism_init_comp45 INTEGER :: ncomp_id ! id returned by oasis_init_comp 51 46 INTEGER :: nerror ! return error code 52 53 INTEGER, PARAMETER :: nmaxfld=40 ! Maximum number of coupling fields 47 #if ! defined key_oasis3 48 ! OASIS Variables not used. defined only for compilation purpose 49 INTEGER :: OASIS_Out = -1 50 INTEGER :: OASIS_REAL = -1 51 INTEGER :: OASIS_Ok = -1 52 INTEGER :: OASIS_In = -1 53 INTEGER :: OASIS_Sent = -1 54 INTEGER :: OASIS_SentOut = -1 55 INTEGER :: OASIS_ToRest = -1 56 INTEGER :: OASIS_ToRestOut = -1 57 INTEGER :: OASIS_Recvd = -1 58 INTEGER :: OASIS_RecvOut = -1 59 INTEGER :: OASIS_FromRest = -1 60 INTEGER :: OASIS_FromRestOut = -1 61 #endif 62 63 INTEGER, PUBLIC, PARAMETER :: nmaxfld=40 ! Maximum number of coupling fields 64 INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields 65 INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields 54 66 55 67 TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information … … 58 70 CHARACTER(len = 1) :: clgrid ! Grid type 59 71 REAL(wp) :: nsgn ! Control of the sign change 60 INTEGER, DIMENSION( 9) :: nid ! Id of the field (no more than 9 categories)72 INTEGER, DIMENSION(nmaxcat,nmaxcpl) :: nid ! Id of the field (no more than 9 categories and 9 extrena models) 61 73 INTEGER :: nct ! Number of categories in field 74 INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received 62 75 END TYPE FLD_CPL 63 76 … … 73 86 CONTAINS 74 87 75 SUBROUTINE cpl_ prism_init( kl_comm )88 SUBROUTINE cpl_init( kl_comm ) 76 89 !!------------------------------------------------------------------- 77 !! *** ROUTINE cpl_ prism_init ***90 !! *** ROUTINE cpl_init *** 78 91 !! 79 92 !! ** Purpose : Initialize coupled mode communication for ocean … … 89 102 90 103 !------------------------------------------------------------------ 91 ! 1st Initialize the PRISMsystem for the application104 ! 1st Initialize the OASIS system for the application 92 105 !------------------------------------------------------------------ 93 CALL prism_init_comp_proto( ncomp_id, 'oceanx', nerror )94 IF ( nerror /= PRISM_Ok ) &95 CALL prism_abort_proto (ncomp_id, 'cpl_prism_init', 'Failure in prism_init_comp_proto')106 CALL oasis_init_comp ( ncomp_id, 'oceanx', nerror ) 107 IF ( nerror /= OASIS_Ok ) & 108 CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') 96 109 97 110 !------------------------------------------------------------------ … … 99 112 !------------------------------------------------------------------ 100 113 101 CALL prism_get_localcomm_proto( kl_comm, nerror )102 IF ( nerror /= PRISM_Ok ) &103 CALL prism_abort_proto (ncomp_id, 'cpl_prism_init','Failure in prism_get_localcomm_proto' )104 ! 105 END SUBROUTINE cpl_ prism_init106 107 108 SUBROUTINE cpl_ prism_define( krcv, ksnd)114 CALL oasis_get_localcomm ( kl_comm, nerror ) 115 IF ( nerror /= OASIS_Ok ) & 116 CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' ) 117 ! 118 END SUBROUTINE cpl_init 119 120 121 SUBROUTINE cpl_define( krcv, ksnd, kcplmodel ) 109 122 !!------------------------------------------------------------------- 110 !! *** ROUTINE cpl_ prism_define ***123 !! *** ROUTINE cpl_define *** 111 124 !! 112 125 !! ** Purpose : Define grid and field information for ocean … … 116 129 !!-------------------------------------------------------------------- 117 130 INTEGER, INTENT(in) :: krcv, ksnd ! Number of received and sent coupling fields 131 INTEGER, INTENT(in) :: kcplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 118 132 ! 119 133 INTEGER :: id_part 120 134 INTEGER :: paral(5) ! OASIS3 box partition 121 135 INTEGER :: ishape(2,2) ! shape of arrays passed to PSMILe 122 INTEGER :: ji,jc ! local loop indicees 123 CHARACTER(LEN=8) :: zclname 136 INTEGER :: ji,jc,jm ! local loop indicees 137 CHARACTER(LEN=64) :: zclname 138 CHARACTER(LEN=2) :: cli2 124 139 !!-------------------------------------------------------------------- 125 140 126 141 IF(lwp) WRITE(numout,*) 127 IF(lwp) WRITE(numout,*) 'cpl_ prism_define : initialization in coupled ocean/atmosphere case'142 IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case' 128 143 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 129 144 IF(lwp) WRITE(numout,*) 130 145 146 IF( kcplmodel > nmaxcpl ) THEN 147 CALL oasis_abort ( ncomp_id, 'cpl_define', 'kcplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN 148 ENDIF 131 149 ! 132 150 ! ... Define the shape for the area that excludes the halo … … 141 159 ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror) 142 160 IF( nerror > 0 ) THEN 143 CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld') ; RETURN161 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN 144 162 ENDIF 145 163 ! … … 161 179 ENDIF 162 180 163 CALL prism_def_partition_proto( id_part, paral, nerror )181 CALL oasis_def_partition ( id_part, paral, nerror ) 164 182 ! 165 183 ! ... Announce send variables. 166 184 ! 185 ssnd(:)%ncplmodel = kcplmodel 186 ! 167 187 DO ji = 1, ksnd 168 IF ( ssnd(ji)%laction ) THEN 188 IF ( ssnd(ji)%laction ) THEN 189 190 IF( ssnd(ji)%nct > nmaxcat ) THEN 191 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & 192 & TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) 193 RETURN 194 ENDIF 195 169 196 DO jc = 1, ssnd(ji)%nct 170 IF ( ssnd(ji)%nct .gt. 1 ) THEN 171 WRITE(zclname,'( a7, i1)') ssnd(ji)%clname,jc 172 ELSE 173 zclname=ssnd(ji)%clname 174 ENDIF 175 WRITE(numout,*) "Define",ji,jc,zclname," for",PRISM_Out 176 CALL prism_def_var_proto (ssnd(ji)%nid(jc), zclname, id_part, (/ 2, 0/), & 177 PRISM_Out, ishape, PRISM_REAL, nerror) 178 IF ( nerror /= PRISM_Ok ) THEN 179 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(zclname) 180 CALL prism_abort_proto ( ssnd(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var') 181 ENDIF 197 DO jm = 1, kcplmodel 198 199 IF ( ssnd(ji)%nct .GT. 1 ) THEN 200 WRITE(cli2,'(i2.2)') jc 201 zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2 202 ELSE 203 zclname = ssnd(ji)%clname 204 ENDIF 205 IF ( kcplmodel > 1 ) THEN 206 WRITE(cli2,'(i2.2)') jm 207 zclname = 'model'//cli2//'_'//TRIM(zclname) 208 ENDIF 209 #if defined key_agrif 210 IF( agrif_fixed() /= 0 ) THEN 211 zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) 212 END IF 213 #endif 214 IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out 215 CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , (/ 2, 0 /), & 216 & OASIS_Out , ishape , OASIS_REAL, nerror ) 217 IF ( nerror /= OASIS_Ok ) THEN 218 WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) 219 CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) 220 ENDIF 221 IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" 222 IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" 223 END DO 182 224 END DO 183 225 ENDIF … … 188 230 DO ji = 1, krcv 189 231 IF ( srcv(ji)%laction ) THEN 232 233 IF( srcv(ji)%nct > nmaxcat ) THEN 234 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & 235 & TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) 236 RETURN 237 ENDIF 238 190 239 DO jc = 1, srcv(ji)%nct 191 IF ( srcv(ji)%nct .gt. 1 ) THEN 192 WRITE(zclname,'( a7, i1)') srcv(ji)%clname,jc 193 ELSE 194 zclname=srcv(ji)%clname 195 ENDIF 196 WRITE(numout,*) "Define",ji,jc,zclname," for",PRISM_In 197 CALL prism_def_var_proto ( srcv(ji)%nid(jc), zclname, id_part, (/ 2, 0/), & 198 & PRISM_In , ishape , PRISM_REAL, nerror) 199 IF ( nerror /= PRISM_Ok ) THEN 200 WRITE(numout,*) 'Failed to define transient ', ji, TRIM(zclname) 201 CALL prism_abort_proto ( srcv(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var') 202 ENDIF 240 DO jm = 1, kcplmodel 241 242 IF ( srcv(ji)%nct .GT. 1 ) THEN 243 WRITE(cli2,'(i2.2)') jc 244 zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2 245 ELSE 246 zclname = srcv(ji)%clname 247 ENDIF 248 IF ( kcplmodel > 1 ) THEN 249 WRITE(cli2,'(i2.2)') jm 250 zclname = 'model'//cli2//'_'//TRIM(zclname) 251 ENDIF 252 #if defined key_agrif 253 IF( agrif_fixed() /= 0 ) THEN 254 zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) 255 END IF 256 #endif 257 IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In 258 CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , (/ 2, 0 /), & 259 & OASIS_In , ishape , OASIS_REAL, nerror ) 260 IF ( nerror /= OASIS_Ok ) THEN 261 WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) 262 CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) 263 ENDIF 264 IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" 265 IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" 266 267 END DO 203 268 END DO 204 269 ENDIF … … 209 274 !------------------------------------------------------------------ 210 275 211 CALL prism_enddef_proto(nerror)212 IF( nerror /= PRISM_Ok ) CALL prism_abort_proto ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef')213 ! 214 END SUBROUTINE cpl_ prism_define276 CALL oasis_enddef(nerror) 277 IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef') 278 ! 279 END SUBROUTINE cpl_define 215 280 216 281 217 SUBROUTINE cpl_ prism_snd( kid, kstep, pdata, kinfo )282 SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo ) 218 283 !!--------------------------------------------------------------------- 219 !! *** ROUTINE cpl_ prism_snd ***284 !! *** ROUTINE cpl_snd *** 220 285 !! 221 286 !! ** Purpose : - At each coupling time-step,this routine sends fields … … 227 292 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata 228 293 !! 229 INTEGER :: jc 294 INTEGER :: jc,jm ! local loop index 230 295 !!-------------------------------------------------------------------- 231 296 ! … … 233 298 ! 234 299 DO jc = 1, ssnd(kid)%nct 235 236 CALL prism_put_proto ( ssnd(kid)%nid(jc), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo ) 237 238 IF ( ln_ctl ) THEN 239 IF ( kinfo == PRISM_Sent .OR. kinfo == PRISM_ToRest .OR. & 240 & kinfo == PRISM_SentOut .OR. kinfo == PRISM_ToRestOut ) THEN 241 WRITE(numout,*) '****************' 242 WRITE(numout,*) 'prism_put_proto: Outgoing ', ssnd(kid)%clname 243 WRITE(numout,*) 'prism_put_proto: ivarid ', ssnd(kid)%nid(jc) 244 WRITE(numout,*) 'prism_put_proto: kstep ', kstep 245 WRITE(numout,*) 'prism_put_proto: info ', kinfo 246 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 247 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 248 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 249 WRITE(numout,*) '****************' 300 DO jm = 1, ssnd(kid)%ncplmodel 301 302 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN 303 CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo ) 304 305 IF ( ln_ctl ) THEN 306 IF ( kinfo == OASIS_Sent .OR. kinfo == OASIS_ToRest .OR. & 307 & kinfo == OASIS_SentOut .OR. kinfo == OASIS_ToRestOut ) THEN 308 WRITE(numout,*) '****************' 309 WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname 310 WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm) 311 WRITE(numout,*) 'oasis_put: kstep ', kstep 312 WRITE(numout,*) 'oasis_put: info ', kinfo 313 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 314 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 315 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 316 WRITE(numout,*) '****************' 317 ENDIF 318 ENDIF 319 250 320 ENDIF 251 ENDIF252 321 322 ENDDO 253 323 ENDDO 254 324 ! 255 END SUBROUTINE cpl_ prism_snd256 257 258 SUBROUTINE cpl_ prism_rcv( kid, kstep, pdata, kinfo )325 END SUBROUTINE cpl_snd 326 327 328 SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo ) 259 329 !!--------------------------------------------------------------------- 260 !! *** ROUTINE cpl_ prism_rcv ***330 !! *** ROUTINE cpl_rcv *** 261 331 !! 262 332 !! ** Purpose : - At each coupling time-step,this routine receives fields … … 266 336 INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds 267 337 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done 338 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask 268 339 INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument 269 340 !! 270 INTEGER :: jc 271 LOGICAL :: llaction 341 INTEGER :: jc,jm ! local loop index 342 LOGICAL :: llaction, llfisrt 272 343 !!-------------------------------------------------------------------- 273 344 ! 274 345 ! receive local data from OASIS3 on every process 275 346 ! 347 kinfo = OASIS_idle 348 ! 276 349 DO jc = 1, srcv(kid)%nct 277 278 CALL prism_get_proto ( srcv(kid)%nid(jc), kstep, exfld, kinfo ) 279 280 llaction = .false. 281 IF( kinfo == PRISM_Recvd .OR. kinfo == PRISM_FromRest .OR. & 282 kinfo == PRISM_RecvOut .OR. kinfo == PRISM_FromRestOut ) llaction = .TRUE. 283 284 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc) 285 286 IF ( llaction ) THEN 350 llfisrt = .TRUE. 351 352 DO jm = 1, srcv(kid)%ncplmodel 353 354 IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN 355 356 CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo ) 357 358 llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. & 359 & kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut 360 361 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 362 363 IF ( llaction ) THEN 364 365 kinfo = OASIS_Rcv 366 IF( llfisrt ) THEN 367 pdata(nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 368 llfisrt = .FALSE. 369 ELSE 370 pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 371 ENDIF 372 373 IF ( ln_ctl ) THEN 374 WRITE(numout,*) '****************' 375 WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname 376 WRITE(numout,*) 'oasis_get: ivarid ' , srcv(kid)%nid(jc,jm) 377 WRITE(numout,*) 'oasis_get: kstep', kstep 378 WRITE(numout,*) 'oasis_get: info ', kinfo 379 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 380 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 381 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 382 WRITE(numout,*) '****************' 383 ENDIF 384 385 ENDIF 386 387 ENDIF 287 388 288 pdata(nldi:nlei, nldj:nlej,jc) = exfld(:,:) 289 290 !--- Fill the overlap areas and extra hallows (mpp) 291 !--- check periodicity conditions (all cases) 292 CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) 293 294 IF ( ln_ctl ) THEN 295 WRITE(numout,*) '****************' 296 WRITE(numout,*) 'prism_get_proto: Incoming ', srcv(kid)%clname 297 WRITE(numout,*) 'prism_get_proto: ivarid ' , srcv(kid)%nid(jc) 298 WRITE(numout,*) 'prism_get_proto: kstep', kstep 299 WRITE(numout,*) 'prism_get_proto: info ', kinfo 300 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(:,:,jc)) 301 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(:,:,jc)) 302 WRITE(numout,*) ' - Sum value is ', SUM(pdata(:,:,jc)) 303 WRITE(numout,*) '****************' 304 ENDIF 305 306 ! Ideally we would not reuse kinfo, but define a separate variable 307 ! for use as the return code from this routine to avoid confusion 308 ! with the return code previously obtained from the coupler. 309 kinfo = OASIS_Rcv 310 311 ELSE 312 kinfo = OASIS_idle 313 ENDIF 314 389 ENDDO 390 391 !--- Fill the overlap areas and extra hallows (mpp) 392 !--- check periodicity conditions (all cases) 393 IF( .not. llfisrt ) CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) 394 315 395 ENDDO 316 396 ! 317 END SUBROUTINE cpl_ prism_rcv318 319 320 INTEGER FUNCTION cpl_ prism_freq( kid )397 END SUBROUTINE cpl_rcv 398 399 400 INTEGER FUNCTION cpl_freq( kid ) 321 401 !!--------------------------------------------------------------------- 322 !! *** ROUTINE cpl_ prism_freq ***402 !! *** ROUTINE cpl_freq *** 323 403 !! 324 404 !! ** Purpose : - send back the coupling frequency for a particular field 325 405 !!---------------------------------------------------------------------- 326 INTEGER,INTENT(in) :: kid ! variable index 406 INTEGER,INTENT(in) :: kid ! variable index 407 !! 408 INTEGER :: info 327 409 !!---------------------------------------------------------------------- 328 cpl_prism_freq = ig_def_freq( kid)329 ! 330 END FUNCTION cpl_ prism_freq331 332 333 SUBROUTINE cpl_ prism_finalize410 CALL oasis_get_freqs(kid, 1, cpl_freq, info) 411 ! 412 END FUNCTION cpl_freq 413 414 415 SUBROUTINE cpl_finalize 334 416 !!--------------------------------------------------------------------- 335 !! *** ROUTINE cpl_ prism_finalize ***417 !! *** ROUTINE cpl_finalize *** 336 418 !! 337 419 !! ** Purpose : - Finalizes the coupling. If MPI_init has not been 338 !! called explicitly before cpl_ prism_init it will also close420 !! called explicitly before cpl_init it will also close 339 421 !! MPI communication. 340 422 !!---------------------------------------------------------------------- 341 423 ! 342 424 DEALLOCATE( exfld ) 343 CALL prism_terminate_proto( nerror ) 344 ! 345 END SUBROUTINE cpl_prism_finalize 346 347 #else 348 !!---------------------------------------------------------------------- 349 !! Default case Dummy module Forced Ocean/Atmosphere 350 !!---------------------------------------------------------------------- 351 USE in_out_manager ! I/O manager 352 LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .FALSE. !: coupled flag 353 PUBLIC cpl_prism_init 354 PUBLIC cpl_prism_finalize 355 CONTAINS 356 SUBROUTINE cpl_prism_init (kl_comm) 357 INTEGER, INTENT(out) :: kl_comm ! local communicator of the model 358 kl_comm = -1 359 WRITE(numout,*) 'cpl_prism_init: Error you sould not be there...' 360 END SUBROUTINE cpl_prism_init 361 SUBROUTINE cpl_prism_finalize 362 WRITE(numout,*) 'cpl_prism_finalize: Error you sould not be there...' 363 END SUBROUTINE cpl_prism_finalize 425 IF (nstop == 0) THEN 426 CALL oasis_terminate( nerror ) 427 ELSE 428 CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" ) 429 ENDIF 430 ! 431 END SUBROUTINE cpl_finalize 432 433 #if ! defined key_oasis3 434 435 !!---------------------------------------------------------------------- 436 !! No OASIS Library OASIS3 Dummy module... 437 !!---------------------------------------------------------------------- 438 439 SUBROUTINE oasis_init_comp(k1,cd1,k2) 440 CHARACTER(*), INTENT(in ) :: cd1 441 INTEGER , INTENT( out) :: k1,k2 442 k1 = -1 ; k2 = -1 443 WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1 444 END SUBROUTINE oasis_init_comp 445 446 SUBROUTINE oasis_abort(k1,cd1,cd2) 447 INTEGER , INTENT(in ) :: k1 448 CHARACTER(*), INTENT(in ) :: cd1,cd2 449 WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2 450 END SUBROUTINE oasis_abort 451 452 SUBROUTINE oasis_get_localcomm(k1,k2) 453 INTEGER , INTENT( out) :: k1,k2 454 k1 = -1 ; k2 = -1 455 WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...' 456 END SUBROUTINE oasis_get_localcomm 457 458 SUBROUTINE oasis_def_partition(k1,k2,k3) 459 INTEGER , INTENT( out) :: k1,k3 460 INTEGER , INTENT(in ) :: k2(5) 461 k1 = k2(1) ; k3 = k2(5) 462 WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...' 463 END SUBROUTINE oasis_def_partition 464 465 SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7) 466 CHARACTER(*), INTENT(in ) :: cd1 467 INTEGER , INTENT(in ) :: k2,k3(2),k4,k5(2,2),k6 468 INTEGER , INTENT( out) :: k1,k7 469 k1 = -1 ; k7 = -1 470 WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1 471 END SUBROUTINE oasis_def_var 472 473 SUBROUTINE oasis_enddef(k1) 474 INTEGER , INTENT( out) :: k1 475 k1 = -1 476 WRITE(numout,*) 'oasis_enddef: Error you sould not be there...' 477 END SUBROUTINE oasis_enddef 478 479 SUBROUTINE oasis_put(k1,k2,p1,k3) 480 REAL(wp), DIMENSION(:,:), INTENT(in ) :: p1 481 INTEGER , INTENT(in ) :: k1,k2 482 INTEGER , INTENT( out) :: k3 483 k3 = -1 484 WRITE(numout,*) 'oasis_put: Error you sould not be there...' 485 END SUBROUTINE oasis_put 486 487 SUBROUTINE oasis_get(k1,k2,p1,k3) 488 REAL(wp), DIMENSION(:,:), INTENT( out) :: p1 489 INTEGER , INTENT(in ) :: k1,k2 490 INTEGER , INTENT( out) :: k3 491 p1(1,1) = -1. ; k3 = -1 492 WRITE(numout,*) 'oasis_get: Error you sould not be there...' 493 END SUBROUTINE oasis_get 494 495 SUBROUTINE oasis_get_freqs(k1,k2,k3,k4) 496 INTEGER , INTENT(in ) :: k1,k2 497 INTEGER , INTENT( out) :: k3,k4 498 k3 = k1 ; k4 = k2 499 WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...' 500 END SUBROUTINE oasis_get_freqs 501 502 SUBROUTINE oasis_terminate(k1) 503 INTEGER , INTENT( out) :: k1 504 k1 = -1 505 WRITE(numout,*) 'oasis_terminate: Error you sould not be there...' 506 END SUBROUTINE oasis_terminate 507 364 508 #endif 365 509 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r4306 r4946 14 14 !!---------------------------------------------------------------------- 15 15 USE par_oce ! ocean parameters 16 USE sbc_oce ! surface boundary condition: ocean 16 17 # if defined key_lim3 17 18 USE par_ice ! LIM-3 parameters … … 21 22 USE ice_2 22 23 # endif 23 # if defined key_cice 24 # if defined key_cice 24 25 USE ice_domain_size, only: ncat 25 26 #endif … … 55 56 # endif 56 57 57 #if defined key_lim3 || defined key_lim2 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice_mean !: dauly mean solar heat flux over ice [W/m2] 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] 62 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqla_ice !: latent sensibility over ice [W/m2/K] 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqns_ice !: non solar heat flux over ice (LW+SEN+LA) [W/m2/K] 64 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice !: ice surface temperature [K] 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: albedo of ice 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice_mean !: daily mean solar heat flux over ice [W/m2] 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] 62 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqla_ice !: latent sensibility over ice [W/m2/K] 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqns_ice !: non solar heat flux over ice (LW+SEN+LA) [W/m2/K] 64 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice !: ice surface temperature [K] 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: ice albedo [-] 66 66 67 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2]68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2]69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr1_i0 !: 1st Qsr fraction penetrating inside ice cover[-]70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr2_i0 !: 2nd Qsr fraction penetrating inside ice cover[-]71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation-snow budget over ice[kg/m2]67 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2] 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2] 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr1_i0 !: Solar surface transmission parameter, thick ice [-] 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr2_i0 !: Solar surface transmission parameter, thin ice [-] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2] 72 72 73 # if defined key_lim3 74 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature 75 # endif 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt 74 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt 76 75 77 # elif defined key_cice76 #if defined key_cice 78 77 ! 79 78 ! for consistency with LIM, these are declared with three dimensions 80 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qlw_ice !: incoming long-wave 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2]82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2]83 80 ! 84 81 ! other forcing arrays are two dimensional … … 86 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iov !: y ice-ocean surface stress at NEMO V point 87 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation-snow budget over ice [kg/m2] 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature89 85 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qatm_ice !: specific humidity 90 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndi_ice !: i wind at T point … … 93 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iu !: ice fraction at NEMO U point 94 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iv !: ice fraction at NEMO V point 95 ! 96 ! finally, arrays corresponding to different ice categories 97 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: category ice fraction 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt 99 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt 91 92 ! variables used in the coupled interface 93 INTEGER , PUBLIC, PARAMETER :: jpl = ncat 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj 100 95 #endif 96 97 #if defined key_lim2 || defined key_cice 98 ! already defined in ice.F90 for LIM3 99 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ht_i, ht_s 101 #endif 102 103 #if defined key_lim3 || defined key_cice 104 ! not used with LIM2 105 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature [K] 106 #endif 107 108 REAL(wp), PUBLIC, SAVE :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 101 109 102 110 !!---------------------------------------------------------------------- … … 111 119 !! *** FUNCTION sbc_ice_alloc *** 112 120 !!---------------------------------------------------------------------- 113 INTEGER :: ierr( 2)121 INTEGER :: ierr(5) 114 122 !!---------------------------------------------------------------------- 115 123 ierr(:) = 0 116 124 117 #if defined key_lim3 || defined key_lim2 118 ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & 125 ALLOCATE( qsr_ice (jpi,jpj,jpl) , & 119 126 & qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) , & 120 & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , &121 & alb_ice (jpi,jpj,jpl) , &122 127 & utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , & 123 & fr1_i0 (jpi,jpj) , fr2_i0 (jpi,jpj) , & 124 #if defined key_lim3 125 & emp_ice(jpi,jpj) , tatm_ice(jpi,jpj) , STAT= ierr(1) ) 126 #else 127 & emp_ice(jpi,jpj) , STAT= ierr(1) ) 128 #if defined key_lim3 || defined key_cice 129 & tatm_ice(jpi,jpj) , & 128 130 #endif 129 #elif defined key_cice 130 ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , & 131 wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , &131 & STAT= ierr(1) ) 132 #if defined key_cice 133 ALLOCATE( qlw_ice(jpi,jpj,1) , wndi_ice(jpi,jpj) , qatm_ice(jpi,jpj) , & 132 134 wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , & 133 135 ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & 134 a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat), STAT= ierr(1) ) 136 a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 137 STAT= ierr(1) ) 138 IF( lk_cpl ) ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , & 139 & v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,1) , & 140 & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & 141 & STAT= ierr(2) ) 142 143 #else 144 ALLOCATE( fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , & 145 & fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,1) , & 146 & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & 147 & STAT= ierr(2) ) 135 148 #endif 136 149 ! 137 150 #if defined key_lim2 138 IF( ltrcdm2dc_ice )THEN 139 ALLOCATE( qsr_ice_mean (jpi,jpj,jpl), STAT=ierr(2) ) 140 ENDIF 151 IF( ltrcdm2dc_ice ) ALLOCATE( qsr_ice_mean (jpi,jpj,jpl), STAT=ierr(3) ) 141 152 #endif 142 153 ! 154 #if defined key_lim2 155 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(4) ) 156 #endif 157 158 #if defined key_cice || defined key_lim2 159 IF( lk_cpl ) ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 160 #endif 161 143 162 sbc_ice_alloc = MAXVAL( ierr ) 144 163 IF( lk_mpp ) CALL mpp_sum ( sbc_ice_alloc ) … … 150 169 !! Default option NO LIM 2.0 or 3.0 or CICE sea-ice model 151 170 !!---------------------------------------------------------------------- 171 USE in_out_manager ! I/O manager 152 172 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-2 ice model 153 173 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 ice model 154 174 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model 155 175 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = '-' !: no grid ice-velocity 176 REAL , PUBLIC, PARAMETER :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 177 INTEGER , PUBLIC, PARAMETER :: jpl = 1 178 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice,fr1_i0,fr2_i0 ! jpi, jpj 179 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl) 180 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i 181 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice 182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice 183 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ht_i, ht_s 184 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt 156 185 #endif 157 186 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r4666 r4946 35 35 LOGICAL , PUBLIC :: ln_blk_core !: CORE bulk formulation 36 36 LOGICAL , PUBLIC :: ln_blk_mfs !: MFS bulk formulation 37 LOGICAL , PUBLIC :: ln_cpl !: coupled formulation (overwritten by key_sbc_coupled ) 37 #if defined key_oasis3 38 LOGICAL , PUBLIC :: lk_cpl = .TRUE. !: coupled formulation 39 #else 40 LOGICAL , PUBLIC :: lk_cpl = .FALSE. !: coupled formulation 41 #endif 38 42 LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) 39 43 LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths … … 46 50 ! !: =1 levitating ice with mass and salt exchange but no presure effect 47 51 ! !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 52 INTEGER , PUBLIC :: nn_limflx !: LIM3 Multi-category heat flux formulation 53 ! !: =-1 Use of per-category fluxes 54 ! !: = 0 Average per-category fluxes 55 ! !: = 1 Average then redistribute per-category fluxes 56 ! !: = 2 Redistribute a single flux over categories 48 57 INTEGER , PUBLIC :: nn_fwb !: FreshWater Budget: 49 58 ! !: = 0 unchecked … … 56 65 LOGICAL , PUBLIC :: ln_icebergs !: Icebergs 57 66 ! 58 CHARACTER (len=8), PUBLIC :: cn_iceflx !: Flux handling over ice categories 59 LOGICAL, PUBLIC :: ln_iceflx_ave ! Average heat fluxes over all ice categories 60 LOGICAL, PUBLIC :: ln_iceflx_linear ! Redistribute mean heat fluxes over all ice categories, using ice temperature and albedo 61 ! 62 INTEGER , PUBLIC :: nn_lsm !: Number of iteration if seaoverland is applied 67 INTEGER , PUBLIC :: nn_lsm !: Number of iteration if seaoverland is applied 68 !!---------------------------------------------------------------------- 69 !! switch definition (improve readability) 70 !!---------------------------------------------------------------------- 71 INTEGER , PUBLIC, PARAMETER :: jp_gyre = 0 !: GYRE analytical formulation 72 INTEGER , PUBLIC, PARAMETER :: jp_ana = 1 !: analytical formulation 73 INTEGER , PUBLIC, PARAMETER :: jp_flx = 2 !: flux formulation 74 INTEGER , PUBLIC, PARAMETER :: jp_clio = 3 !: CLIO bulk formulation 75 INTEGER , PUBLIC, PARAMETER :: jp_core = 4 !: CORE bulk formulation 76 INTEGER , PUBLIC, PARAMETER :: jp_cpl = 5 !: Coupled formulation 77 INTEGER , PUBLIC, PARAMETER :: jp_mfs = 6 !: MFS bulk formulation 78 INTEGER , PUBLIC, PARAMETER :: jp_esopa = -1 !: esopa test, ALL formulations 79 63 80 !!---------------------------------------------------------------------- 64 81 !! Ocean Surface Boundary Condition fields -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r4724 r4946 114 114 !! - utau, vtau i- and j-component of the wind stress 115 115 !! - taum wind stress module at T-point 116 !! - wndm 10m wind module at T-point 116 !! - wndm 10m wind module at T-point over free ocean or leads in presence of sea-ice 117 117 !! - qns non-solar heat flux including latent heat of solid 118 118 !! precip. melting and emp heat content … … 204 204 !! - utau, vtau i- and j-component of the wind stress 205 205 !! - taum wind stress module at T-point 206 !! - wndm 10m wind module at T-point 206 !! - wndm 10m wind module at T-point over free ocean or leads in presence of sea-ice 207 207 !! - qns non-solar heat flux including latent heat of solid 208 208 !! precip. melting and emp heat content … … 403 403 404 404 405 SUBROUTINE blk_ice_clio( pst , palb_cs, palb_os ,&405 SUBROUTINE blk_ice_clio( pst , palb_cs, palb_os, palb, & 406 406 & p_taui, p_tauj, p_qns , p_qsr, & 407 407 & p_qla , p_dqns, p_dqla, & … … 432 432 !!---------------------------------------------------------------------- 433 433 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pst ! ice surface temperature [Kelvin] 434 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_cs ! ice albedo (clear sky) (alb_ice_cs) [%] 435 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_os ! ice albedo (overcast sky) (alb_ice_os) [%] 434 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_cs ! ice albedo (clear sky) (alb_ice_cs) [-] 435 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_os ! ice albedo (overcast sky) (alb_ice_os) [-] 436 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb ! ice albedo (actual value) [-] 436 437 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_taui ! surface ice stress at I-point (i-component) [N/m2] 437 438 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_tauj ! surface ice stress at I-point (j-component) [N/m2] … … 443 444 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_tpr ! total precipitation (T-point) [Kg/m2/s] 444 445 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_spr ! solid precipitation (T-point) [Kg/m2/s] 445 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr1 ! 1sr fraction of qsr penetration in ice [ %]446 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr2 ! 2nd fraction of qsr penetration in ice [ %]446 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr1 ! 1sr fraction of qsr penetration in ice [-] 447 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr2 ! 2nd fraction of qsr penetration in ice [-] 447 448 CHARACTER(len=1), INTENT(in ) :: cd_grid ! type of sea-ice grid ("C" or "B" grid) 448 449 INTEGER, INTENT(in ) :: pdim ! number of ice categories … … 547 548 !-----------------------------------------------------------! 548 549 CALL blk_clio_qsr_ice( palb_cs, palb_os, p_qsr ) 550 551 DO jl = 1, ijpl 552 palb(:,:,jl) = ( palb_cs(:,:,jl) * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) & 553 & + palb_os(:,:,jl) * sf(jp_ccov)%fnow(ji,jj,1) ) 554 END DO 549 555 550 556 ! ! ========================== ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r4924 r4946 5 5 !!===================================================================== 6 6 !! History : 1.0 ! 2004-08 (U. Schweckendiek) Original code 7 !! 2.0 ! 2005-04 (L. Brodeau, A.M. Treguier) additions: 7 !! 2.0 ! 2005-04 (L. Brodeau, A.M. Treguier) additions: 8 8 !! - new bulk routine for efficiency 9 9 !! - WINDS ARE NOW ASSUMED TO BE AT T POINTS in input files !!!! 10 !! - file names and file characteristics in namelist 11 !! - Implement reading of 6-hourly fields 12 !! 3.0 ! 2006-06 (G. Madec) sbc rewritting 13 !! - ! 2006-12 (L. Brodeau) Original code for TURB_CORE_2Z10 !! - file names and file characteristics in namelist 11 !! - Implement reading of 6-hourly fields 12 !! 3.0 ! 2006-06 (G. Madec) sbc rewritting 13 !! - ! 2006-12 (L. Brodeau) Original code for turb_core_2z 14 14 !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put 15 15 !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle 16 16 !! 3.4 ! 2011-11 (C. Harris) Fill arrays required by CICE 17 !! 3.7 ! 2014-06 (L. Brodeau) simplification and optimization of CORE bulk 17 18 !!---------------------------------------------------------------------- 18 19 19 20 !!---------------------------------------------------------------------- 20 !! sbc_blk_core : bulk formulation as ocean surface boundary condition 21 !! (forced mode, CORE bulk formulea) 22 !! blk_oce_core : ocean: computes momentum, heat and freshwater fluxes 23 !! blk_ice_core : ice : computes momentum, heat and freshwater fluxes 24 !! turb_core : computes the CORE turbulent transfer coefficients 21 !! sbc_blk_core : bulk formulation as ocean surface boundary condition (forced mode, CORE bulk formulea) 22 !! blk_oce_core : computes momentum, heat and freshwater fluxes over ocean 23 !! blk_ice_core : computes momentum, heat and freshwater fluxes over ice 24 !! blk_bio_meanqsr : compute daily mean short wave radiation over the ocean 25 !! blk_ice_meanqsr : compute daily mean short wave radiation over the ice 26 !! turb_core_2z : Computes turbulent transfert coefficients 27 !! cd_neutral_10m : Estimate of the neutral drag coefficient at 10m 28 !! psi_m : universal profile stability function for momentum 29 !! psi_h : universal profile stability function for temperature and humidity 25 30 !!---------------------------------------------------------------------- 26 31 USE oce ! ocean dynamics and tracers … … 38 43 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 39 44 USE prtctl ! Print control 40 USE sbcwave,ONLY : cdn_wave !wave module 41 #if defined key_lim3 || defined key_cice 45 USE sbcwave, ONLY : cdn_wave ! wave module 42 46 USE sbc_ice ! Surface boundary condition: ice fields 43 #endif44 47 USE lib_fortran ! to use key_nosignedzero 45 48 … … 52 55 PUBLIC turb_core_2z ! routine calles in sbcblk_mfs module 53 56 54 INTEGER , PARAMETER :: jpfld = 9 ! maximum number of files to read 57 INTEGER , PARAMETER :: jpfld = 9 ! maximum number of files to read 55 58 INTEGER , PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point 56 59 INTEGER , PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point … … 62 65 INTEGER , PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s) 63 66 INTEGER , PARAMETER :: jp_tdif = 9 ! index of tau diff associated to HF tau (N/m2) at T-point 64 67 65 68 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) 66 69 67 70 ! !!! CORE bulk parameters 68 71 REAL(wp), PARAMETER :: rhoa = 1.22 ! air density … … 75 78 76 79 ! !!* Namelist namsbc_core : CORE bulk parameters 77 LOGICAL :: ln_2m ! logical flag for height of air temp. and hum78 80 LOGICAL :: ln_taudif ! logical flag to use the "mean of stress module - module of mean stress" data 79 81 REAL(wp) :: rn_pfac ! multiplication factor for precipitation 80 82 REAL(wp) :: rn_efac ! multiplication factor for evaporation (clem) 81 83 REAL(wp) :: rn_vfac ! multiplication factor for ice/ocean velocity in the calculation of wind stress (clem) 82 LOGICAL :: ln_bulk2z ! logical flag for case where z(q,t) and z(u) are specified in the namelist83 84 REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements 84 85 REAL(wp) :: rn_zu ! z(u) : height of wind measurements … … 88 89 # include "vectopt_loop_substitute.h90" 89 90 !!---------------------------------------------------------------------- 90 !! NEMO/OPA 3. 3 , NEMO-consortium (2010)91 !! NEMO/OPA 3.7 , NEMO-consortium (2014) 91 92 !! $Id$ 92 93 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 97 98 !!--------------------------------------------------------------------- 98 99 !! *** ROUTINE sbc_blk_core *** 99 !! 100 !! 100 101 !! ** Purpose : provide at each time step the surface ocean fluxes 101 !! (momentum, heat, freshwater and runoff) 102 !! (momentum, heat, freshwater and runoff) 102 103 !! 103 104 !! ** Method : (1) READ each fluxes in NetCDF files: … … 118 119 !! ** Action : defined at each time-step at the air-sea interface 119 120 !! - utau, vtau i- and j-component of the wind stress 120 !! - taum, wndm wind stress and 10m wind modules at T-point 121 !! - taum wind stress module at T-point 122 !! - wndm wind speed module at T-point over free ocean or leads in presence of sea-ice 121 123 !! - qns, qsr non-solar and solar heat fluxes 122 124 !! - emp upward mass flux (evapo. - precip.) 123 125 !! - sfx salt flux due to freezing/melting (non-zero only if ice is present) 124 126 !! (set in limsbc(_2).F90) 127 !! 128 !! ** References : Large & Yeager, 2004 / Large & Yeager, 2008 129 !! Brodeau et al. Ocean Modelling 2010 125 130 !!---------------------------------------------------------------------- 126 131 INTEGER, INTENT(in) :: kt ! ocean time step 127 ! !132 ! 128 133 INTEGER :: ierror ! return error code 129 134 INTEGER :: ifpr ! dummy loop indice 130 135 INTEGER :: jfld ! dummy loop arguments 131 136 INTEGER :: ios ! Local integer output status for namelist read 132 ! !137 ! 133 138 CHARACTER(len=100) :: cn_dir ! Root directory for location of core files 134 139 TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read … … 136 141 TYPE(FLD_N) :: sn_qlw , sn_tair, sn_prec, sn_snow ! " " 137 142 TYPE(FLD_N) :: sn_tdif ! " " 138 NAMELIST/namsbc_core/ cn_dir , ln_ 2m , ln_taudif, rn_pfac, rn_efac, rn_vfac, &143 NAMELIST/namsbc_core/ cn_dir , ln_taudif, rn_pfac, rn_efac, rn_vfac, & 139 144 & sn_wndi, sn_wndj, sn_humi , sn_qsr , & 140 145 & sn_qlw , sn_tair, sn_prec , sn_snow, & 141 & sn_tdif, rn_zqt , ln_bulk2z,rn_zu142 !!--------------------------------------------------------------------- 143 146 & sn_tdif, rn_zqt, rn_zu 147 !!--------------------------------------------------------------------- 148 ! 144 149 ! ! ====================== ! 145 150 IF( kt == nit000 ) THEN ! First call kt=nit000 ! … … 149 154 READ ( numnam_ref, namsbc_core, IOSTAT = ios, ERR = 901) 150 155 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_core in reference namelist', lwp ) 151 156 ! 152 157 REWIND( numnam_cfg ) ! Namelist namsbc_core in configuration namelist : CORE bulk parameters 153 158 READ ( numnam_cfg, namsbc_core, IOSTAT = ios, ERR = 902 ) 154 159 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_core in configuration namelist', lwp ) 155 160 156 IF(lwm)WRITE ( numond, namsbc_core )161 WRITE ( numond, namsbc_core ) 157 162 ! ! check: do we plan to use ln_dm2dc with non-daily forcing? 158 IF( ln_dm2dc .AND. sn_qsr%nfreqh /= 24 ) & 159 & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) 163 IF( ln_dm2dc .AND. sn_qsr%nfreqh /= 24 ) & 164 & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) 160 165 IF( ln_dm2dc .AND. sn_qsr%ln_tint ) THEN 161 166 CALL ctl_warn( 'sbc_blk_core: ln_dm2dc is taking care of the temporal interpolation of daily qsr', & 162 167 & ' ==> We force time interpolation = .false. for qsr' ) 163 168 sn_qsr%ln_tint = .false. 164 169 ENDIF … … 169 174 slf_i(jp_prec) = sn_prec ; slf_i(jp_snow) = sn_snow 170 175 slf_i(jp_tdif) = sn_tdif 171 ! 176 ! 172 177 lhftau = ln_taudif ! do we use HF tau information? 173 178 jfld = jpfld - COUNT( (/.NOT. lhftau/) ) … … 191 196 IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL blk_oce_core( kt, sf, sst_m, ssu_m, ssv_m ) 192 197 193 ! If diurnal cycle is activated, compute a daily mean short waves flux for biogeochemistery 198 ! If diurnal cycle is activated, compute a daily mean short waves flux for biogeochemistery 194 199 IF( ltrcdm2dc ) CALL blk_bio_meanqsr 195 200 … … 226 231 !! - qsr : Solar heat flux over the ocean (W/m2) 227 232 !! - qns : Non Solar heat flux over the ocean (W/m2) 228 !! - evap : Evaporation over the ocean (kg/m2/s)229 233 !! - emp : evaporation minus precipitation (kg/m2/s) 230 234 !! … … 269 273 zwnd_j(:,:) = 0.e0 270 274 #if defined key_cyclone 271 # if defined key_vectopt_loop 272 !CDIR COLLAPSE 273 # endif 274 CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add Manu ! 275 CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) 275 276 DO jj = 2, jpjm1 276 277 DO ji = fs_2, fs_jpim1 ! vect. opt. … … 279 280 END DO 280 281 END DO 281 #endif282 #if defined key_vectopt_loop283 !CDIR COLLAPSE284 282 #endif 285 283 DO jj = 2, jpjm1 … … 292 290 CALL lbc_lnk( zwnd_j(:,:) , 'T', -1. ) 293 291 ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) 294 !CDIR NOVERRCHK295 !CDIR COLLAPSE296 292 wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) & 297 293 & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1) … … 300 296 ! I Radiative FLUXES ! 301 297 ! ----------------------------------------------------------------------------- ! 302 298 303 299 ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle ! Short Wave 304 300 zztmp = 1. - albo … … 306 302 ELSE ; qsr(:,:) = zztmp * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) 307 303 ENDIF 308 !CDIR COLLAPSE309 304 zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave 310 305 ! ----------------------------------------------------------------------------- ! … … 313 308 314 309 ! ... specific humidity at SST and IST 315 !CDIR NOVERRCHK 316 !CDIR COLLAPSE 317 zqsatw(:,:) = zcoef_qsatw * EXP( -5107.4 / zst(:,:) ) 310 zqsatw(:,:) = zcoef_qsatw * EXP( -5107.4 / zst(:,:) ) 318 311 319 312 ! ... NCAR Bulk formulae, computation of Cd, Ch, Ce at T-point : 320 IF( ln_2m ) THEN 321 !! If air temp. and spec. hum. are given at different height (2m) than wind (10m) : 322 CALL TURB_CORE_2Z(2.,10., zst , sf(jp_tair)%fnow, & 323 & zqsatw, sf(jp_humi)%fnow, wndm, & 324 & Cd , Ch , Ce , & 325 & zt_zu , zq_zu ) 326 ELSE IF( ln_bulk2z ) THEN 327 !! If the height of the air temp./spec. hum. and wind are to be specified by hand : 328 IF( rn_zqt == rn_zu ) THEN 329 !! If air temp. and spec. hum. are at the same height as wind : 330 CALL TURB_CORE_1Z( rn_zu, zst , sf(jp_tair)%fnow(:,:,1), & 331 & zqsatw, sf(jp_humi)%fnow(:,:,1), wndm, & 332 & Cd , Ch , Ce ) 333 ELSE 334 !! If air temp. and spec. hum. are at a different height to wind : 335 CALL TURB_CORE_2Z(rn_zqt, rn_zu , zst , sf(jp_tair)%fnow, & 336 & zqsatw, sf(jp_humi)%fnow, wndm, & 337 & Cd , Ch , Ce , & 338 & zt_zu , zq_zu ) 339 ENDIF 340 ELSE 341 !! If air temp. and spec. hum. are given at same height than wind (10m) : 342 !gm bug? at the compiling phase, add a copy in temporary arrays... ==> check perf 343 ! CALL TURB_CORE_1Z( 10., zst (:,:), sf(jp_tair)%fnow(:,:), & 344 ! & zqsatw(:,:), sf(jp_humi)%fnow(:,:), wndm(:,:), & 345 ! & Cd (:,:), Ch (:,:), Ce (:,:) ) 346 !gm bug 347 ! ARPDBG - this won't compile with gfortran. Fix but check performance 348 ! as per comment above. 349 CALL TURB_CORE_1Z( 10., zst , sf(jp_tair)%fnow(:,:,1), & 350 & zqsatw, sf(jp_humi)%fnow(:,:,1), wndm, & 351 & Cd , Ch , Ce ) 352 ENDIF 353 313 CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, sf(jp_humi)%fnow, wndm, & 314 & Cd, Ch, Ce, zt_zu, zq_zu ) 315 354 316 ! ... tau module, i and j component 355 317 DO jj = 1, jpj … … 363 325 364 326 ! ... add the HF tau contribution to the wind stress module? 365 IF( lhftau ) THEN 366 !CDIR COLLAPSE 327 IF( lhftau ) THEN 367 328 taum(:,:) = taum(:,:) + sf(jp_tdif)%fnow(:,:,1) 368 329 ENDIF … … 383 344 CALL lbc_lnk( vtau(:,:), 'V', -1. ) 384 345 346 385 347 ! Turbulent fluxes over ocean 386 348 ! ----------------------------- 387 IF( ln_2m .OR. ( ln_bulk2z .AND. rn_zqt /= rn_zu )) THEN388 ! Values of temp. and hum. adjusted to height of wind must be used389 zevap(:,:) = rn_efac * MAX( 0.e0, rhoa *Ce(:,:)*( zqsatw(:,:) - zq_zu(:,:) ) * wndm(:,:) )! Evaporation390 zqsb (:,:) = rhoa*cpa*Ch(:,:)*( zst (:,:) - zt_zu(:,:) ) * wndm(:,:)! Sensible Heat349 IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 350 !! q_air and t_air are (or "are almost") given at 10m (wind reference height) 351 zevap(:,:) = rn_efac*MAX( 0._wp, rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 352 zqsb (:,:) = cpa*rhoa*Ch(:,:)*( zst (:,:) - sf(jp_tair)%fnow(:,:,1) )*wndm(:,:) ! Sensible Heat 391 353 ELSE 392 !CDIR COLLAPSE 393 zevap(:,:) = rn_efac * MAX( 0.e0, rhoa *Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) ) * wndm(:,:) ) ! Evaporation394 !CDIR COLLAPSE 395 zqsb (:,:) = rhoa*cpa*Ch(:,:)*( zst (:,:) - sf(jp_tair)%fnow(:,:,1) ) *wndm(:,:) ! Sensible Heat354 !! q_air and t_air are not given at 10m (wind reference height) 355 ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!! 356 zevap(:,:) = rn_efac*MAX( 0._wp, rhoa*Ce(:,:)*( zqsatw(:,:) - zq_zu(:,:) )*wndm(:,:) ) ! Evaporation 357 zqsb (:,:) = cpa*rhoa*Ch(:,:)*( zst (:,:) - zt_zu(:,:) )*wndm(:,:) ! Sensible Heat 396 358 ENDIF 397 !CDIR COLLAPSE398 359 zqla (:,:) = Lv * zevap(:,:) ! Latent Heat 399 360 … … 412 373 ! III Total FLUXES ! 413 374 ! ----------------------------------------------------------------------------- ! 414 415 !CDIR COLLAPSE 375 ! 416 376 emp (:,:) = ( zevap(:,:) & ! mass flux (evap. - precip.) 417 377 & - sf(jp_prec)%fnow(:,:,1) * rn_pfac ) * tmask(:,:,1) 418 !CDIR COLLAPSE419 378 qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) & ! Downward Non Solar flux 420 379 & - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus & ! remove latent melting heat for solid precip 421 380 & - zevap(:,:) * pst(:,:) * rcp & ! remove evap heat content at SST 422 381 & + ( sf(jp_prec)%fnow(:,:,1) - sf(jp_snow)%fnow(:,:,1) ) * rn_pfac & ! add liquid precip heat content at Tair 423 & * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & 382 & * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & 424 383 & + sf(jp_snow)%fnow(:,:,1) * rn_pfac & ! add solid precip heat content at min(Tair,Tsnow) 425 384 & * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) … … 445 404 ! 446 405 END SUBROUTINE blk_oce_core 447 448 SUBROUTINE blk_bio_meanqsr449 !!---------------------------------------------------------------------450 !! *** ROUTINE blk_bio_meanqsr451 !!452 !! ** Purpose : provide daily qsr_mean for PISCES when453 !! analytic diurnal cycle is applied in physic454 !!455 !! ** Method : add part where there is no ice456 !!457 !!---------------------------------------------------------------------458 IF( nn_timing == 1 ) CALL timing_start('blk_bio_meanqsr')459 460 qsr_mean(:,:) = (1. - albo ) * sf(jp_qsr)%fnow(:,:,1)461 462 IF( nn_timing == 1 ) CALL timing_stop('blk_bio_meanqsr')463 464 END SUBROUTINE blk_bio_meanqsr465 466 467 SUBROUTINE blk_ice_meanqsr(palb,p_qsr_mean,pdim)468 !!---------------------------------------------------------------------469 !!470 !! ** Purpose : provide the daily qsr_mean over sea_ice for PISCES when471 !! analytic diurnal cycle is applied in physic472 !!473 !! ** Method : compute qsr474 !!475 !!---------------------------------------------------------------------476 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo (clear sky) (alb_ice_cs) [%]477 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qsr_mean ! solar heat flux over ice (T-point) [W/m2]478 INTEGER , INTENT(in ) :: pdim ! number of ice categories479 !!480 INTEGER :: ijpl ! number of ice categories (size of 3rd dim of input arrays)481 INTEGER :: ji, jj, jl ! dummy loop indices482 REAL(wp) :: zztmp ! temporary variable483 !!---------------------------------------------------------------------484 IF( nn_timing == 1 ) CALL timing_start('blk_ice_meanqsr')485 !486 ijpl = pdim ! number of ice categories487 zztmp = 1. / ( 1. - albo )488 ! ! ========================== !489 DO jl = 1, ijpl ! Loop over ice categories !490 ! ! ========================== !491 DO jj = 1 , jpj492 DO ji = 1, jpi493 p_qsr_mean(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr_mean(ji,jj)494 END DO495 END DO496 END DO497 !498 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_meanqsr')499 !500 END SUBROUTINE blk_ice_meanqsr501 406 502 407 … … 521 426 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pui ! ice surface velocity (i- and i- components [m/s] 522 427 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pvi ! at I-point (B-grid) or U & V-point (C-grid) 523 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo ( clear sky) (alb_ice_cs)[%]428 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo (all skies) [%] 524 429 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_taui ! i- & j-components of surface ice stress [N/m2] 525 430 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) … … 541 446 REAL(wp) :: zcoef_wnorm, zcoef_wnorm2, zcoef_dqlw, zcoef_dqla, zcoef_dqsb 542 447 REAL(wp) :: zztmp ! temporary variable 543 REAL(wp) :: zcoef_frca ! fractional cloud amount544 448 REAL(wp) :: zwnorm_f, zwndi_f , zwndj_f ! relative wind module and components at F-point 545 449 REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point … … 565 469 zcoef_dqla = -Ls * Cice * 11637800. * (-5897.8) 566 470 zcoef_dqsb = rhoa * cpa * Cice 567 zcoef_frca = 1.0 - 0.3568 ! MV 2014 the proper cloud fraction (mean summer months from the CLIO climato, NH+SH) is 0.19569 zcoef_frca = 1.0 - 0.19570 471 571 472 !!gm brutal.... … … 584 485 CASE( 'I' ) ! B-grid ice dynamics : I-point (i.e. F-point with sea-ice indexation) 585 486 ! and scalar wind at T-point ( = | U10m - U_ice | ) (masked) 586 !CDIR NOVERRCHK587 487 DO jj = 2, jpjm1 588 488 DO ji = 2, jpim1 ! B grid : NO vector opt … … 609 509 ! 610 510 CASE( 'C' ) ! C-grid ice dynamics : U & V-points (same as ocean) 611 #if defined key_vectopt_loop612 !CDIR COLLAPSE613 #endif614 511 DO jj = 2, jpj 615 512 DO ji = fs_2, jpi ! vect. opt. … … 619 516 END DO 620 517 END DO 621 #if defined key_vectopt_loop622 !CDIR COLLAPSE623 #endif624 518 DO jj = 2, jpjm1 625 519 DO ji = fs_2, fs_jpim1 ! vect. opt. … … 640 534 DO jl = 1, ijpl ! Loop over ice categories ! 641 535 ! ! ========================== ! 642 !CDIR NOVERRCHK643 !CDIR COLLAPSE644 536 DO jj = 1 , jpj 645 !CDIR NOVERRCHK646 537 DO ji = 1, jpi 647 538 ! ----------------------------! … … 668 559 & * ( 11637800. * EXP( -5897.8 / pst(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1) ) ) 669 560 ! Latent heat sensitivity for ice (Dqla/Dt) 670 ! MV we also have to cap the sensitivity if the flux is zero 671 IF ( p_qla(ji,jj,jl) .GT. 0.0 ) THEN 561 IF( p_qla(ji,jj,jl) > 0._wp ) THEN 672 562 p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) ) 673 563 ELSE 674 p_dqla(ji,jj,jl) = 0. 0564 p_dqla(ji,jj,jl) = 0._wp 675 565 ENDIF 676 566 677 567 ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 678 568 z_dqsb(ji,jj,jl) = zcoef_dqsb * z_wnds_t(ji,jj) … … 682 572 ! ----------------------------! 683 573 ! Downward Non Solar flux 684 p_qns (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - p_qla (ji,jj,jl) 574 p_qns (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - p_qla (ji,jj,jl) 685 575 ! Total non solar heat flux sensitivity for ice 686 p_dqns(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + p_dqla(ji,jj,jl) ) 576 p_dqns(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + p_dqla(ji,jj,jl) ) 687 577 END DO 688 578 ! … … 695 585 ! thin surface layer and penetrates inside the ice cover 696 586 ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 ) 697 698 !CDIR COLLAPSE 699 p_fr1(:,:) = ( 0.18 * ( 1.0 - zcoef_frca ) + 0.35 * zcoef_frca ) 700 !CDIR COLLAPSE 701 p_fr2(:,:) = ( 0.82 * ( 1.0 - zcoef_frca ) + 0.65 * zcoef_frca ) 702 703 !CDIR COLLAPSE 587 ! 588 p_fr1(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 589 p_fr2(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 590 ! 704 591 p_tpr(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac ! total precipitation [kg/m2/s] 705 !CDIR COLLAPSE706 592 p_spr(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac ! solid precipitation [kg/m2/s] 707 CALL iom_put( 'snowpre', p_spr * 86400. ) ! Snow precipitation 708 CALL iom_put( 'precip' , p_tpr * 86400. ) ! Total precipitation593 CALL iom_put( 'snowpre', p_spr * 86400. ) ! Snow precipitation 594 CALL iom_put( 'precip' , p_tpr * 86400. ) ! Total precipitation 709 595 ! 710 596 IF(ln_ctl) THEN … … 719 605 ENDIF 720 606 721 CALL wrk_dealloc( jpi,jpj, z_wnds_t )722 CALL wrk_dealloc( jpi,jpj, pdim, z_qlw, z_qsb, z_dqlw, z_dqsb )607 CALL wrk_dealloc( jpi,jpj, z_wnds_t ) 608 CALL wrk_dealloc( jpi,jpj, pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 723 609 ! 724 610 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_core') 725 611 ! 726 612 END SUBROUTINE blk_ice_core 727 728 729 SUBROUTINE TURB_CORE_1Z(zu, sst, T_a, q_sat, q_a, & 730 & dU , Cd , Ch , Ce ) 613 614 615 SUBROUTINE blk_bio_meanqsr 616 !!--------------------------------------------------------------------- 617 !! *** ROUTINE blk_bio_meanqsr 618 !! 619 !! ** Purpose : provide daily qsr_mean for PISCES when 620 !! analytic diurnal cycle is applied in physic 621 !! 622 !! ** Method : add part where there is no ice 623 !! 624 !!--------------------------------------------------------------------- 625 IF( nn_timing == 1 ) CALL timing_start('blk_bio_meanqsr') 626 ! 627 qsr_mean(:,:) = (1. - albo ) * sf(jp_qsr)%fnow(:,:,1) 628 ! 629 IF( nn_timing == 1 ) CALL timing_stop('blk_bio_meanqsr') 630 ! 631 END SUBROUTINE blk_bio_meanqsr 632 633 634 SUBROUTINE blk_ice_meanqsr( palb, p_qsr_mean, pdim ) 635 !!--------------------------------------------------------------------- 636 !! 637 !! ** Purpose : provide the daily qsr_mean over sea_ice for PISCES when 638 !! analytic diurnal cycle is applied in physic 639 !! 640 !! ** Method : compute qsr 641 !! 642 !!--------------------------------------------------------------------- 643 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo (clear sky) (alb_ice_cs) [%] 644 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qsr_mean ! solar heat flux over ice (T-point) [W/m2] 645 INTEGER , INTENT(in ) :: pdim ! number of ice categories 646 ! 647 INTEGER :: ijpl ! number of ice categories (size of 3rd dim of input arrays) 648 INTEGER :: ji, jj, jl ! dummy loop indices 649 REAL(wp) :: zztmp ! temporary variable 650 !!--------------------------------------------------------------------- 651 IF( nn_timing == 1 ) CALL timing_start('blk_ice_meanqsr') 652 ! 653 ijpl = pdim ! number of ice categories 654 zztmp = 1. / ( 1. - albo ) 655 ! ! ========================== ! 656 DO jl = 1, ijpl ! Loop over ice categories ! 657 ! ! ========================== ! 658 DO jj = 1 , jpj 659 DO ji = 1, jpi 660 p_qsr_mean(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr_mean(ji,jj) 661 END DO 662 END DO 663 END DO 664 ! 665 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_meanqsr') 666 ! 667 END SUBROUTINE blk_ice_meanqsr 668 669 670 SUBROUTINE turb_core_2z( zt, zu, sst, T_zt, q_sat, q_zt, dU, & 671 & Cd, Ch, Ce , T_zu, q_zu ) 731 672 !!---------------------------------------------------------------------- 732 673 !! *** ROUTINE turb_core *** 733 674 !! 734 675 !! ** Purpose : Computes turbulent transfert coefficients of surface 735 !! fluxes according to Large & Yeager (2004) 736 !! 737 !! ** Method : I N E R T I A L D I S S I P A T I O N M E T H O D 738 !! Momentum, Latent and sensible heat exchange coefficients 739 !! Caution: this procedure should only be used in cases when air 740 !! temperature (T_air), air specific humidity (q_air) and wind (dU) 741 !! are provided at the same height 'zzu'! 742 !! 743 !! References : Large & Yeager, 2004 : ??? 744 !!---------------------------------------------------------------------- 745 REAL(wp) , INTENT(in ) :: zu ! altitude of wind measurement [m] 746 REAL(wp), DIMENSION(:,:), INTENT(in ) :: sst ! sea surface temperature [Kelvin] 747 REAL(wp), DIMENSION(:,:), INTENT(in ) :: T_a ! potential air temperature [Kelvin] 748 REAL(wp), DIMENSION(:,:), INTENT(in ) :: q_sat ! sea surface specific humidity [kg/kg] 749 REAL(wp), DIMENSION(:,:), INTENT(in ) :: q_a ! specific air humidity [kg/kg] 750 REAL(wp), DIMENSION(:,:), INTENT(in ) :: dU ! wind module |U(zu)-U(0)| [m/s] 751 REAL(wp), DIMENSION(:,:), INTENT( out) :: Cd ! transfert coefficient for momentum (tau) 752 REAL(wp), DIMENSION(:,:), INTENT( out) :: Ch ! transfert coefficient for temperature (Q_sens) 753 REAL(wp), DIMENSION(:,:), INTENT( out) :: Ce ! transfert coefficient for evaporation (Q_lat) 754 !! 755 INTEGER :: j_itt 756 INTEGER , PARAMETER :: nb_itt = 3 757 REAL(wp), PARAMETER :: grav = 9.8 ! gravity 758 REAL(wp), PARAMETER :: kappa = 0.4 ! von Karman s constant 759 760 REAL(wp), DIMENSION(:,:), POINTER :: dU10 ! dU [m/s] 761 REAL(wp), DIMENSION(:,:), POINTER :: dT ! air/sea temperature differeence [K] 762 REAL(wp), DIMENSION(:,:), POINTER :: dq ! air/sea humidity difference [K] 763 REAL(wp), DIMENSION(:,:), POINTER :: Cd_n10 ! 10m neutral drag coefficient 764 REAL(wp), DIMENSION(:,:), POINTER :: Ce_n10 ! 10m neutral latent coefficient 765 REAL(wp), DIMENSION(:,:), POINTER :: Ch_n10 ! 10m neutral sensible coefficient 766 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd_n10 ! root square of Cd_n10 767 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd ! root square of Cd 768 REAL(wp), DIMENSION(:,:), POINTER :: T_vpot ! virtual potential temperature [K] 769 REAL(wp), DIMENSION(:,:), POINTER :: T_star ! turbulent scale of tem. fluct. 770 REAL(wp), DIMENSION(:,:), POINTER :: q_star ! turbulent humidity of temp. fluct. 771 REAL(wp), DIMENSION(:,:), POINTER :: U_star ! turb. scale of velocity fluct. 772 REAL(wp), DIMENSION(:,:), POINTER :: L ! Monin-Obukov length [m] 773 REAL(wp), DIMENSION(:,:), POINTER :: zeta ! stability parameter at height zu 774 REAL(wp), DIMENSION(:,:), POINTER :: U_n10 ! neutral wind velocity at 10m [m] 775 REAL(wp), DIMENSION(:,:), POINTER :: xlogt, xct, zpsi_h, zpsi_m 776 777 INTEGER , DIMENSION(:,:), POINTER :: stab ! 1st guess stability test integer 778 !!---------------------------------------------------------------------- 779 ! 780 IF( nn_timing == 1 ) CALL timing_start('TURB_CORE_1Z') 781 ! 782 CALL wrk_alloc( jpi,jpj, stab ) ! integer 783 CALL wrk_alloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 784 CALL wrk_alloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta, U_n10, xlogt, xct, zpsi_h, zpsi_m ) 785 786 !! * Start 787 !! Air/sea differences 788 dU10 = max(0.5, dU) ! we don't want to fall under 0.5 m/s 789 dT = T_a - sst ! assuming that T_a is allready the potential temp. at zzu 790 dq = q_a - q_sat 791 !! 792 !! Virtual potential temperature 793 T_vpot = T_a*(1. + 0.608*q_a) 794 !! 795 !! Neutral Drag Coefficient 796 stab = 0.5 + sign(0.5,dT) ! stable : stab = 1 ; unstable : stab = 0 797 IF ( ln_cdgw ) THEN 798 cdn_wave = cdn_wave - rsmall*(tmask(:,:,1)-1) 799 Cd_n10(:,:) = cdn_wave 800 ELSE 801 Cd_n10 = 1.e-3 * ( 2.7/dU10 + 0.142 + dU10/13.09 ) ! L & Y eq. (6a) 802 ENDIF 803 sqrt_Cd_n10 = sqrt(Cd_n10) 804 Ce_n10 = 1.e-3 * ( 34.6 * sqrt_Cd_n10 ) ! L & Y eq. (6b) 805 Ch_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1.-stab)) ! L & Y eq. (6c), (6d) 806 !! 807 !! Initializing transfert coefficients with their first guess neutral equivalents : 808 Cd = Cd_n10 ; Ce = Ce_n10 ; Ch = Ch_n10 ; sqrt_Cd = sqrt(Cd) 809 810 !! * Now starting iteration loop 811 DO j_itt=1, nb_itt 812 !! Turbulent scales : 813 U_star = sqrt_Cd*dU10 ! L & Y eq. (7a) 814 T_star = Ch/sqrt_Cd*dT ! L & Y eq. (7b) 815 q_star = Ce/sqrt_Cd*dq ! L & Y eq. (7c) 816 817 !! Estimate the Monin-Obukov length : 818 L = (U_star**2)/( kappa*grav*(T_star/T_vpot + q_star/(q_a + 1./0.608)) ) 819 820 !! Stability parameters : 821 zeta = zu/L ; zeta = sign( min(abs(zeta),10.0), zeta ) 822 zpsi_h = psi_h(zeta) 823 zpsi_m = psi_m(zeta) 824 825 IF ( ln_cdgw ) THEN 826 sqrt_Cd=kappa/((kappa/sqrt_Cd_n10) - zpsi_m) ; Cd=sqrt_Cd*sqrt_Cd; 827 ELSE 828 !! Shifting the wind speed to 10m and neutral stability : L & Y eq. (9a) 829 ! In very rare low-wind conditions, the old way of estimating the 830 ! neutral wind speed at 10m leads to a negative value that causes the code 831 ! to crash. To prevent this a threshold of 0.25m/s is now imposed. 832 U_n10 = MAX( 0.25 , dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ) 833 834 !! Updating the neutral 10m transfer coefficients : 835 Cd_n10 = 1.e-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 836 sqrt_Cd_n10 = sqrt(Cd_n10) 837 Ce_n10 = 1.e-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 838 stab = 0.5 + sign(0.5,zeta) 839 Ch_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1.-stab)) ! L & Y eq. (6c), (6d) 840 841 !! Shifting the neutral 10m transfer coefficients to ( zu , zeta ) : 842 !! 843 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10) - zpsi_m) 844 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 845 ENDIF 846 !! 847 xlogt = log(zu/10.) - zpsi_h 848 !! 849 xct = 1. + Ch_n10*xlogt/kappa/sqrt_Cd_n10 850 Ch = Ch_n10*sqrt_Cd/sqrt_Cd_n10/xct 851 !! 852 xct = 1. + Ce_n10*xlogt/kappa/sqrt_Cd_n10 853 Ce = Ce_n10*sqrt_Cd/sqrt_Cd_n10/xct 854 !! 855 END DO 856 !! 857 CALL wrk_dealloc( jpi,jpj, stab ) ! integer 858 CALL wrk_dealloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 859 CALL wrk_dealloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta, U_n10, xlogt, xct, zpsi_h, zpsi_m ) 860 ! 861 IF( nn_timing == 1 ) CALL timing_stop('TURB_CORE_1Z') 862 ! 863 END SUBROUTINE TURB_CORE_1Z 864 865 866 SUBROUTINE TURB_CORE_2Z(zt, zu, sst, T_zt, q_sat, q_zt, dU, Cd, Ch, Ce, T_zu, q_zu) 867 !!---------------------------------------------------------------------- 868 !! *** ROUTINE turb_core *** 869 !! 870 !! ** Purpose : Computes turbulent transfert coefficients of surface 871 !! fluxes according to Large & Yeager (2004). 872 !! 873 !! ** Method : I N E R T I A L D I S S I P A T I O N M E T H O D 874 !! Momentum, Latent and sensible heat exchange coefficients 875 !! Caution: this procedure should only be used in cases when air 876 !! temperature (T_air) and air specific humidity (q_air) are at a 877 !! different height to wind (dU). 878 !! 879 !! References : Large & Yeager, 2004 : ??? 676 !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) 677 !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu 678 !! 679 !! ** Method : Monin Obukhov Similarity Theory 680 !! + Large & Yeager (2004,2008) closure: CD_n10 = f(U_n10) 681 !! 682 !! ** References : Large & Yeager, 2004 / Large & Yeager, 2008 683 !! 684 !! ** Last update: Laurent Brodeau, June 2014: 685 !! - handles both cases zt=zu and zt/=zu 686 !! - optimized: less 2D arrays allocated and less operations 687 !! - better first guess of stability by checking air-sea difference of virtual temperature 688 !! rather than temperature difference only... 689 !! - added function "cd_neutral_10m" that uses the improved parametrization of 690 !! Large & Yeager 2008. Drag-coefficient reduction for Cyclone conditions! 691 !! - using code-wide physical constants defined into "phycst.mod" rather than redifining them 692 !! => 'vkarmn' and 'grav' 880 693 !!---------------------------------------------------------------------- 881 694 REAL(wp), INTENT(in ) :: zt ! height for T_zt and q_zt [m] … … 885 698 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_sat ! sea surface specific humidity [kg/kg] 886 699 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity [kg/kg] 887 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: dU ! relative wind module |U(zu)-U(0)|[m/s]700 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: dU ! relative wind module at zu [m/s] 888 701 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) 889 702 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) … … 891 704 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: T_zu ! air temp. shifted at zu [K] 892 705 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. hum. shifted at zu [kg/kg] 893 894 INTEGER :: j_itt 895 INTEGER , PARAMETER :: nb_itt = 5 ! number of itterations 896 REAL(wp), PARAMETER :: grav = 9.8 ! gravity 897 REAL(wp), PARAMETER :: kappa = 0.4 ! von Karman's constant 898 899 REAL(wp), DIMENSION(:,:), POINTER :: dU10 ! dU [m/s] 900 REAL(wp), DIMENSION(:,:), POINTER :: dT ! air/sea temperature differeence [K] 901 REAL(wp), DIMENSION(:,:), POINTER :: dq ! air/sea humidity difference [K] 902 REAL(wp), DIMENSION(:,:), POINTER :: Cd_n10 ! 10m neutral drag coefficient 706 ! 707 INTEGER :: j_itt 708 INTEGER , PARAMETER :: nb_itt = 5 ! number of itterations 709 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at different height than U 710 ! 711 REAL(wp), DIMENSION(:,:), POINTER :: U_zu ! relative wind at zu [m/s] 903 712 REAL(wp), DIMENSION(:,:), POINTER :: Ce_n10 ! 10m neutral latent coefficient 904 713 REAL(wp), DIMENSION(:,:), POINTER :: Ch_n10 ! 10m neutral sensible coefficient 905 714 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd_n10 ! root square of Cd_n10 906 715 REAL(wp), DIMENSION(:,:), POINTER :: sqrt_Cd ! root square of Cd 907 REAL(wp), DIMENSION(:,:), POINTER :: T_vpot ! virtual potential temperature [K]908 REAL(wp), DIMENSION(:,:), POINTER :: T_star ! turbulent scale of tem. fluct.909 REAL(wp), DIMENSION(:,:), POINTER :: q_star ! turbulent humidity of temp. fluct.910 REAL(wp), DIMENSION(:,:), POINTER :: U_star ! turb. scale of velocity fluct.911 REAL(wp), DIMENSION(:,:), POINTER :: L ! Monin-Obukov length [m]912 716 REAL(wp), DIMENSION(:,:), POINTER :: zeta_u ! stability parameter at height zu 913 717 REAL(wp), DIMENSION(:,:), POINTER :: zeta_t ! stability parameter at height zt 914 REAL(wp), DIMENSION(:,:), POINTER :: U_n10 ! neutral wind velocity at 10m [m] 915 REAL(wp), DIMENSION(:,:), POINTER :: xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m 916 917 INTEGER , DIMENSION(:,:), POINTER :: stab ! 1st stability test integer 718 REAL(wp), DIMENSION(:,:), POINTER :: zpsi_h_u, zpsi_m_u 719 REAL(wp), DIMENSION(:,:), POINTER :: ztmp0, ztmp1, ztmp2 720 REAL(wp), DIMENSION(:,:), POINTER :: stab ! 1st stability test integer 918 721 !!---------------------------------------------------------------------- 919 ! 920 IF( nn_timing == 1 ) CALL timing_start('TURB_CORE_2Z') 921 ! 922 CALL wrk_alloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 923 CALL wrk_alloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta_u, zeta_t, U_n10 ) 924 CALL wrk_alloc( jpi,jpj, xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m ) 925 CALL wrk_alloc( jpi,jpj, stab ) ! interger 926 927 !! Initial air/sea differences 928 dU10 = max(0.5, dU) ! we don't want to fall under 0.5 m/s 929 dT = T_zt - sst 930 dq = q_zt - q_sat 931 932 !! Neutral Drag Coefficient : 933 stab = 0.5 + sign(0.5,dT) ! stab = 1 if dT > 0 -> STABLE 934 IF( ln_cdgw ) THEN 935 cdn_wave = cdn_wave - rsmall*(tmask(:,:,1)-1) 936 Cd_n10(:,:) = cdn_wave 722 723 IF( nn_timing == 1 ) CALL timing_start('turb_core_2z') 724 725 CALL wrk_alloc( jpi,jpj, U_zu, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd ) 726 CALL wrk_alloc( jpi,jpj, zeta_u, stab ) 727 CALL wrk_alloc( jpi,jpj, zpsi_h_u, zpsi_m_u, ztmp0, ztmp1, ztmp2 ) 728 729 l_zt_equal_zu = .FALSE. 730 IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision 731 732 IF( .NOT. l_zt_equal_zu ) CALL wrk_alloc( jpi,jpj, zeta_t ) 733 734 U_zu = MAX( 0.5 , dU ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s 735 736 !! First guess of stability: 737 ztmp0 = T_zt*(1. + 0.608*q_zt) - sst*(1. + 0.608*q_sat) ! air-sea difference of virtual pot. temp. at zt 738 stab = 0.5 + sign(0.5,ztmp0) ! stab = 1 if dTv > 0 => STABLE, 0 if unstable 739 740 !! Neutral coefficients at 10m: 741 IF( ln_cdgw ) THEN ! wave drag case 742 cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) 743 ztmp0 (:,:) = cdn_wave(:,:) 937 744 ELSE 938 Cd_n10 = 1.e-3*( 2.7/dU10 + 0.142 + dU10/13.09 )745 ztmp0 = cd_neutral_10m( U_zu ) 939 746 ENDIF 940 sqrt_Cd_n10 = sqrt(Cd_n10)747 sqrt_Cd_n10 = SQRT( ztmp0 ) 941 748 Ce_n10 = 1.e-3*( 34.6 * sqrt_Cd_n10 ) 942 749 Ch_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1. - stab)) 943 750 944 751 !! Initializing transf. coeff. with their first guess neutral equivalents : 945 Cd = Cd_n10 ; Ce = Ce_n10 ; Ch = Ch_n10 ; sqrt_Cd = sqrt(Cd)946 947 !! Initializing z_u values with z_t values:948 T_zu = T_zt ;q_zu = q_zt752 Cd = ztmp0 ; Ce = Ce_n10 ; Ch = Ch_n10 ; sqrt_Cd = sqrt_Cd_n10 753 754 !! Initializing values at z_u with z_t values: 755 T_zu = T_zt ; q_zu = q_zt 949 756 950 757 !! * Now starting iteration loop 951 758 DO j_itt=1, nb_itt 952 dT = T_zu - sst ; dq = q_zu - q_sat ! Updating air/sea differences 953 T_vpot = T_zu*(1. + 0.608*q_zu) ! Updating virtual potential temperature at zu 954 U_star = sqrt_Cd*dU10 ! Updating turbulent scales : (L & Y eq. (7)) 955 T_star = Ch/sqrt_Cd*dT ! 956 q_star = Ce/sqrt_Cd*dq ! 957 !! 958 L = (U_star*U_star) & ! Estimate the Monin-Obukov length at height zu 959 & / (kappa*grav/T_vpot*(T_star*(1.+0.608*q_zu) + 0.608*T_zu*q_star)) 759 ! 760 ztmp1 = T_zu - sst ! Updating air/sea differences 761 ztmp2 = q_zu - q_sat 762 763 ! Updating turbulent scales : (L&Y 2004 eq. (7)) 764 ztmp1 = Ch/sqrt_Cd*ztmp1 ! theta* 765 ztmp2 = Ce/sqrt_Cd*ztmp2 ! q* 766 767 ztmp0 = T_zu*(1. + 0.608*q_zu) ! virtual potential temperature at zu 768 769 ! Estimate the inverse of Monin-Obukov length (1/L) at height zu: 770 ztmp0 = (vkarmn*grav/ztmp0*(ztmp1*(1.+0.608*q_zu) + 0.608*T_zu*ztmp2)) / (Cd*U_zu*U_zu) 771 ! ( Cd*U_zu*U_zu is U*^2 at zu) 772 960 773 !! Stability parameters : 961 zeta_u = zu/L ; zeta_u = sign( min(abs(zeta_u),10.0), zeta_u ) 962 zeta_t = zt/L ; zeta_t = sign( min(abs(zeta_t),10.0), zeta_t ) 963 zpsi_hu = psi_h(zeta_u) 964 zpsi_ht = psi_h(zeta_t) 965 zpsi_m = psi_m(zeta_u) 966 !! 967 !! Shifting the wind speed to 10m and neutral stability : L & Y eq.(9a) 968 ! In very rare low-wind conditions, the old way of estimating the 969 ! neutral wind speed at 10m leads to a negative value that causes the code 970 ! to crash. To prevent this a threshold of 0.25m/s is now imposed. 971 U_n10 = MAX( 0.25 , dU10/(1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m)) ) 972 !! 973 !! Shifting temperature and humidity at zu : (L & Y eq. (9b-9c)) 974 ! T_zu = T_zt - T_star/kappa*(log(zt/zu) + psi_h(zeta_u) - psi_h(zeta_t)) 975 T_zu = T_zt - T_star/kappa*(log(zt/zu) + zpsi_hu - zpsi_ht) 976 ! q_zu = q_zt - q_star/kappa*(log(zt/zu) + psi_h(zeta_u) - psi_h(zeta_t)) 977 q_zu = q_zt - q_star/kappa*(log(zt/zu) + zpsi_hu - zpsi_ht) 978 !! 979 !! q_zu cannot have a negative value : forcing 0 980 stab = 0.5 + sign(0.5,q_zu) ; q_zu = stab*q_zu 981 !! 982 IF( ln_cdgw ) THEN 983 sqrt_Cd=kappa/((kappa/sqrt_Cd_n10) - zpsi_m) ; Cd=sqrt_Cd*sqrt_Cd; 774 zeta_u = zu*ztmp0 ; zeta_u = sign( min(abs(zeta_u),10.0), zeta_u ) 775 zpsi_h_u = psi_h( zeta_u ) 776 zpsi_m_u = psi_m( zeta_u ) 777 778 !! Shifting temperature and humidity at zu (L&Y 2004 eq. (9b-9c)) 779 IF ( .NOT. l_zt_equal_zu ) THEN 780 zeta_t = zt*ztmp0 ; zeta_t = sign( min(abs(zeta_t),10.0), zeta_t ) 781 stab = LOG(zu/zt) - zpsi_h_u + psi_h(zeta_t) ! stab just used as temp array!!! 782 T_zu = T_zt + ztmp1/vkarmn*stab ! ztmp1 is still theta* 783 q_zu = q_zt + ztmp2/vkarmn*stab ! ztmp2 is still q* 784 q_zu = max(0., q_zu) 785 END IF 786 787 IF( ln_cdgw ) THEN ! surface wave case 788 sqrt_Cd = vkarmn / ( vkarmn / sqrt_Cd_n10 - zpsi_m_u ) 789 Cd = sqrt_Cd * sqrt_Cd 984 790 ELSE 985 !! Updating the neutral 10m transfer coefficients : 986 Cd_n10 = 1.e-3 * (2.7/U_n10 + 0.142 + U_n10/13.09) ! L & Y eq. (6a) 987 sqrt_Cd_n10 = sqrt(Cd_n10) 988 Ce_n10 = 1.e-3 * (34.6 * sqrt_Cd_n10) ! L & Y eq. (6b) 989 stab = 0.5 + sign(0.5,zeta_u) 990 Ch_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1.-stab)) ! L & Y eq. (6c-6d) 991 !! 992 !! 993 !! Shifting the neutral 10m transfer coefficients to (zu,zeta_u) : 994 xct = 1. + sqrt_Cd_n10/kappa*(log(zu/10.) - zpsi_m) ! L & Y eq. (10a) 995 Cd = Cd_n10/(xct*xct) ; sqrt_Cd = sqrt(Cd) 791 ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 eq. 9a)... 792 ! In very rare low-wind conditions, the old way of estimating the 793 ! neutral wind speed at 10m leads to a negative value that causes the code 794 ! to crash. To prevent this a threshold of 0.25m/s is imposed. 795 ztmp0 = MAX( 0.25 , U_zu/(1. + sqrt_Cd_n10/vkarmn*(LOG(zu/10.) - zpsi_m_u)) ) ! U_n10 796 ztmp0 = cd_neutral_10m(ztmp0) ! Cd_n10 797 sqrt_Cd_n10 = sqrt(ztmp0) 798 799 Ce_n10 = 1.e-3 * (34.6 * sqrt_Cd_n10) ! L&Y 2004 eq. (6b) 800 stab = 0.5 + sign(0.5,zeta_u) ! update stability 801 Ch_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1. - stab)) ! L&Y 2004 eq. (6c-6d) 802 803 !! Update of transfer coefficients: 804 ztmp1 = 1. + sqrt_Cd_n10/vkarmn*(LOG(zu/10.) - zpsi_m_u) ! L&Y 2004 eq. (10a) 805 Cd = ztmp0 / ( ztmp1*ztmp1 ) 806 sqrt_Cd = SQRT( Cd ) 996 807 ENDIF 997 !! 998 xlogt = log(zu/10.) - zpsi_hu 999 !! 1000 xct = 1. + Ch_n10*xlogt/kappa/sqrt_Cd_n10 ! L & Y eq. (10b) 1001 Ch = Ch_n10*sqrt_Cd/sqrt_Cd_n10/xct 1002 !! 1003 xct = 1. + Ce_n10*xlogt/kappa/sqrt_Cd_n10 ! L & Y eq. (10c) 1004 Ce = Ce_n10*sqrt_Cd/sqrt_Cd_n10/xct 1005 !! 1006 !! 808 ! 809 ztmp0 = (LOG(zu/10.) - zpsi_h_u) / vkarmn / sqrt_Cd_n10 810 ztmp2 = sqrt_Cd / sqrt_Cd_n10 811 ztmp1 = 1. + Ch_n10*ztmp0 812 Ch = Ch_n10*ztmp2 / ztmp1 ! L&Y 2004 eq. (10b) 813 ! 814 ztmp1 = 1. + Ce_n10*ztmp0 815 Ce = Ce_n10*ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) 816 ! 1007 817 END DO 1008 !! 1009 CALL wrk_dealloc( jpi,jpj, dU10, dT, dq, Cd_n10, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd, L ) 1010 CALL wrk_dealloc( jpi,jpj, T_vpot, T_star, q_star, U_star, zeta_u, zeta_t, U_n10 ) 1011 CALL wrk_dealloc( jpi,jpj, xlogt, xct, zpsi_hu, zpsi_ht, zpsi_m ) 1012 CALL wrk_dealloc( jpi,jpj, stab ) ! interger 1013 ! 1014 IF( nn_timing == 1 ) CALL timing_stop('TURB_CORE_2Z') 1015 ! 1016 END SUBROUTINE TURB_CORE_2Z 1017 1018 1019 FUNCTION psi_m(zta) !! Psis, L & Y eq. (8c), (8d), (8e) 818 819 CALL wrk_dealloc( jpi,jpj, U_zu, Ce_n10, Ch_n10, sqrt_Cd_n10, sqrt_Cd ) 820 CALL wrk_dealloc( jpi,jpj, zeta_u, stab ) 821 CALL wrk_dealloc( jpi,jpj, zpsi_h_u, zpsi_m_u, ztmp0, ztmp1, ztmp2 ) 822 823 IF( .NOT. l_zt_equal_zu ) CALL wrk_dealloc( jpi,jpj, zeta_t ) 824 825 IF( nn_timing == 1 ) CALL timing_stop('turb_core_2z') 826 ! 827 END SUBROUTINE turb_core_2z 828 829 830 FUNCTION cd_neutral_10m( zw10 ) 831 !!---------------------------------------------------------------------- 832 !! Estimate of the neutral drag coefficient at 10m as a function 833 !! of neutral wind speed at 10m 834 !! 835 !! Origin: Large & Yeager 2008 eq.(11a) and eq.(11b) 836 !! 837 !! Author: L. Brodeau, june 2014 838 !!---------------------------------------------------------------------- 839 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zw10 ! scalar wind speed at 10m (m/s) 840 REAL(wp), DIMENSION(jpi,jpj) :: cd_neutral_10m 841 ! 842 REAL(wp), DIMENSION(:,:), POINTER :: rgt33 843 !!---------------------------------------------------------------------- 844 ! 845 CALL wrk_alloc( jpi,jpj, rgt33 ) 846 ! 847 !! When wind speed > 33 m/s => Cyclone conditions => special treatment 848 rgt33 = 0.5_wp + SIGN( 0.5_wp, (zw10 - 33._wp) ) ! If zw10 < 33. => 0, else => 1 849 cd_neutral_10m = 1.e-3 * ( & 850 & (rgt33 + 1._wp)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33. 851 & + rgt33 * 2.34 ) ! zw10 >= 33. 852 ! 853 CALL wrk_dealloc( jpi,jpj, rgt33) 854 ! 855 END FUNCTION cd_neutral_10m 856 857 858 FUNCTION psi_m(pta) !! Psis, L&Y 2004 eq. (8c), (8d), (8e) 1020 859 !------------------------------------------------------------------------------- 1021 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zta 1022 1023 REAL(wp), PARAMETER :: pi = 3.141592653589793_wp 860 ! universal profile stability function for momentum 861 !------------------------------------------------------------------------------- 862 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta 863 ! 1024 864 REAL(wp), DIMENSION(jpi,jpj) :: psi_m 1025 865 REAL(wp), DIMENSION(:,:), POINTER :: X2, X, stabit 1026 866 !------------------------------------------------------------------------------- 1027 867 ! 1028 868 CALL wrk_alloc( jpi,jpj, X2, X, stabit ) 1029 1030 X2 = sqrt(abs(1. - 16.*zta)) ; X2 = max(X2 , 1.0) ; X = sqrt(X2)1031 stabit = 0.5 + sign(0.5,zta)1032 psi_m = -5.* zta*stabit & ! Stable1033 & + (1. - stabit)*(2 *log((1. + X)/2) + log((1. + X2)/2) - 2*atan(X) + pi/2) ! Unstable1034 869 ! 870 X2 = SQRT( ABS( 1. - 16.*pta ) ) ; X2 = MAX( X2 , 1. ) ; X = SQRT( X2 ) 871 stabit = 0.5 + SIGN( 0.5 , pta ) 872 psi_m = -5.*pta*stabit & ! Stable 873 & + (1. - stabit)*(2.*LOG((1. + X)*0.5) + LOG((1. + X2)*0.5) - 2.*ATAN(X) + rpi*0.5) ! Unstable 874 ! 1035 875 CALL wrk_dealloc( jpi,jpj, X2, X, stabit ) 1036 876 ! 1037 1038 1039 1040 FUNCTION psi_h( zta ) !! Psis, L & Yeq. (8c), (8d), (8e)877 END FUNCTION psi_m 878 879 880 FUNCTION psi_h( pta ) !! Psis, L&Y 2004 eq. (8c), (8d), (8e) 1041 881 !------------------------------------------------------------------------------- 1042 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zta 882 ! universal profile stability function for temperature and humidity 883 !------------------------------------------------------------------------------- 884 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta 1043 885 ! 1044 886 REAL(wp), DIMENSION(jpi,jpj) :: psi_h 1045 REAL(wp), DIMENSION(:,:), POINTER :: X2, X, stabit887 REAL(wp), DIMENSION(:,:), POINTER :: X2, X, stabit 1046 888 !------------------------------------------------------------------------------- 1047 889 ! 1048 890 CALL wrk_alloc( jpi,jpj, X2, X, stabit ) 1049 1050 X2 = sqrt(abs(1. - 16.*zta)) ; X2 = max(X2 , 1.) ; X = sqrt(X2)1051 stabit = 0.5 + sign(0.5,zta)1052 psi_h = -5.* zta*stabit& ! Stable1053 & + (1. - stabit)*(2.* log( (1. + X2)/2. ))! Unstable1054 891 ! 892 X2 = SQRT( ABS( 1. - 16.*pta ) ) ; X2 = MAX( X2 , 1. ) ; X = SQRT( X2 ) 893 stabit = 0.5 + SIGN( 0.5 , pta ) 894 psi_h = -5.*pta*stabit & ! Stable 895 & + (1. - stabit)*(2.*LOG( (1. + X2)*0.5 )) ! Unstable 896 ! 1055 897 CALL wrk_dealloc( jpi,jpj, X2, X, stabit ) 1056 898 ! 1057 1058 899 END FUNCTION psi_h 900 1059 901 !!====================================================================== 1060 902 END MODULE sbcblk_core -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_mfs.F90
r4724 r4946 82 82 !! - utau, vtau i- and j-component of the wind stress 83 83 !! - taum wind stress module at T-point 84 !! - wndm 10m wind module at T-point 84 !! - wndm 10m wind module at T-point over free ocean or leads in presence of sea-ice 85 85 !! - qns, qsr non-slor and solar heat flux 86 86 !! - emp evaporation minus precipitation -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r4924 r4946 9 9 !! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields 10 10 !!---------------------------------------------------------------------- 11 #if defined key_oasis3 || defined key_oasis412 !!----------------------------------------------------------------------13 !! 'key_oasis3' or 'key_oasis4' Coupled Ocean/Atmosphere formulation14 11 !!---------------------------------------------------------------------- 15 12 !! namsbc_cpl : coupled formulation namlist … … 34 31 USE ice_2 ! ice variables 35 32 #endif 36 #if defined key_oasis337 33 USE cpl_oasis3 ! OASIS3 coupling 38 #endif39 #if defined key_oasis440 USE cpl_oasis4 ! OASIS4 coupling41 #endif42 34 USE geo2ocean ! 43 35 USE oce , ONLY : tsn, un, vn … … 58 50 IMPLICIT NONE 59 51 PRIVATE 60 52 !EM XIOS-OASIS-MCT compliance 53 PUBLIC sbc_cpl_init ! routine called by sbcmod.F90 61 54 PUBLIC sbc_cpl_rcv ! routine called by sbc_ice_lim(_2).F90 62 55 PUBLIC sbc_cpl_snd ! routine called by step.F90 … … 129 122 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf 130 123 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2 124 ! Other namelist parameters ! 125 INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 126 LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models 127 ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 128 129 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: xcplmask 131 130 132 131 TYPE :: DYNARR … … 139 138 140 139 INTEGER , ALLOCATABLE, SAVE, DIMENSION( :) :: nrcvinfo ! OASIS info argument 141 142 #if ! defined key_lim2 && ! defined key_lim3143 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice,fr1_i0,fr2_i0 ! jpi, jpj144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl)145 #endif146 147 #if defined key_cice148 INTEGER, PARAMETER :: jpl = ncat149 #elif ! defined key_lim2 && ! defined key_lim3150 INTEGER, PARAMETER :: jpl = 1151 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice153 #endif154 155 #if ! defined key_lim3 && ! defined key_cice156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i157 #endif158 159 #if ! defined key_lim3160 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ht_i, ht_s161 #endif162 163 #if ! defined key_cice164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt165 #endif166 140 167 141 !! Substitution … … 179 153 !! *** FUNCTION sbc_cpl_alloc *** 180 154 !!---------------------------------------------------------------------- 181 INTEGER :: ierr( 4),jn155 INTEGER :: ierr(3) 182 156 !!---------------------------------------------------------------------- 183 157 ierr(:) = 0 184 158 ! 185 159 ALLOCATE( albedo_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) 186 ! 187 #if ! defined key_lim2 && ! defined key_lim3 188 ! quick patch to be able to run the coupled model without sea-ice... 189 ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , & 190 v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,1), & 191 emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , STAT=ierr(2) ) 160 161 #if ! defined key_lim3 && ! defined key_lim2 && ! defined key_cice 162 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 192 163 #endif 193 194 #if ! defined key_lim3 && ! defined key_cice 195 ALLOCATE( a_i(jpi,jpj,jpl) , STAT=ierr(3) ) 196 #endif 197 198 #if defined key_cice || defined key_lim2 199 ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(4) ) 200 #endif 164 ALLOCATE( xcplmask(jpi,jpj,nn_cplmodel) , STAT=ierr(3) ) 165 ! 201 166 sbc_cpl_alloc = MAXVAL( ierr ) 202 167 IF( lk_mpp ) CALL mpp_sum ( sbc_cpl_alloc ) … … 210 175 !! *** ROUTINE sbc_cpl_init *** 211 176 !! 212 !! ** Purpose : Initialisation of send and rec ieved information from177 !! ** Purpose : Initialisation of send and received information from 213 178 !! the atmospheric component 214 179 !! … … 222 187 INTEGER :: jn ! dummy loop index 223 188 INTEGER :: ios ! Local integer output status for namelist read 189 INTEGER :: inum 224 190 REAL(wp), POINTER, DIMENSION(:,:) :: zacs, zaos 225 191 !! 226 NAMELIST/namsbc_cpl/ sn_snd_temp, sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & 227 & sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, & 228 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx , sn_rcv_co2 192 NAMELIST/namsbc_cpl/ sn_snd_temp, sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & 193 & sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, & 194 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx, & 195 & sn_rcv_co2 , nn_cplmodel , ln_usecplmask 229 196 !!--------------------------------------------------------------------- 230 197 ! … … 274 241 WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd 275 242 WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' 243 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel 244 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask 276 245 ENDIF 277 246 … … 485 454 END DO 486 455 ! Allocate taum part of frcv which is used even when not received as coupling field 487 IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(j n)%nct) )456 IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) 488 457 ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. 489 458 IF( k_ice /= 0 ) THEN 490 IF ( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(j n)%nct) )491 IF ( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(j n)%nct) )459 IF ( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) ) 460 IF ( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) ) 492 461 END IF 493 462 … … 604 573 ! ================================ ! 605 574 606 CALL cpl_prism_define(jprcv, jpsnd) 607 ! 608 IF( ln_dm2dc .AND. ( cpl_prism_freq( jpr_qsroce ) + cpl_prism_freq( jpr_qsrmix ) /= 86400 ) ) & 575 CALL cpl_define(jprcv, jpsnd,nn_cplmodel) 576 IF (ln_usecplmask) THEN 577 xcplmask(:,:,:) = 0. 578 CALL iom_open( 'cplmask', inum ) 579 CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:nlci,1:nlcj,1:nn_cplmodel), & 580 & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) ) 581 CALL iom_close( inum ) 582 ELSE 583 xcplmask(:,:,:) = 1. 584 ENDIF 585 ! 586 IF( ln_dm2dc .AND. ( cpl_freq( jpr_qsroce ) + cpl_freq( jpr_qsrmix ) /= 86400 ) ) & 609 587 & CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 610 588 … … 654 632 !! 655 633 !! ** Action : update utau, vtau ocean stress at U,V grid 656 !! taum, wndm wind stres and wind speed module at T-point 634 !! taum wind stress module at T-point 635 !! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice 657 636 !! qns non solar heat fluxes including emp heat content (ocean only case) 658 637 !! and the latent heat flux of solid precip. melting … … 678 657 ! 679 658 CALL wrk_alloc( jpi,jpj, ztx, zty ) 680 681 IF( kt == nit000 ) CALL sbc_cpl_init( k_ice ) ! initialisation682 683 659 ! ! Receive all the atmos. fields (including ice information) 684 660 isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges 685 661 DO jn = 1, jprcv ! received fields sent by the atmosphere 686 IF( srcv(jn)%laction ) CALL cpl_ prism_rcv( jn, isec, frcv(jn)%z3, nrcvinfo(jn) )662 IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask, nrcvinfo(jn) ) 687 663 END DO 688 664 … … 848 824 IF( srcv(jpr_qnsoce)%laction ) qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 849 825 IF( srcv(jpr_qnsmix)%laction ) qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 850 ! add the latent heat of solid precip. melting851 IF( srcv(jpr_snow )%laction ) THEN ! update qns over the free ocean with:852 qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus & ! energy for melting solid precipitation over the free ocean853 & - emp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST)826 ! update qns over the free ocean with: 827 qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) 828 IF( srcv(jpr_snow )%laction ) THEN 829 qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus ! energy for melting solid precipitation over the free ocean 854 830 ENDIF 855 831 … … 914 890 CALL wrk_alloc( jpi,jpj, ztx, zty ) 915 891 916 !AC Pour eviter un stress nul sur la glace dans le cas mixed oce-ice 917 IF( srcv(jpr_itx1)%laction .AND. TRIM( sn_rcv_tau%cldes ) == 'oce and ice') THEN ; itx = jpr_itx1 892 IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 918 893 ELSE ; itx = jpr_otx1 919 894 ENDIF … … 922 897 IF( nrcvinfo(itx) == OASIS_Rcv ) THEN 923 898 924 ! ! ======================= ! 925 !AC Pour eviter un stress nul sur la glace dans le cas mixes oce-ice 926 IF( srcv(jpr_itx1)%laction .AND. TRIM( sn_rcv_tau%cldes ) == 'oce and ice') THEN ! ice stress received ! 927 ! ! ======================= ! 899 ! ! ======================= ! 900 IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received ! 901 ! ! ======================= ! 928 902 ! 929 903 IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere … … 1125 1099 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1] 1126 1100 ! optional arguments, used only in 'mixed oce-ice' case 1127 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! ice albedo1128 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Cel cius]1101 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1102 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1129 1103 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1130 1104 ! … … 1296 1270 ENDIF 1297 1271 1298 SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) 1272 ! ! ========================= ! 1273 SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) ! d(qns)/dt ! 1274 ! ! ========================= ! 1299 1275 CASE ('coupled') 1300 1276 IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN … … 1308 1284 END SELECT 1309 1285 1310 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) 1286 ! ! ========================= ! 1287 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt ! 1288 ! ! ========================= ! 1311 1289 CASE ('coupled') 1312 1290 topmelt(:,:,:)=frcv(jpr_topm)%z3(:,:,:) … … 1314 1292 END SELECT 1315 1293 1316 ! Ice Qsr penetration used (only?)in lim2 or lim3 1317 ! fraction of net shortwave radiation which is not absorbed in the thin surface layer 1318 ! and penetrates inside the ice cover ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 ) 1294 ! Surface transimission parameter io (Maykut Untersteiner , 1971 ; Ebert and Curry, 1993 ) 1295 ! Used for LIM2 and LIM3 1319 1296 ! Coupled case: since cloud cover is not received from atmosphere 1320 ! ===> defined as constant value -> definition done in sbc_cpl_init 1321 fr1_i0(:,:) = 0.18 1322 fr2_i0(:,:) = 0.82 1323 1297 ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 1298 fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 1299 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1324 1300 1325 1301 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr ) … … 1336 1312 !! ** Purpose : provide the ocean-ice informations to the atmosphere 1337 1313 !! 1338 !! ** Method : send to the atmosphere through a call to cpl_ prism_snd1314 !! ** Method : send to the atmosphere through a call to cpl_snd 1339 1315 !! all the needed fields (as defined in sbc_cpl_init) 1340 1316 !!---------------------------------------------------------------------- … … 1355 1331 1356 1332 zfr_l(:,:) = 1.- fr_i(:,:) 1357 1358 1333 ! ! ------------------------- ! 1359 1334 ! ! Surface temperature ! in Kelvin … … 1380 1355 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 1381 1356 END SELECT 1382 IF( ssnd(jps_toce)%laction ) CALL cpl_prism_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1383 IF( ssnd(jps_tice)%laction ) CALL cpl_prism_snd( jps_tice, isec, ztmp3, info ) 1384 IF( ssnd(jps_tmix)%laction ) CALL cpl_prism_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1385 ENDIF 1386 ! 1357 IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1358 IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info ) 1359 IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1360 ENDIF 1387 1361 ! ! ------------------------- ! 1388 1362 ! ! Albedo ! … … 1390 1364 IF( ssnd(jps_albice)%laction ) THEN ! ice 1391 1365 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1392 CALL cpl_ prism_snd( jps_albice, isec, ztmp3, info )1366 CALL cpl_snd( jps_albice, isec, ztmp3, info ) 1393 1367 ENDIF 1394 1368 IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean … … 1397 1371 ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) 1398 1372 ENDDO 1399 CALL cpl_ prism_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )1373 CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1400 1374 ENDIF 1401 1375 ! ! ------------------------- ! … … 1409 1383 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 1410 1384 END SELECT 1411 CALL cpl_ prism_snd( jps_fice, isec, ztmp3, info )1385 CALL cpl_snd( jps_fice, isec, ztmp3, info ) 1412 1386 ENDIF 1413 1387 … … 1434 1408 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 1435 1409 END SELECT 1436 IF( ssnd(jps_hice)%laction ) CALL cpl_ prism_snd( jps_hice, isec, ztmp3, info )1437 IF( ssnd(jps_hsnw)%laction ) CALL cpl_ prism_snd( jps_hsnw, isec, ztmp4, info )1410 IF( ssnd(jps_hice)%laction ) CALL cpl_snd( jps_hice, isec, ztmp3, info ) 1411 IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info ) 1438 1412 ENDIF 1439 1413 ! … … 1442 1416 ! ! CO2 flux from PISCES ! 1443 1417 ! ! ------------------------- ! 1444 IF( ssnd(jps_co2)%laction ) CALL cpl_ prism_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info )1418 IF( ssnd(jps_co2)%laction ) CALL cpl_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info ) 1445 1419 ! 1446 1420 #endif … … 1565 1539 ENDIF 1566 1540 ! 1567 IF( ssnd(jps_ocx1)%laction ) CALL cpl_ prism_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid1568 IF( ssnd(jps_ocy1)%laction ) CALL cpl_ prism_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid1569 IF( ssnd(jps_ocz1)%laction ) CALL cpl_ prism_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid1541 IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid 1542 IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid 1543 IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid 1570 1544 ! 1571 IF( ssnd(jps_ivx1)%laction ) CALL cpl_ prism_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid1572 IF( ssnd(jps_ivy1)%laction ) CALL cpl_ prism_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid1573 IF( ssnd(jps_ivz1)%laction ) CALL cpl_ prism_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid1545 IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid 1546 IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid 1547 IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid 1574 1548 ! 1575 1549 ENDIF … … 1582 1556 END SUBROUTINE sbc_cpl_snd 1583 1557 1584 #else1585 !!----------------------------------------------------------------------1586 !! Dummy module NO coupling1587 !!----------------------------------------------------------------------1588 USE par_kind ! kind definition1589 CONTAINS1590 SUBROUTINE sbc_cpl_snd( kt )1591 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?', kt1592 END SUBROUTINE sbc_cpl_snd1593 !1594 SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice )1595 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?', kt, k_fsbc, k_ice1596 END SUBROUTINE sbc_cpl_rcv1597 !1598 SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj )1599 REAL(wp), INTENT(out), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2]1600 REAL(wp), INTENT(out), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid)1601 p_taui(:,:) = 0. ; p_tauj(:,:) = 0. ! stupid definition to avoid warning message when compiling...1602 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?'1603 END SUBROUTINE sbc_cpl_ice_tau1604 !1605 SUBROUTINE sbc_cpl_ice_flx( p_frld , palbi , psst , pist )1606 REAL(wp), INTENT(in ), DIMENSION(:,: ) :: p_frld ! lead fraction [0 to 1]1607 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! ice albedo1608 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celcius]1609 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin]1610 WRITE(*,*) 'sbc_cpl_snd: You should not have seen this print! error?', p_frld(1,1), palbi(1,1,1), psst(1,1), pist(1,1,1)1611 END SUBROUTINE sbc_cpl_ice_flx1612 1613 #endif1614 1615 1558 !!====================================================================== 1616 1559 END MODULE sbccpl -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90
r4924 r4946 91 91 area = glob_sum( e1e2t(:,:) ) ! interior global domain surface 92 92 ! 93 #if ! defined key_lim2 && ! defined key_lim3 && ! defined key_cice 93 #if ! defined key_lim2 && ! defined key_lim3 && ! defined key_cice 94 94 snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass 95 95 snwice_mass (:,:) = 0.e0 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
r4627 r4946 17 17 USE phycst, only : rcp, rau0, r1_rau0, rhosn, rhoic 18 18 USE in_out_manager ! I/O manager 19 USE iom, only : iom_put ! I/O manager library !!Joakim edit 19 20 USE lib_mpp ! distributed memory computing library 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 23 24 USE daymod ! calendar 24 25 USE fldread ! read input fields 25 26 26 USE sbc_oce ! Surface boundary condition: ocean fields 27 27 USE sbc_ice ! Surface boundary condition: ice fields … … 38 38 USE ice_calendar, only: dt 39 39 USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen 40 # if defined key_cice4 40 41 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 41 42 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, & … … 44 45 uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & 45 46 swvdr,swvdf,swidr,swidf 47 USE ice_therm_vertical, only: calc_Tsfc 48 #else 49 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 50 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, & 51 fresh_ai,fhocn_ai,fswthru_ai,frzmlt, & 52 flatn_f,fsurfn_f,fcondtopn_f, & 53 uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & 54 swvdr,swvdf,swidr,swidf 55 USE ice_therm_shared, only: calc_Tsfc 56 #endif 46 57 USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf 47 58 USE ice_atmo, only: calc_strair 48 USE ice_therm_vertical, only: calc_Tsfc49 59 50 60 USE CICE_InitMod … … 95 105 END FUNCTION sbc_ice_cice_alloc 96 106 97 SUBROUTINE sbc_ice_cice( kt, nsbc )107 SUBROUTINE sbc_ice_cice( kt, ksbc ) 98 108 !!--------------------------------------------------------------------- 99 109 !! *** ROUTINE sbc_ice_cice *** … … 113 123 !!--------------------------------------------------------------------- 114 124 INTEGER, INTENT(in) :: kt ! ocean time step 115 INTEGER, INTENT(in) :: nsbc ! surface forcing type125 INTEGER, INTENT(in) :: ksbc ! surface forcing type 116 126 !!---------------------------------------------------------------------- 117 127 ! … … 123 133 124 134 ! Make sure any fluxes required for CICE are set 125 IF ( nsbc == 2 )THEN135 IF ( ksbc == jp_flx ) THEN 126 136 CALL cice_sbc_force(kt) 127 ELSE IF ( nsbc == 5) THEN137 ELSE IF ( ksbc == jp_cpl ) THEN 128 138 CALL sbc_cpl_ice_flx( 1.0-fr_i ) 129 139 ENDIF 130 140 131 CALL cice_sbc_in ( kt, nsbc )141 CALL cice_sbc_in ( kt, ksbc ) 132 142 CALL CICE_Run 133 CALL cice_sbc_out ( kt, nsbc )134 135 IF ( nsbc == 5) CALL cice_sbc_hadgam(kt+1)143 CALL cice_sbc_out ( kt, ksbc ) 144 145 IF ( ksbc == jp_cpl ) CALL cice_sbc_hadgam(kt+1) 136 146 137 147 ENDIF ! End sea-ice time step only … … 141 151 END SUBROUTINE sbc_ice_cice 142 152 143 SUBROUTINE cice_sbc_init ( nsbc)153 SUBROUTINE cice_sbc_init (ksbc) 144 154 !!--------------------------------------------------------------------- 145 155 !! *** ROUTINE cice_sbc_init *** 146 156 !! ** Purpose: Initialise ice related fields for NEMO and coupling 147 157 !! 148 INTEGER, INTENT( in ) :: nsbc ! surface forcing type158 INTEGER, INTENT( in ) :: ksbc ! surface forcing type 149 159 REAL(wp), DIMENSION(:,:), POINTER :: ztmp1, ztmp2 150 160 REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar 151 INTEGER :: ji, jj, jl 161 INTEGER :: ji, jj, jl, jk ! dummy loop indices 152 162 !!--------------------------------------------------------------------- 153 163 … … 161 171 jj_off = INT ( (jpjglo - ny_global) / 2 ) 162 172 173 #if defined key_nemocice_decomp 174 ! Pass initial SST from NEMO to CICE so ice is initialised correctly if 175 ! there is no restart file. 176 ! Values from a CICE restart file would overwrite this 177 IF ( .NOT. ln_rstart ) THEN 178 CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.) 179 ENDIF 180 #endif 181 163 182 ! Initialize CICE 164 183 CALL CICE_Initialize 165 184 166 185 ! Do some CICE consistency checks 167 IF ( ( nsbc == 2) .OR. (nsbc == 5) ) THEN186 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 168 187 IF ( calc_strair .OR. calc_Tsfc ) THEN 169 188 CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) 170 189 ENDIF 171 ELSEIF ( nsbc == 4) THEN190 ELSEIF (ksbc == jp_core) THEN 172 191 IF ( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN 173 192 CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' ) … … 190 209 191 210 CALL cice2nemo(aice,fr_i, 'T', 1. ) 192 IF ( ( nsbc == 2).OR.(nsbc == 5) ) THEN211 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_cpl) ) THEN 193 212 DO jl=1,ncat 194 213 CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) … … 218 237 snwice_mass_b(:,:) = 0.0_wp ! no mass exchanges 219 238 ENDIF 220 IF( nn_ice_embd == 2 .AND. & ! full embedment (case 2) & no restart : 221 & .NOT.ln_rstart ) THEN ! deplete the initial ssh belew sea-ice area 222 sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 223 sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 224 ! 239 IF( .NOT. ln_rstart ) THEN 240 IF( nn_ice_embd == 2 ) THEN ! full embedment (case 2) deplete the initial ssh below sea-ice area 241 sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 242 sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 243 #if defined key_vvl 244 ! key_vvl necessary? clem: yes for compilation purpose 245 DO jk = 1,jpkm1 ! adjust initial vertical scale factors 246 fse3t_n(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshn(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 247 fse3t_b(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshb(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 248 ENDDO 249 fse3t_a(:,:,:) = fse3t_b(:,:,:) 250 ! Reconstruction of all vertical scale factors at now and before time 251 ! steps 252 ! ============================================================================= 253 ! Horizontal scale factor interpolations 254 ! -------------------------------------- 255 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 256 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 257 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 258 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 259 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' ) 260 ! Vertical scale factor interpolations 261 ! ------------------------------------ 262 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 263 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 264 CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 265 CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 266 CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 267 ! t- and w- points depth 268 ! ---------------------- 269 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 270 fsdepw_n(:,:,1) = 0.0_wp 271 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 272 DO jk = 2, jpk 273 fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 274 fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 275 fsde3w_n(:,:,jk) = fsdept_n(:,:,jk ) - sshn (:,:) 276 END DO 277 #endif 278 ENDIF 225 279 ENDIF 226 280 … … 232 286 233 287 234 SUBROUTINE cice_sbc_in (kt, nsbc)288 SUBROUTINE cice_sbc_in (kt, ksbc) 235 289 !!--------------------------------------------------------------------- 236 290 !! *** ROUTINE cice_sbc_in *** … … 238 292 !!--------------------------------------------------------------------- 239 293 INTEGER, INTENT(in ) :: kt ! ocean time step 240 INTEGER, INTENT(in ) :: nsbc ! surface forcing type294 INTEGER, INTENT(in ) :: ksbc ! surface forcing type 241 295 242 296 INTEGER :: ji, jj, jl ! dummy loop indices … … 262 316 ! forced and coupled case 263 317 264 IF ( ( nsbc == 2).OR.(nsbc == 5) ) THEN318 IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 265 319 266 320 ztmpn(:,:,:)=0.0 … … 287 341 288 342 ! Surface downward latent heat flux (CI_5) 289 IF ( nsbc == 2) THEN343 IF (ksbc == jp_flx) THEN 290 344 DO jl=1,ncat 291 345 ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl) … … 316 370 ! GBM conductive flux through ice (CI_6) 317 371 ! Convert to GBM 318 IF ( nsbc == 2) THEN372 IF (ksbc == jp_flx) THEN 319 373 ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl) 320 374 ELSE … … 325 379 ! GBM surface heat flux (CI_7) 326 380 ! Convert to GBM 327 IF ( nsbc == 2) THEN381 IF (ksbc == jp_flx) THEN 328 382 ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) 329 383 ELSE … … 333 387 ENDDO 334 388 335 ELSE IF ( nsbc == 4) THEN389 ELSE IF (ksbc == jp_core) THEN 336 390 337 391 ! Pass CORE forcing fields to CICE (which will calculate heat fluxes etc itself) … … 375 429 376 430 ! Snowfall 377 ! Ensure fsnow is positive (as in CICE routine prepare_forcing) 431 ! Ensure fsnow is positive (as in CICE routine prepare_forcing) 432 CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit 378 433 ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) 379 434 CALL nemo2cice(ztmp,fsnow,'T', 1. ) 380 435 381 436 ! Rainfall 437 CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit 382 438 ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 383 439 CALL nemo2cice(ztmp,frain,'T', 1. ) … … 458 514 459 515 460 SUBROUTINE cice_sbc_out (kt, nsbc)516 SUBROUTINE cice_sbc_out (kt,ksbc) 461 517 !!--------------------------------------------------------------------- 462 518 !! *** ROUTINE cice_sbc_out *** … … 464 520 !!--------------------------------------------------------------------- 465 521 INTEGER, INTENT( in ) :: kt ! ocean time step 466 INTEGER, INTENT( in ) :: nsbc ! surface forcing type522 INTEGER, INTENT( in ) :: ksbc ! surface forcing type 467 523 468 524 INTEGER :: ji, jj, jl ! dummy loop indices … … 510 566 ! Freshwater fluxes 511 567 512 IF ( nsbc == 2) THEN568 IF (ksbc == jp_flx) THEN 513 569 ! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip) 514 570 ! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below … … 516 572 ! Better to use evap and tprecip? (but for now don't read in evap in this case) 517 573 emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 518 ELSE IF ( nsbc == 4) THEN574 ELSE IF (ksbc == jp_core) THEN 519 575 emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) 520 ELSE IF ( nsbc ==5) THEN576 ELSE IF (ksbc == jp_cpl) THEN 521 577 ! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 522 578 ! This is currently as required with the coupling fields from the UM atmosphere … … 524 580 ENDIF 525 581 582 #if defined key_cice4 526 583 CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. ) 527 584 CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. ) 585 #else 586 CALL cice2nemo(fresh_ai,ztmp1,'T', 1. ) 587 CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. ) 588 #endif 528 589 529 590 ! Check to avoid unphysical expression when ice is forming (ztmp1 negative) … … 535 596 sfx(:,:)=ztmp2(:,:)*1000.0 536 597 emp(:,:)=emp(:,:)-ztmp1(:,:) 537 598 fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 599 538 600 CALL lbc_lnk( emp , 'T', 1. ) 539 601 CALL lbc_lnk( sfx , 'T', 1. ) … … 543 605 ! Scale qsr and qns according to ice fraction (bulk formulae only) 544 606 545 IF ( nsbc == 4) THEN607 IF (ksbc == jp_core) THEN 546 608 qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:)) 547 609 qns(:,:)=qns(:,:)*(1.0-fr_i(:,:)) 548 610 ENDIF 549 611 ! Take into account snow melting except for fully coupled when already in qns_tot 550 IF ( nsbc == 5) THEN612 IF (ksbc == jp_cpl) THEN 551 613 qsr(:,:)= qsr_tot(:,:) 552 614 qns(:,:)= qns_tot(:,:) … … 557 619 ! Now add in ice / snow related terms 558 620 ! [fswthru will be zero unless running with calc_Tsfc=T in CICE] 621 #if defined key_cice4 559 622 CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. ) 623 #else 624 CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. ) 625 #endif 560 626 qsr(:,:)=qsr(:,:)+ztmp1(:,:) 561 627 CALL lbc_lnk( qsr , 'T', 1. ) … … 567 633 ENDDO 568 634 635 #if defined key_cice4 569 636 CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. ) 637 #else 638 CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. ) 639 #endif 570 640 qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:) 571 641 … … 575 645 576 646 CALL cice2nemo(aice,fr_i,'T', 1. ) 577 IF ( ( nsbc == 2).OR.(nsbc == 5) ) THEN647 IF ( (ksbc == jp_flx).OR.(ksbc == jp_cpl) ) THEN 578 648 DO jl=1,ncat 579 649 CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) … … 611 681 612 682 613 #if defined key_oasis3 || defined key_oasis4614 683 SUBROUTINE cice_sbc_hadgam( kt ) 615 684 !!--------------------------------------------------------------------- … … 653 722 END SUBROUTINE cice_sbc_hadgam 654 723 655 #else656 SUBROUTINE cice_sbc_hadgam( kt ) ! Dummy routine657 INTEGER, INTENT( in ) :: kt ! ocean time step658 WRITE(*,*) 'cice_sbc_hadgam: You should not have seen this print! error?'659 END SUBROUTINE cice_sbc_hadgam660 #endif661 724 662 725 SUBROUTINE cice_sbc_final … … 713 776 IF( kt == nit000 ) THEN ! First call kt=nit000 ! 714 777 ! ! ====================== ! 778 ! namsbc_cice is not yet in the reference namelist 779 ! set file information (default values) 780 cn_dir = './' ! directory in which the model is executed 781 782 ! (NB: frequency positive => hours, negative => months) 783 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask 784 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file 785 sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 786 sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 787 sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' ) 788 sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) 789 sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) 790 sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) 791 sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) 792 sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) 793 sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) 794 sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) 795 sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) 796 sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) 797 sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) 798 715 799 REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : 716 800 READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) … … 1001 1085 CONTAINS 1002 1086 1003 SUBROUTINE sbc_ice_cice ( kt, nsbc ) ! Dummy routine1087 SUBROUTINE sbc_ice_cice ( kt, ksbc ) ! Dummy routine 1004 1088 WRITE(*,*) 'sbc_ice_cice: You should not have seen this print! error?', kt 1005 1089 END SUBROUTINE sbc_ice_cice 1006 1090 1007 SUBROUTINE cice_sbc_init ( nsbc) ! Dummy routine1091 SUBROUTINE cice_sbc_init (ksbc) ! Dummy routine 1008 1092 WRITE(*,*) 'cice_sbc_init: You should not have seen this print! error?' 1009 1093 END SUBROUTINE cice_sbc_init -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90
r4624 r4946 16 16 USE eosbn2 ! equation of state 17 17 USE sbc_oce ! surface boundary condition: ocean fields 18 USE sbccpl 18 #if defined key_lim3 19 USE ice , ONLY : a_i 20 #else 21 USE sbc_ice, ONLY : a_i 22 #endif 19 23 USE fldread ! read input field 20 24 USE iom ! I/O manager library … … 99 103 ! ( d rho / dt ) / ( d rho / ds ) ( s = 34, t = -1.8 ) 100 104 101 fr_i(:,:) = tfreez( sss_m ) * tmask(:,:,1) ! sea surface freezing temperature [Celcius]105 fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1) ! sea surface freezing temperature [Celcius] 102 106 103 ! OM : probleme. a_i pas defini dans les cas lim3 et cice 104 #if defined key_coupled && defined key_lim2 105 a_i(:,:,1) = fr_i(:,:) 106 #endif 107 IF( lk_cpl ) a_i(:,:,1) = fr_i(:,:) 107 108 108 109 ! Flux and ice fraction computation 109 !CDIR COLLAPSE110 110 DO jj = 1, jpj 111 111 DO ji = 1, jpi -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r4924 r4946 12 12 !! 3.4 ! 2011-01 (A Porter) dynamical allocation 13 13 !! - ! 2012-10 (C. Rousset) add lim_diahsb 14 !! 3.6 ! 2014-07 (M. Vancoppenolle, G. Madec, O. Marti) revise coupled interface 14 15 !!---------------------------------------------------------------------- 15 16 #if defined key_lim3 … … 59 60 USE prtctl ! Print control 60 61 USE lib_fortran ! 61 USE cpl_oasis3, ONLY : lk_cpl62 62 63 63 #if defined key_bdy … … 80 80 !!---------------------------------------------------------------------- 81 81 CONTAINS 82 83 FUNCTION fice_cell_ave ( ptab)84 !!--------------------------------------------------------------------------85 !! * Compute average over categories, for grid cell (ice covered and free ocean)86 !!--------------------------------------------------------------------------87 REAL (wp), DIMENSION (jpi,jpj) :: fice_cell_ave88 REAL (wp), DIMENSION (jpi,jpj,jpl), INTENT (in) :: ptab89 INTEGER :: jl ! Dummy loop index90 91 fice_cell_ave (:,:) = 0.0_wp92 93 DO jl = 1, jpl94 fice_cell_ave (:,:) = fice_cell_ave (:,:) &95 & + a_i (:,:,jl) * ptab (:,:,jl)96 END DO97 98 END FUNCTION fice_cell_ave99 100 FUNCTION fice_ice_ave ( ptab)101 !!--------------------------------------------------------------------------102 !! * Compute average over categories, for ice covered part of grid cell103 !!--------------------------------------------------------------------------104 REAL (kind=wp), DIMENSION (jpi,jpj) :: fice_ice_ave105 REAL (kind=wp), DIMENSION (jpi,jpj,jpl), INTENT(in) :: ptab106 107 fice_ice_ave (:,:) = 0.0_wp108 WHERE ( at_i (:,:) .GT. 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:)109 110 END FUNCTION fice_ice_ave111 82 112 83 !!====================================================================== … … 133 104 !!--------------------------------------------------------------------- 134 105 INTEGER, INTENT(in) :: kt ! ocean time step 135 INTEGER, INTENT(in) :: kblk ! type of bulk (=3 CLIO, =4 CORE )106 INTEGER, INTENT(in) :: kblk ! type of bulk (=3 CLIO, =4 CORE, =5 COUPLED) 136 107 !! 137 INTEGER :: j i, jj, jl, jk! dummy loop index108 INTEGER :: jl ! dummy loop index 138 109 REAL(wp) :: zcoef ! local scalar 139 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice_os, zalb_ice_cs ! albedo of the ice under overcast/clear sky 140 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean albedo of ice (for coupled) 141 142 REAL(wp), POINTER, DIMENSION(:,:) :: zalb_ice_all ! Mean albedo over all categories 143 REAL(wp), POINTER, DIMENSION(:,:) :: ztem_ice_all ! Mean temperature over all categories 144 145 REAL(wp), POINTER, DIMENSION(:,:) :: z_qsr_ice_all ! Mean solar heat flux over all categories 146 REAL(wp), POINTER, DIMENSION(:,:) :: z_qns_ice_all ! Mean non solar heat flux over all categories 147 REAL(wp), POINTER, DIMENSION(:,:) :: z_qla_ice_all ! Mean latent heat flux over all categories 148 REAL(wp), POINTER, DIMENSION(:,:) :: z_dqns_ice_all ! Mean d(qns)/dT over all categories 149 REAL(wp), POINTER, DIMENSION(:,:) :: z_dqla_ice_all ! Mean d(qla)/dT over all categories 150 REAL(wp) :: ztmelts ! clem 2014: for HC diags 151 REAL(wp) :: epsi20 = 1.e-20 ! 110 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean ice albedo (for coupled) 152 112 !!---------------------------------------------------------------------- 153 113 154 !- O.M. : why do we allocate all these arrays even when MOD( kt-1, nn_fsbc ) /= 0 ?????155 156 114 IF( nn_timing == 1 ) CALL timing_start('sbc_ice_lim') 157 158 CALL wrk_alloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs, zalb_ice )159 160 IF( lk_cpl ) THEN161 IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) &162 & CALL wrk_alloc( jpi, jpj, ztem_ice_all , zalb_ice_all , z_qsr_ice_all, z_qns_ice_all, &163 & z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all)164 ENDIF165 115 166 116 IF( kt == nit000 ) THEN … … 185 135 u_oce(:,:) = ssu_m(:,:) * umask(:,:,1) ! mean surface ocean current at ice velocity point 186 136 v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1) ! (C-grid dynamics : U- & V-points as the ocean) 187 188 ! masked sea surface freezing temperature [Kelvin] 189 t_bo(:,:) = ( tfreez( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) ) 190 191 CALL albedo_ice( t_su, ht_i, ht_s, zalb_ice_cs, zalb_ice_os ) ! ... ice albedo 192 137 ! 138 t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) ) ! masked sea surface freezing temperature [Kelvin] 139 ! ! (set to rt0 over land) 140 ! ! Ice albedo 141 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 142 143 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 144 145 SELECT CASE( kblk ) 146 CASE( jp_core , jp_cpl ) ! CORE and COUPLED bulk formulations 147 148 ! albedo depends on cloud fraction because of non-linear spectral effects 149 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 150 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 151 ! (zalb_ice) is computed within the bulk routine 152 153 END SELECT 154 155 ! ! Mask sea ice surface temperature 193 156 DO jl = 1, jpl 194 157 t_su(:,:,jl) = t_su(:,:,jl) + rt0 * ( 1. - tmask(:,:,1) ) 195 158 END DO 196 197 IF ( ln_cpl ) zalb_ice (:,:,:) = 0.5 * ( zalb_ice_cs (:,:,:) + zalb_ice_os (:,:,:) ) 198 199 IF( lk_cpl ) THEN 200 IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) THEN 201 ! 202 ! Compute mean albedo and temperature 203 zalb_ice_all (:,:) = fice_ice_ave ( zalb_ice (:,:,:) ) 204 ztem_ice_all (:,:) = fice_ice_ave ( tn_ice (:,:,:) ) 205 ! 206 ENDIF 207 ENDIF 208 ! Bulk formulea - provides the following fields: 159 160 ! Bulk formulae - provides the following fields: 209 161 ! utau_ice, vtau_ice : surface ice stress (U- & V-points) [N/m2] 210 162 ! qsr_ice , qns_ice : solar & non solar heat flux over ice (T-point) [W/m2] … … 215 167 ! 216 168 SELECT CASE( kblk ) 217 CASE( 3) ! CLIO bulk formulation218 CALL blk_ice_clio( t_su , zalb_ ice_cs, zalb_ice_os,&169 CASE( jp_clio ) ! CLIO bulk formulation 170 CALL blk_ice_clio( t_su , zalb_cs , zalb_os , zalb_ice , & 219 171 & utau_ice , vtau_ice , qns_ice , qsr_ice , & 220 172 & qla_ice , dqns_ice , dqla_ice , & … … 222 174 & fr1_i0 , fr2_i0 , cp_ice_msh, jpl ) 223 175 ! 224 CASE( 4 ) ! CORE bulk formulation 225 ! MV 2014 226 ! We must account for cloud fraction in the computation of the albedo 227 ! The present ref just uses the clear sky value 228 ! The overcast sky value is 0.06 higher, and polar skies are mostly overcast 229 ! CORE has no cloud fraction, hence we must prescribe it 230 ! Mean summer cloud fraction computed from CLIO = 0.81 231 zalb_ice(:,:,:) = 0.19 * zalb_ice_cs(:,:,:) + 0.81 * zalb_ice_os(:,:,:) 232 ! Following line, we replace zalb_ice_cs by simply zalb_ice 176 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 177 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 178 179 CASE( jp_core ) ! CORE bulk formulation 233 180 CALL blk_ice_core( t_su , u_ice , v_ice , zalb_ice , & 234 181 & utau_ice , vtau_ice , qns_ice , qsr_ice , & … … 236 183 & tprecip , sprecip , & 237 184 & fr1_i0 , fr2_i0 , cp_ice_msh, jpl ) 185 ! 186 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 187 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 238 188 ! 239 CASE ( 5 ) 240 zalb_ice (:,:,:) = 0.5 * ( zalb_ice_cs (:,:,:) + zalb_ice_os (:,:,:) ) 189 CASE ( jp_cpl ) 241 190 242 191 CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 243 192 244 CALL sbc_cpl_ice_flx( p_frld=ato_i, palbi=zalb_ice, psst=sst_m, pist=tn_ice ) 245 246 ! Latent heat flux is forced to 0 in coupled : 247 ! it is included in qns (non-solar heat flux) 248 qla_ice (:,:,:) = 0.0e0_wp 249 dqla_ice (:,:,:) = 0.0e0_wp 193 ! MV -> seb 194 ! CALL sbc_cpl_ice_flx( p_frld=ato_i, palbi=zalb_ice, psst=sst_m, pist=t_su ) 195 196 ! IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 197 ! & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 198 ! ! Latent heat flux is forced to 0 in coupled : 199 ! ! it is included in qns (non-solar heat flux) 200 ! qla_ice (:,:,:) = 0._wp 201 ! dqla_ice (:,:,:) = 0._wp 202 ! END MV -> seb 250 203 ! 251 204 END SELECT 252 253 ! Average over all categories 254 IF( lk_cpl ) THEN 255 IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) THEN 256 257 z_qns_ice_all (:,:) = fice_ice_ave ( qns_ice (:,:,:) ) 258 z_qsr_ice_all (:,:) = fice_ice_ave ( qsr_ice (:,:,:) ) 259 z_dqns_ice_all (:,:) = fice_ice_ave ( dqns_ice (:,:,:) ) 260 z_qla_ice_all (:,:) = fice_ice_ave ( qla_ice (:,:,:) ) 261 z_dqla_ice_all (:,:) = fice_ice_ave ( dqla_ice (:,:,:) ) 262 263 DO jl = 1, jpl 264 dqns_ice (:,:,jl) = z_dqns_ice_all (:,:) 265 dqla_ice (:,:,jl) = z_dqla_ice_all (:,:) 266 END DO 267 ! 268 IF ( ln_iceflx_ave ) THEN 269 DO jl = 1, jpl 270 qns_ice (:,:,jl) = z_qns_ice_all (:,:) 271 qsr_ice (:,:,jl) = z_qsr_ice_all (:,:) 272 qla_ice (:,:,jl) = z_qla_ice_all (:,:) 273 END DO 274 END IF 275 ! 276 IF ( ln_iceflx_linear ) THEN 277 DO jl = 1, jpl 278 qns_ice (:,:,jl) = z_qns_ice_all(:,:) + z_dqns_ice_all(:,:) * (tn_ice(:,:,jl) - ztem_ice_all(:,:)) 279 qla_ice (:,:,jl) = z_qla_ice_all(:,:) + z_dqla_ice_all(:,:) * (tn_ice(:,:,jl) - ztem_ice_all(:,:)) 280 qsr_ice (:,:,jl) = (1.0e0_wp-zalb_ice(:,:,jl)) / (1.0e0_wp-zalb_ice_all(:,:)) * z_qsr_ice_all(:,:) 281 END DO 282 END IF 283 END IF 284 ENDIF 205 285 206 ! !----------------------! 286 207 ! ! LIM-3 time-stepping ! … … 389 310 pfrld(:,:) = 1._wp - at_i(:,:) 390 311 phicif(:,:) = vt_i(:,:) 312 313 ! MV -> seb 314 SELECT CASE( kblk ) 315 CASE ( jp_cpl ) 316 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 317 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 318 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 319 ! Latent heat flux is forced to 0 in coupled : 320 ! it is included in qns (non-solar heat flux) 321 qla_ice (:,:,:) = 0._wp 322 dqla_ice (:,:,:) = 0._wp 323 END SELECT 324 ! END MV -> seb 391 325 ! 392 326 CALL lim_var_bv ! bulk brine volume (diag) … … 420 354 IF( ln_nicep ) CALL lim_ctl( kt ) ! alerts in case of model crash 421 355 ! 356 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 357 ! 422 358 ENDIF ! End sea-ice time step only 423 359 … … 429 365 ! ! otherwise the atm.-ocean stresses are used everywhere 430 366 IF( ln_limdyn ) CALL lim_sbc_tau( kt, ub(:,:,1), vb(:,:,1) ) ! using before instantaneous surf. currents 431 432 367 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 433 CALL wrk_dealloc( jpi,jpj,jpl, zalb_ice_os, zalb_ice_cs, zalb_ice ) 434 435 IF( lk_cpl ) THEN 436 IF ( ln_iceflx_ave .OR. ln_iceflx_linear ) & 437 & CALL wrk_dealloc( jpi, jpj, ztem_ice_all , zalb_ice_all , z_qsr_ice_all, z_qns_ice_all, & 438 & z_qla_ice_all, z_dqns_ice_all, z_dqla_ice_all) 439 ENDIF 368 440 369 ! 441 370 IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_lim') 442 371 ! 443 372 END SUBROUTINE sbc_ice_lim 444 445 373 374 375 SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice, & 376 & pdqn_ice, pqla_ice, pdql_ice, k_limflx ) 377 !!--------------------------------------------------------------------- 378 !! *** ROUTINE sbc_ice_lim *** 379 !! 380 !! ** Purpose : update the ice surface boundary condition by averaging and / or 381 !! redistributing fluxes on ice categories 382 !! 383 !! ** Method : average then redistribute 384 !! 385 !! ** Action : 386 !!--------------------------------------------------------------------- 387 INTEGER , INTENT(in ) :: k_limflx ! =-1 do nothing; =0 average ; 388 ! =1 average and redistribute ; =2 redistribute 389 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptn_ice ! ice surface temperature 390 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb_ice ! ice albedo 391 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqns_ice ! non solar flux 392 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqsr_ice ! net solar flux 393 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity 394 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqla_ice ! latent heat flux 395 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdql_ice ! latent heat flux sensitivity 396 ! 397 INTEGER :: jl ! dummy loop index 398 ! 399 REAL(wp), POINTER, DIMENSION(:,:) :: zalb_m ! Mean albedo over all categories 400 REAL(wp), POINTER, DIMENSION(:,:) :: ztem_m ! Mean temperature over all categories 401 ! 402 REAL(wp), POINTER, DIMENSION(:,:) :: z_qsr_m ! Mean solar heat flux over all categories 403 REAL(wp), POINTER, DIMENSION(:,:) :: z_qns_m ! Mean non solar heat flux over all categories 404 REAL(wp), POINTER, DIMENSION(:,:) :: z_qla_m ! Mean latent heat flux over all categories 405 REAL(wp), POINTER, DIMENSION(:,:) :: z_dqn_m ! Mean d(qns)/dT over all categories 406 REAL(wp), POINTER, DIMENSION(:,:) :: z_dql_m ! Mean d(qla)/dT over all categories 407 !!---------------------------------------------------------------------- 408 409 IF( nn_timing == 1 ) CALL timing_start('ice_lim_flx') 410 ! 411 ! 412 SELECT CASE( k_limflx ) !== averaged on all ice categories ==! 413 CASE( 0 , 1 ) 414 CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 415 ! 416 z_qns_m(:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 417 z_qsr_m(:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 418 z_dqn_m(:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 419 z_qla_m(:,:) = fice_ice_ave ( pqla_ice (:,:,:) ) 420 z_dql_m(:,:) = fice_ice_ave ( pdql_ice (:,:,:) ) 421 DO jl = 1, jpl 422 pdqn_ice(:,:,jl) = z_dqn_m(:,:) 423 pdql_ice(:,:,jl) = z_dql_m(:,:) 424 END DO 425 ! 426 DO jl = 1, jpl 427 pqns_ice(:,:,jl) = z_qns_m(:,:) 428 pqsr_ice(:,:,jl) = z_qsr_m(:,:) 429 pqla_ice(:,:,jl) = z_qla_m(:,:) 430 END DO 431 ! 432 CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_qla_m, z_dqn_m, z_dql_m) 433 END SELECT 434 435 SELECT CASE( k_limflx ) !== redistribution on all ice categories ==! 436 CASE( 1 , 2 ) 437 CALL wrk_alloc( jpi,jpj, zalb_m, ztem_m ) 438 ! 439 zalb_m(:,:) = fice_ice_ave ( palb_ice (:,:,:) ) 440 ztem_m(:,:) = fice_ice_ave ( ptn_ice (:,:,:) ) 441 DO jl = 1, jpl 442 pqns_ice(:,:,jl) = pqns_ice(:,:,jl) + pdqn_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 443 pqla_ice(:,:,jl) = pqla_ice(:,:,jl) + pdql_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:)) 444 pqsr_ice(:,:,jl) = pqsr_ice(:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) ) 445 END DO 446 ! 447 CALL wrk_dealloc( jpi,jpj, zalb_m, ztem_m ) 448 END SELECT 449 ! 450 IF( nn_timing == 1 ) CALL timing_stop('ice_lim_flx') 451 ! 452 END SUBROUTINE ice_lim_flx 453 454 446 455 SUBROUTINE lim_ctl( kt ) 447 456 !!----------------------------------------------------------------------- … … 675 684 !! n : number of the option 676 685 !!------------------------------------------------------------------- 677 INTEGER , INTENT(in) :: kt ! ocean time step686 INTEGER , INTENT(in) :: kt ! ocean time step 678 687 INTEGER , INTENT(in) :: ki, kj, kn ! ocean gridpoint indices 679 688 CHARACTER(len=*), INTENT(in) :: cd1 ! … … 853 862 END DO 854 863 END DO 855 864 ! 856 865 END SUBROUTINE lim_prt_state 866 867 868 FUNCTION fice_cell_ave ( ptab ) 869 !!-------------------------------------------------------------------------- 870 !! * Compute average over categories, for grid cell (ice covered and free ocean) 871 !!-------------------------------------------------------------------------- 872 REAL (wp), DIMENSION (jpi,jpj) :: fice_cell_ave 873 REAL (wp), DIMENSION (jpi,jpj,jpl), INTENT (in) :: ptab 874 INTEGER :: jl ! Dummy loop index 875 876 fice_cell_ave (:,:) = 0.0_wp 877 878 DO jl = 1, jpl 879 fice_cell_ave (:,:) = fice_cell_ave (:,:) & 880 & + a_i (:,:,jl) * ptab (:,:,jl) 881 END DO 882 883 END FUNCTION fice_cell_ave 884 885 886 FUNCTION fice_ice_ave ( ptab ) 887 !!-------------------------------------------------------------------------- 888 !! * Compute average over categories, for ice covered part of grid cell 889 !!-------------------------------------------------------------------------- 890 REAL (kind=wp), DIMENSION (jpi,jpj) :: fice_ice_ave 891 REAL (kind=wp), DIMENSION (jpi,jpj,jpl), INTENT(in) :: ptab 892 893 fice_ice_ave (:,:) = 0.0_wp 894 WHERE ( at_i (:,:) .GT. 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 895 896 END FUNCTION fice_ice_ave 897 857 898 858 899 #else -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90
r4924 r4946 97 97 !! 98 98 INTEGER :: ji, jj ! dummy loop indices 99 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice_os ! albedo of the ice under overcast sky 100 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice_cs ! albedo of ice under clear sky 101 REAL(wp), DIMENSION(:,:,:), POINTER :: zsist ! surface ice temperature (K) 99 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_os ! ice albedo under overcast sky 100 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_cs ! ice albedo under clear sky 101 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice ! mean ice albedo 102 REAL(wp), DIMENSION(:,:,:), POINTER :: zsist ! ice surface temperature (K) 102 103 !!---------------------------------------------------------------------- 103 104 104 CALL wrk_alloc( jpi,jpj,1, zalb_ ice_os, zalb_ice_cs, zsist )105 CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 105 106 106 107 IF( kt == nit000 ) THEN … … 130 131 DO jj = 2, jpj 131 132 DO ji = 2, jpi ! NO vector opt. possible 132 u_oce(ji,jj) = 0.5_wp * ( ssu_m(ji-1,jj ) * umask(ji-1,jj ,1) + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 133 v_oce(ji,jj) = 0.5_wp * ( ssv_m(ji ,jj-1) * vmask(ji ,jj-1,1) + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 133 u_oce(ji,jj) = 0.5_wp * ( ssu_m(ji-1,jj ) * umask(ji-1,jj ,1) & 134 & + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 135 v_oce(ji,jj) = 0.5_wp * ( ssv_m(ji ,jj-1) * vmask(ji ,jj-1,1) & 136 & + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 134 137 END DO 135 138 END DO … … 144 147 145 148 ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 146 tfu(:,:) = tfreez( sss_m ) + rt0149 tfu(:,:) = eos_fzp( sss_m ) + rt0 147 150 148 151 zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) 149 152 150 ! ... ice albedo (clear sky and overcast sky) 153 ! Ice albedo 154 151 155 CALL albedo_ice( zsist, reshape( hicif, (/jpi,jpj,1/) ), & 152 156 reshape( hsnif, (/jpi,jpj,1/) ), & 153 zalb_ice_cs, zalb_ice_os ) 157 zalb_cs, zalb_os ) 158 159 SELECT CASE( ksbc ) 160 CASE( jp_core , jp_cpl ) ! CORE and COUPLED bulk formulations 161 162 ! albedo depends on cloud fraction because of non-linear spectral effects 163 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 164 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 165 ! (zalb_ice) is computed within the bulk routine 166 167 END SELECT 154 168 155 169 ! ... Sea-ice surface boundary conditions output from bulk formulae : … … 167 181 ! 168 182 SELECT CASE( ksbc ) 169 CASE( 3) ! CLIO bulk formulation170 CALL blk_ice_clio( zsist, zalb_ ice_cs, zalb_ice_os,&183 CASE( jp_clio ) ! CLIO bulk formulation 184 CALL blk_ice_clio( zsist, zalb_cs , zalb_os , zalb_ice , & 171 185 & utau_ice , vtau_ice , qns_ice , qsr_ice, & 172 186 & qla_ice , dqns_ice , dqla_ice , & … … 174 188 & fr1_i0 , fr2_i0 , cp_ice_msh , jpl ) 175 189 176 CASE( 4) ! CORE bulk formulation177 CALL blk_ice_core( zsist, u_ice , v_ice , zalb_ice _cs, &190 CASE( jp_core ) ! CORE bulk formulation 191 CALL blk_ice_core( zsist, u_ice , v_ice , zalb_ice , & 178 192 & utau_ice , vtau_ice , qns_ice , qsr_ice, & 179 193 & qla_ice , dqns_ice , dqla_ice , & 180 194 & tprecip , sprecip , & 181 195 & fr1_i0 , fr2_i0 , cp_ice_msh , jpl ) 182 IF( ltrcdm2dc_ice ) CALL blk_ice_meanqsr( zalb_ice _cs, qsr_ice_mean, jpl )183 184 CASE( 5 )! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics)196 IF( ltrcdm2dc_ice ) CALL blk_ice_meanqsr( zalb_ice, qsr_ice_mean, jpl ) 197 198 CASE( jp_cpl ) ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 185 199 CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 186 200 END SELECT … … 213 227 #endif 214 228 END IF 215 #if defined key_coupled216 229 ! ! Ice surface fluxes in coupled mode 217 IF( ksbc == 5) THEN230 IF( ksbc == jp_cpl ) THEN 218 231 a_i(:,:,1)=fr_i 219 232 CALL sbc_cpl_ice_flx( frld, & 220 233 ! optional arguments, used only in 'mixed oce-ice' case 221 & palbi = zalb_ice _cs, psst = sst_m, pist = zsist )234 & palbi = zalb_ice, psst = sst_m, pist = zsist ) 222 235 sprecip(:,:) = - emp_ice(:,:) ! Ugly patch, WARNING, in coupled mode, sublimation included in snow (parsub = 0.) 223 236 ENDIF 224 #endif225 237 CALL lim_thd_2 ( kt ) ! Ice thermodynamics 226 238 CALL lim_sbc_flx_2 ( kt ) ! update surface ocean mass, heat & salt fluxes … … 252 264 IF( ln_limdyn ) CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) ) ! using before instantaneous surf. currents 253 265 ! 254 CALL wrk_dealloc( jpi,jpj,1, zalb_ ice_os, zalb_ice_cs, zsist )266 CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 255 267 ! 256 268 END SUBROUTINE sbc_ice_lim_2 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90
r4938 r4946 54 54 REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: risfLeff !:effective length (Leff) BG03 nn_isf==2 55 55 REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 56 INTEGER(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base 56 #ifdef key_agrif 57 ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base 57 59 !: (first wet level and last level include in the tbl) 60 #else 61 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base 62 #endif 63 58 64 59 65 REAL(wp), PUBLIC, SAVE :: rcpi = 2000.0_wp ! phycst ? … … 303 309 sbc_isf_alloc = 0 ! set to zero if no array to be allocated 304 310 IF( .NOT. ALLOCATED( qisf ) ) THEN 305 ALLOCATE( risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj), fwfisf(jpi,jpj), & 306 & fwfisf_b(jpi,jpj), misfkt(jpi,jpj), rhisf_tbl(jpi,jpj), r1_hisf_tbl(jpi,jpj), & 307 & rzisf_tbl(jpi,jpj), misfkb(jpi,jpj), ttbl(jpi,jpj), stbl(jpi,jpj), utbl(jpi,jpj), & 308 & vtbl(jpi, jpj), risfLeff(jpi,jpj), rhisf_tbl_0(jpi,jpj), ralpha(jpi,jpj), STAT= sbc_isf_alloc ) 311 ALLOCATE( risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts) , & 312 & qisf(jpi,jpj) , fwfisf(jpi,jpj) , fwfisf_b(jpi,jpj) , & 313 & rhisf_tbl(jpi,jpj), r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj) , & 314 & ttbl(jpi,jpj) , stbl(jpi,jpj) , utbl(jpi,jpj) , & 315 & vtbl(jpi, jpj) , risfLeff(jpi,jpj) , rhisf_tbl_0(jpi,jpj), & 316 & ralpha(jpi,jpj) , misfkt(jpi,jpj) , misfkb(jpi,jpj) , & 317 & STAT= sbc_isf_alloc ) 309 318 ! 310 319 IF( lk_mpp ) CALL mpp_sum ( sbc_isf_alloc ) … … 363 372 ! Calculate freezing temperature 364 373 zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04 365 zt_frz = tfreez1D(tsb(ji,jj,ik,jp_sal), zpress)374 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress) 366 375 zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik) ! sum temp 367 376 ENDDO … … 445 454 zti(:,:)=tinsitu( ttbl, stbl, zpress ) 446 455 ! Calculate freezing temperature 447 zfrz(:,:)= tfreez( sss_m(:,:), zpress )456 zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 448 457 449 458 … … 526 535 nit = nit + 1 527 536 IF (nit .GE. 51) THEN 528 WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b, zgammat, zgammas, nn_gammablk, ji, jj, mikt(ji,jj), narea 537 WRITE(numout,*) "sbcisf : too many iteration ... ", & 538 & zhtflx, zhtflx_b, zgammat, zgammas, nn_gammablk, ji, jj, mikt(ji,jj), narea 529 539 CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 530 540 END IF … … 584 594 REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence 585 595 REAL(wp) :: zcoef ! temporary coef 586 REAL(wp) :: zrhos, zalbet, zbeta, zthermal, zhalin 587 REAL(wp) :: zt, zs, zh 596 REAL(wp) :: zdep 588 597 REAL(wp), PARAMETER :: zxsiN = 0.052 ! dimensionless constant 589 598 REAL(wp), PARAMETER :: epsln = 1.0e-20 ! a small positive number 590 599 REAL(wp), PARAMETER :: znu = 1.95e-6 ! kinamatic viscosity of sea water (m2.s-1) 591 600 REAL(wp) :: rcs = 1.0e-3_wp ! conversion: mm/s ==> m/s 601 REAL(wp), DIMENSION(2) :: zts, zab 592 602 !!--------------------------------------------------------------------- 593 603 ! … … 656 666 657 667 !! compute bouyancy 658 IF( nn_eos < 1) THEN 659 zt = ttbl(ji,jj) 660 zs = stbl(ji,jj) - 35.0 661 zh = fsdepw(ji,jj,ikt) 662 ! potential volumic mass 663 zrhos = rhop(ji,jj,ikt) 664 zalbet = ( ( ( - 0.255019e-07 * zt + 0.298357e-05 ) * zt & ! ratio alpha/beta 665 & - 0.203814e-03 ) * zt & 666 & + 0.170907e-01 ) * zt & 667 & + 0.665157e-01 & 668 & + ( - 0.678662e-05 * zs & 669 & - 0.846960e-04 * zt + 0.378110e-02 ) * zs & 670 & + ( ( - 0.302285e-13 * zh & 671 & - 0.251520e-11 * zs & 672 & + 0.512857e-12 * zt * zt ) * zh & 673 & - 0.164759e-06 * zs & 674 & +( 0.791325e-08 * zt - 0.933746e-06 ) * zt & 675 & + 0.380374e-04 ) * zh 676 677 zbeta = ( ( -0.415613e-09 * zt + 0.555579e-07 ) * zt & ! beta 678 & - 0.301985e-05 ) * zt & 679 & + 0.785567e-03 & 680 & + ( 0.515032e-08 * zs & 681 & + 0.788212e-08 * zt - 0.356603e-06 ) * zs & 682 & +( ( 0.121551e-17 * zh & 683 & - 0.602281e-15 * zs & 684 & - 0.175379e-14 * zt + 0.176621e-12 ) * zh & 685 & + 0.408195e-10 * zs & 686 & + ( - 0.213127e-11 * zt + 0.192867e-09 ) * zt & 687 & - 0.121555e-07 ) * zh 688 689 zthermal = zbeta * zalbet / ( rcp * zrhos + epsln ) 690 zhalin = zbeta * stbl(ji,jj) * rcs 691 ELSE 692 zrhos = rhop(ji,jj,ikt) + rau0 * ( 1. - tmask(ji,jj,ikt) ) 693 zthermal = rn_alpha / ( rcp * zrhos + epsln ) 694 zhalin = rn_beta * stbl(ji,jj) * rcs 695 ENDIF 668 zts(jp_tem) = ttbl(ji,jj) 669 zts(jp_sal) = stbl(ji,jj) 670 zdep = fsdepw(ji,jj,ikt) 671 ! 672 CALL eos_rab( zts, zdep, zab ) 673 ! 696 674 !! compute length scale 697 zbuofdep = grav * ( z thermal * zqhisf - zhalin* zqwisf ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!675 zbuofdep = grav * ( zab(jp_tem) * zqhisf - zab(jp_sal) * zqwisf ) !!!!!!!!!!!!!!!!!!!!!!!!!!!! 698 676 699 677 !! compute Monin Obukov Length … … 766 744 ! level partially include in ice shelf boundary layer 767 745 zhk = SUM( fse3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) 768 IF (cptin == 'T') varout(ji,jj) = varout(ji,jj) + varin(ji,jj,ikb) * (1._wp - zhk) 769 IF (cptin == 'U') varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji-1,jj,ikb)) * (1._wp - zhk) 770 IF (cptin == 'V') varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji,jj-1,ikb)) * (1._wp - zhk) 746 IF (cptin == 'T') & 747 & varout(ji,jj) = varout(ji,jj) + varin(ji,jj,ikb) * (1._wp - zhk) 748 IF (cptin == 'U') & 749 & varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji-1,jj,ikb)) * (1._wp - zhk) 750 IF (cptin == 'V') & 751 & varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji,jj-1,ikb)) * (1._wp - zhk) 771 752 END IF 772 753 END DO … … 796 777 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence 797 778 !! 798 INTEGER (wp):: ji, jj, jk ! dummy loop indices799 INTEGER (wp):: ikt, ikb800 INTEGER (wp):: nk_isf779 INTEGER :: ji, jj, jk ! dummy loop indices 780 INTEGER :: ikt, ikb 781 INTEGER :: nk_isf 801 782 REAL(wp) :: zhk, z1_hisf_tbl, zhisf_tbl 802 783 REAL(wp) :: zfact ! local scalar … … 834 815 ! level fully include in the ice shelf boundary layer 835 816 DO jk = ikt, ikb - 1 836 phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact 817 phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) & 818 & * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact 837 819 END DO 838 820 ! level partially include in ice shelf boundary layer 839 phdivn(ji,jj,ikb) = phdivn(ji,jj,ikb) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj) 821 phdivn(ji,jj,ikb) = phdivn(ji,jj,ikb) + ( fwfisf(ji,jj) & 822 & + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj) 840 823 !== ice shelf melting mass distributed over several levels ==! 841 824 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r4924 r4946 37 37 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 38 38 USE sbccpl ! surface boundary condition: coupled florulation 39 USE cpl_oasis3, ONLY:lk_cpl ! are we in coupled mode?40 39 USE sbcssr ! surface boundary condition: sea surface restoring 41 40 USE sbcrnf ! surface boundary condition: runoffs … … 83 82 INTEGER :: icpt ! local integer 84 83 !! 85 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, ln_cpl,&84 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, & 86 85 & 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, nn_lsm, cn_iceflx86 & ln_ssr , nn_isf , nn_fwb , ln_cdgw , ln_wave , ln_sdw, nn_lsm, nn_limflx 88 87 INTEGER :: ios 89 88 !!---------------------------------------------------------------------- … … 124 123 WRITE(numout,*) ' CORE bulk formulation ln_blk_core = ', ln_blk_core 125 124 WRITE(numout,*) ' MFS bulk formulation ln_blk_mfs = ', ln_blk_mfs 126 WRITE(numout,*) ' coupled formulation (T if key_ sbc_cpl) ln_cpl = ', ln_cpl127 WRITE(numout,*) ' Flux handling over ice categories cn_iceflx = ', TRIM (cn_iceflx)125 WRITE(numout,*) ' coupled formulation (T if key_oasis3) lk_cpl = ', lk_cpl 126 WRITE(numout,*) ' Multicategory heat flux formulation (LIM3) nn_limflx = ', nn_limflx 128 127 WRITE(numout,*) ' Misc. options of sbc : ' 129 128 WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn … … 139 138 ENDIF 140 139 141 ! Flux handling over ice categories 142 #if defined key_coupled 143 SELECT CASE ( TRIM (cn_iceflx)) 144 CASE ('ave') 145 ln_iceflx_ave = .TRUE. 146 ln_iceflx_linear = .FALSE. 147 CASE ('linear') 148 ln_iceflx_ave = .FALSE. 149 ln_iceflx_linear = .TRUE. 150 CASE default 151 ln_iceflx_ave = .FALSE. 152 ln_iceflx_linear = .FALSE. 140 ! LIM3 Multi-category heat flux formulation 141 SELECT CASE ( nn_limflx) 142 CASE ( -1 ) 143 IF(lwp) WRITE(numout,*) ' Use of per-category fluxes (nn_limflx = -1) ' 144 CASE ( 0 ) 145 IF(lwp) WRITE(numout,*) ' Average per-category fluxes (nn_limflx = 0) ' 146 CASE ( 1 ) 147 IF(lwp) WRITE(numout,*) ' Average then redistribute per-category fluxes (nn_limflx = 1) ' 148 CASE ( 2 ) 149 IF(lwp) WRITE(numout,*) ' Redistribute a single flux over categories (nn_limflx = 2) ' 153 150 END SELECT 154 IF(lwp) WRITE(numout,*) ' Fluxes averaged over all ice categories ln_iceflx_ave = ', ln_iceflx_ave155 IF(lwp) WRITE(numout,*) ' Fluxes distributed linearly over ice categories ln_iceflx_linear = ', ln_iceflx_linear156 #endif157 151 ! 158 152 #if defined key_top && ! defined key_offline … … 214 208 IF( ( nn_ice == 3 .OR. nn_ice == 4 ) .AND. nn_ice_embd == 0 ) & 215 209 & CALL ctl_stop( 'LIM3 and CICE sea-ice models require nn_ice_embd = 1 or 2' ) 216 #if defined key_coupled 217 IF( ln_iceflx_ave .AND. ln_iceflx_linear ) & 218 & CALL ctl_stop( ' ln_iceflx_ave and ln_iceflx_linear options are not compatible' ) 219 IF( ( nn_ice ==3 .AND. lk_cpl) .AND. .NOT. ( ln_iceflx_ave .OR. ln_iceflx_linear ) ) & 220 & CALL ctl_stop( ' With lim3 coupled, either ln_iceflx_ave or ln_iceflx_linear must be set to .TRUE.' ) 221 #endif 210 IF( ( nn_ice /= 3 ) .AND. ( nn_limflx >= 0 ) ) & 211 & WRITE(numout,*) 'The nn_limflx>=0 option has no effect if sea ice model is not LIM3' 212 IF( ( nn_ice == 3 ) .AND. ( lk_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) ) & 213 & CALL ctl_stop( 'The chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 214 IF( ( nn_ice == 3 ) .AND. ( .NOT. lk_cpl ) .AND. ( nn_limflx == 2 ) ) & 215 & CALL ctl_stop( 'The chosen nn_limflx for LIM3 in forced mode cannot be 2' ) 216 222 217 IF( ln_dm2dc ) nday_qsr = -1 ! initialisation flag 223 218 … … 244 239 ! ! Choice of the Surface Boudary Condition (set nsbc) 245 240 icpt = 0 246 IF( ln_ana ) THEN ; nsbc = 1; icpt = icpt + 1 ; ENDIF ! analytical formulation247 IF( ln_flx ) THEN ; nsbc = 2; icpt = icpt + 1 ; ENDIF ! flux formulation248 IF( ln_blk_clio ) THEN ; nsbc = 3; icpt = icpt + 1 ; ENDIF ! CLIO bulk formulation249 IF( ln_blk_core ) THEN ; nsbc = 4; icpt = icpt + 1 ; ENDIF ! CORE bulk formulation250 IF( ln_blk_mfs ) THEN ; nsbc = 6; icpt = icpt + 1 ; ENDIF ! MFS bulk formulation251 IF( l n_cpl ) THEN ; nsbc = 5; icpt = icpt + 1 ; ENDIF ! Coupled formulation252 IF( cp_cfg == 'gyre') THEN ; nsbc = 0; ENDIF ! GYRE analytical formulation253 IF( lk_esopa ) nsbc = -1! esopa test, ALL formulations241 IF( ln_ana ) THEN ; nsbc = jp_ana ; icpt = icpt + 1 ; ENDIF ! analytical formulation 242 IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation 243 IF( ln_blk_clio ) THEN ; nsbc = jp_clio ; icpt = icpt + 1 ; ENDIF ! CLIO bulk formulation 244 IF( ln_blk_core ) THEN ; nsbc = jp_core ; icpt = icpt + 1 ; ENDIF ! CORE bulk formulation 245 IF( ln_blk_mfs ) THEN ; nsbc = jp_mfs ; icpt = icpt + 1 ; ENDIF ! MFS bulk formulation 246 IF( lk_cpl ) THEN ; nsbc = jp_cpl ; icpt = icpt + 1 ; ENDIF ! Coupled formulation 247 IF( cp_cfg == 'gyre') THEN ; nsbc = jp_gyre ; ENDIF ! GYRE analytical formulation 248 IF( lk_esopa ) nsbc = jp_esopa ! esopa test, ALL formulations 254 249 ! 255 250 IF( icpt /= 1 .AND. .NOT.lk_esopa ) THEN … … 262 257 IF(lwp) THEN 263 258 WRITE(numout,*) 264 IF( nsbc == -1 ) WRITE(numout,*) ' ESOPA test All surface boundary conditions' 265 IF( nsbc == 0 ) WRITE(numout,*) ' GYRE analytical formulation' 266 IF( nsbc == 1 ) WRITE(numout,*) ' analytical formulation' 267 IF( nsbc == 2 ) WRITE(numout,*) ' flux formulation' 268 IF( nsbc == 3 ) WRITE(numout,*) ' CLIO bulk formulation' 269 IF( nsbc == 4 ) WRITE(numout,*) ' CORE bulk formulation' 270 IF( nsbc == 5 ) WRITE(numout,*) ' coupled formulation' 271 IF( nsbc == 6 ) WRITE(numout,*) ' MFS Bulk formulation' 272 ENDIF 273 ! 274 CALL sbc_ssm_init ! Sea-surface mean fields initialisation 275 ! 276 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialisation 277 ! 278 IF( nn_ice == 4 ) CALL cice_sbc_init( nsbc ) ! CICE initialisation 279 ! 259 IF( nsbc == jp_esopa ) WRITE(numout,*) ' ESOPA test All surface boundary conditions' 260 IF( nsbc == jp_gyre ) WRITE(numout,*) ' GYRE analytical formulation' 261 IF( nsbc == jp_ana ) WRITE(numout,*) ' analytical formulation' 262 IF( nsbc == jp_flx ) WRITE(numout,*) ' flux formulation' 263 IF( nsbc == jp_clio ) WRITE(numout,*) ' CLIO bulk formulation' 264 IF( nsbc == jp_core ) WRITE(numout,*) ' CORE bulk formulation' 265 IF( nsbc == jp_cpl ) WRITE(numout,*) ' coupled formulation' 266 IF( nsbc == jp_mfs ) WRITE(numout,*) ' MFS Bulk formulation' 267 ENDIF 268 ! 269 CALL sbc_ssm_init ! Sea-surface mean fields initialisation 270 ! 271 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialisation 272 ! 273 IF( nn_ice == 4 ) CALL cice_sbc_init( nsbc ) ! CICE initialisation 274 ! 275 IF( nsbc == jp_cpl ) CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before first time step 276 280 277 END SUBROUTINE sbc_init 281 278 … … 328 325 SELECT CASE( nsbc ) ! Compute ocean surface boundary condition 329 326 ! ! (i.e. utau,vtau, qns, qsr, emp, sfx) 330 CASE( 0) ; CALL sbc_gyre ( kt ) ! analytical formulation : GYRE configuration331 CASE( 1) ; CALL sbc_ana ( kt ) ! analytical formulation : uniform sbc332 CASE( 2) ; CALL sbc_flx ( kt ) ! flux formulation333 CASE( 3) ; CALL sbc_blk_clio( kt ) ! bulk formulation : CLIO for the ocean334 CASE( 4) ; CALL sbc_blk_core( kt ) ! bulk formulation : CORE for the ocean335 CASE( 5) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! coupled formulation336 CASE( 6) ; CALL sbc_blk_mfs ( kt ) ! bulk formulation : MFS for the ocean337 CASE( -1)338 CALL sbc_ana ( kt ) ! ESOPA, test ALL the formulations339 CALL sbc_gyre ( kt ) !340 CALL sbc_flx ( kt ) !341 CALL sbc_blk_clio( kt ) !342 CALL sbc_blk_core( kt ) !343 CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) !327 CASE( jp_gyre ) ; CALL sbc_gyre ( kt ) ! analytical formulation : GYRE configuration 328 CASE( jp_ana ) ; CALL sbc_ana ( kt ) ! analytical formulation : uniform sbc 329 CASE( jp_flx ) ; CALL sbc_flx ( kt ) ! flux formulation 330 CASE( jp_clio ) ; CALL sbc_blk_clio( kt ) ! bulk formulation : CLIO for the ocean 331 CASE( jp_core ) ; CALL sbc_blk_core( kt ) ! bulk formulation : CORE for the ocean 332 CASE( jp_cpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! coupled formulation 333 CASE( jp_mfs ) ; CALL sbc_blk_mfs ( kt ) ! bulk formulation : MFS for the ocean 334 CASE( jp_esopa ) 335 CALL sbc_ana ( kt ) ! ESOPA, test ALL the formulations 336 CALL sbc_gyre ( kt ) ! 337 CALL sbc_flx ( kt ) ! 338 CALL sbc_blk_clio( kt ) ! 339 CALL sbc_blk_core( kt ) ! 340 CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! 344 341 END SELECT 345 342 … … 350 347 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 351 348 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model 352 !is it useful?353 349 CASE( 4 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 354 350 END SELECT … … 424 420 CALL iom_put( "qsr" , qsr ) ! solar heat flux 425 421 IF( nn_ice > 0 ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction 422 CALL iom_put( "taum" , taum ) ! wind stress module 423 CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice 426 424 ENDIF 427 425 ! 428 426 CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at 429 427 CALL iom_put( "vtau", vtau ) ! j-wind stress each time step in sea-ice) 430 CALL iom_put( "taum", taum ) ! wind stress module431 CALL iom_put( "wspd", wndm ) ! wind speed module432 428 ! 433 429 IF(ln_ctl) THEN ! print mean trends (used for debugging) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r4666 r4946 14 14 USE oce ! ocean dynamics and tracers 15 15 USE dom_oce ! ocean space and time domain 16 USE sbc_oce ! Surface boundary condition: ocean fields17 16 USE sbc_oce ! surface boundary condition: ocean fields 18 17 USE sbcapr ! surface boundary condition: atmospheric pressure 19 USE prtctl ! Print control (prt_ctl routine)20 USE iom18 USE eosbn2 ! equation of state and related derivatives 19 ! 21 20 USE in_out_manager ! I/O manager 21 USE prtctl ! Print control 22 USE iom ! IOM library 22 23 23 24 IMPLICIT NONE … … 54 55 INTEGER, INTENT(in) :: kt ! ocean time step 55 56 ! 56 INTEGER :: ji, jj ! loop index57 INTEGER :: ji, jj ! loop index 57 58 REAL(wp) :: zcoef, zf_sbc ! local scalar 59 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts 60 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb,zdep 58 61 !!--------------------------------------------------------------------- 62 63 ! !* first wet T-, U-, V- ocean level (ISF) variables (T, S, depth, velocity) 64 DO jj = 1, jpj 65 DO ji = 1, jpi 66 zub(ji,jj) = ub (ji,jj,miku(ji,jj)) 67 zvb(ji,jj) = vb (ji,jj,mikv(ji,jj)) 68 zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem) 69 zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal) 70 END DO 71 END DO 72 ! 73 IF( lk_vvl ) THEN 74 DO jj = 1, jpj 75 DO ji = 1, jpi 76 zdep(ji,jj) = fse3t_n(ji,jj,mikt(ji,jj)) 77 END DO 78 END DO 79 ENDIF 59 80 ! ! ---------------------------------------- ! 60 81 IF( nn_fsbc == 1 ) THEN ! Instantaneous surface fields ! 61 82 ! ! ---------------------------------------- ! 62 DO jj = 1, jpj 63 DO ji = 1, jpi 64 ssu_m(ji,jj) = ub(ji,jj,miku(ji,jj)) 65 ssv_m(ji,jj) = vb(ji,jj,mikv(ji,jj)) 66 sst_m(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) 67 sss_m(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) 68 IF( lk_vvl ) fse3t_m(ji,jj) = fse3t_n(ji,jj,mikt(ji,jj)) 69 END DO 70 END DO 83 ssu_m(:,:) = zub(:,:) 84 ssv_m(:,:) = zvb(:,:) 85 IF( ln_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 86 ELSE ; sst_m(:,:) = zts(:,:,jp_tem) 87 ENDIF 88 sss_m(:,:) = zts(:,:,jp_sal) 71 89 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 72 90 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 73 91 ELSE ; ssh_m(:,:) = sshn(:,:) 74 92 ENDIF 93 ! 94 IF( lk_vvl ) fse3t_m(:,:) = zdep(:,:) 75 95 ! 76 96 ELSE … … 81 101 IF(lwp) WRITE(numout,*) '~~~~~~~ mean fields initialised to instantaneous values' 82 102 zcoef = REAL( nn_fsbc - 1, wp ) 83 DO jj = 1, jpj 84 DO ji = 1, jpi 85 ssu_m(ji,jj) = zcoef * ub(ji,jj,miku(ji,jj)) 86 ssv_m(ji,jj) = zcoef * vb(ji,jj,mikv(ji,jj)) 87 sst_m(ji,jj) = zcoef * tsn(ji,jj,mikt(ji,jj),jp_tem) 88 sss_m(ji,jj) = zcoef * tsn(ji,jj,mikt(ji,jj),jp_sal) 89 IF( lk_vvl ) fse3t_m(ji,jj) = zcoef * fse3t_n(ji,jj,mikt(ji,jj)) 90 END DO 91 END DO 92 ! ! removed inverse barometer ssh when Patm forcing is used 103 ssu_m(:,:) = zcoef * zub(:,:) 104 ssv_m(:,:) = zcoef * zvb(:,:) 105 IF( ln_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 106 ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem) 107 ENDIF 108 sss_m(:,:) = zcoef * zts(:,:,jp_sal) 109 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 93 110 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = zcoef * ( sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) ) 94 ELSE ; ssh_m(:,:) = zcoef * 111 ELSE ; ssh_m(:,:) = zcoef * sshn(:,:) 95 112 ENDIF 113 ! 114 IF( lk_vvl ) fse3t_m(:,:) = zcoef * zdep(:,:) 96 115 ! ! ---------------------------------------- ! 97 116 ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN ! Initialisation: New mean computation ! … … 107 126 ! ! Cumulate at each time step ! 108 127 ! ! ---------------------------------------- ! 109 DO jj = 1, jpj 110 DO ji = 1, jpi 111 ssu_m(ji,jj) = ssu_m(ji,jj) + ub(ji,jj,miku(ji,jj)) 112 ssv_m(ji,jj) = ssv_m(ji,jj) + vb(ji,jj,mikv(ji,jj)) 113 sst_m(ji,jj) = sst_m(ji,jj) + tsn(ji,jj,mikt(ji,jj),jp_tem) 114 sss_m(ji,jj) = sss_m(ji,jj) + tsn(ji,jj,mikt(ji,jj),jp_sal) 115 IF( lk_vvl ) fse3t_m(ji,jj) = fse3t_m(ji,jj) + fse3t_n(ji,jj,mikt(ji,jj)) 116 END DO 117 END DO 118 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 119 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 128 ssu_m(:,:) = ssu_m(:,:) + zub(:,:) 129 ssv_m(:,:) = ssv_m(:,:) + zvb(:,:) 130 IF( ln_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 131 ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 132 ENDIF 133 sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal) 134 ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) 135 IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 120 136 ELSE ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) 121 137 ENDIF 138 ! 139 IF( lk_vvl ) fse3t_m(:,:) = fse3t_m(:,:) + zdep(:,:) 122 140 123 141 ! ! ---------------------------------------- ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90
r4624 r4946 10 10 !!---------------------------------------------------------------------- 11 11 !! sbc_ssr : add to sbc a restoring term toward SST/SSS climatology 12 !! sbc_ssr_init : initialisation of surface restoring 12 13 !!---------------------------------------------------------------------- 13 14 USE oce ! ocean dynamics and tracers … … 16 17 USE phycst ! physical constants 17 18 USE sbcrnf ! surface boundary condition : runoffs 19 ! 18 20 USE fldread ! read input fields 19 21 USE iom ! I/O manager … … 93 95 ! 94 96 IF( nn_sstr == 1 ) THEN !* Temperature restoring term 95 !CDIR COLLAPSE96 97 DO jj = 1, jpj 97 98 DO ji = 1, jpi -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r4726 r4946 15 15 !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d 16 16 !! - ! 2003-08 (G. Madec) F90, free form 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) 18 18 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 19 !! - ! 2010-10 (G. Nurser, G. Madec) add eos_alpbet used in ldfslp 19 !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp 20 !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation 21 !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state 22 !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module 23 !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 20 24 !!---------------------------------------------------------------------- 21 25 … … 23 27 !! eos : generic interface of the equation of state 24 28 !! eos_insitu : Compute the in situ density 25 !! eos_insitu_pot : Compute the insitu and surface referenced potential 26 !! volumic mass 29 !! eos_insitu_pot : Compute the insitu and surface referenced potential volumic mass 27 30 !! eos_insitu_2d : Compute the in situ density for 2d fields 28 !! eos_bn2 : Compute the Brunt-Vaisala frequency 29 !! eos_alpbet : calculates the in situ thermal/haline expansion ratio 30 !! tfreez : Compute the surface freezing temperature 31 !! bn2 : Compute the Brunt-Vaisala frequency 32 !! eos_rab : generic interface of in situ thermal/haline expansion ratio 33 !! eos_rab_3d : compute in situ thermal/haline expansion ratio 34 !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields 35 !! eos_fzp_2d : freezing temperature for 2d fields 36 !! eos_fzp_0d : freezing temperature for scalar 31 37 !! eos_init : set eos parameters (namelist) 32 38 !!---------------------------------------------------------------------- 33 39 USE dom_oce ! ocean space and time domain 34 40 USE phycst ! physical constants 35 USE zdfddm ! vertical physics: double diffusion41 ! 36 42 USE in_out_manager ! I/O manager 37 43 USE lib_mpp ! MPP library 44 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 45 USE prtctl ! Print control 39 46 USE wrk_nemo ! Memory Allocation 47 USE lbclnk ! ocean lateral boundary conditions 40 48 USE timing ! Timing 41 49 … … 47 55 MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 48 56 END INTERFACE 49 INTERFACE bn2 50 MODULE PROCEDURE eos_bn2 57 ! 58 INTERFACE eos_rab 59 MODULE PROCEDURE rab_3d, rab_2d, rab_0d 51 60 END INTERFACE 52 53 PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules 54 PUBLIC eos_init ! called by istate module 55 PUBLIC bn2 ! called by step module 56 PUBLIC eos_alpbet ! called by ldfslp module 57 PUBLIC tfreez ! called by sbcice_... modules and sbcisf module 58 PUBLIC tfreez1D ! called by trasbc modules 59 60 ! !!* Namelist (nameos) * 61 INTEGER , PUBLIC :: nn_eos !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 62 REAL(wp), PUBLIC :: rn_alpha !: thermal expension coeff. (linear equation of state) 63 REAL(wp), PUBLIC :: rn_beta !: saline expension coeff. (linear equation of state) 64 65 REAL(wp), PUBLIC :: ralpbet !: alpha / beta ratio 61 ! 62 INTERFACE eos_fzp 63 MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d 64 END INTERFACE 65 ! 66 PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules 67 PUBLIC bn2 ! called by step module 68 PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl 69 PUBLIC eos_pt_from_ct ! called by sbcssm 70 PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules 71 PUBLIC eos_pen ! used for pe diagnostics in trdpen module 72 PUBLIC eos_init ! called by istate module 73 74 ! !!* Namelist (nameos) * 75 INTEGER , PUBLIC :: nn_eos = 0 !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 76 LOGICAL , PUBLIC :: ln_useCT = .FALSE. ! determine if eos_pt_from_ct is used to compute sst_m 77 78 ! !!! simplified eos coefficients 79 ! default value: Vallis 2006 80 REAL(wp) :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. 81 REAL(wp) :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. 82 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 83 REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 84 REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T 85 REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S 86 REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt 87 88 ! TEOS10/EOS80 parameters 89 REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS 90 91 ! EOS parameters 92 REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 93 REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 94 REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 95 REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 96 REAL(wp) :: EOS040 , EOS140 , EOS240 97 REAL(wp) :: EOS050 , EOS150 98 REAL(wp) :: EOS060 99 REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 100 REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 101 REAL(wp) :: EOS021 , EOS121 , EOS221 102 REAL(wp) :: EOS031 , EOS131 103 REAL(wp) :: EOS041 104 REAL(wp) :: EOS002 , EOS102 , EOS202 105 REAL(wp) :: EOS012 , EOS112 106 REAL(wp) :: EOS022 107 REAL(wp) :: EOS003 , EOS103 108 REAL(wp) :: EOS013 109 110 ! ALPHA parameters 111 REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 112 REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 113 REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 114 REAL(wp) :: ALP030 , ALP130 , ALP230 115 REAL(wp) :: ALP040 , ALP140 116 REAL(wp) :: ALP050 117 REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 118 REAL(wp) :: ALP011 , ALP111 , ALP211 119 REAL(wp) :: ALP021 , ALP121 120 REAL(wp) :: ALP031 121 REAL(wp) :: ALP002 , ALP102 122 REAL(wp) :: ALP012 123 REAL(wp) :: ALP003 124 125 ! BETA parameters 126 REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 127 REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 128 REAL(wp) :: BET020 , BET120 , BET220 , BET320 129 REAL(wp) :: BET030 , BET130 , BET230 130 REAL(wp) :: BET040 , BET140 131 REAL(wp) :: BET050 132 REAL(wp) :: BET001 , BET101 , BET201 , BET301 133 REAL(wp) :: BET011 , BET111 , BET211 134 REAL(wp) :: BET021 , BET121 135 REAL(wp) :: BET031 136 REAL(wp) :: BET002 , BET102 137 REAL(wp) :: BET012 138 REAL(wp) :: BET003 139 140 ! PEN parameters 141 REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 142 REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 143 REAL(wp) :: PEN020 , PEN120 , PEN220 144 REAL(wp) :: PEN030 , PEN130 145 REAL(wp) :: PEN040 146 REAL(wp) :: PEN001 , PEN101 , PEN201 147 REAL(wp) :: PEN011 , PEN111 148 REAL(wp) :: PEN021 149 REAL(wp) :: PEN002 , PEN102 150 REAL(wp) :: PEN012 151 152 ! ALPHA_PEN parameters 153 REAL(wp) :: APE000 , APE100 , APE200 , APE300 154 REAL(wp) :: APE010 , APE110 , APE210 155 REAL(wp) :: APE020 , APE120 156 REAL(wp) :: APE030 157 REAL(wp) :: APE001 , APE101 158 REAL(wp) :: APE011 159 REAL(wp) :: APE002 160 161 ! BETA_PEN parameters 162 REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 163 REAL(wp) :: BPE010 , BPE110 , BPE210 164 REAL(wp) :: BPE020 , BPE120 165 REAL(wp) :: BPE030 166 REAL(wp) :: BPE001 , BPE101 167 REAL(wp) :: BPE011 168 REAL(wp) :: BPE002 66 169 67 170 !! * Substitutions … … 69 172 # include "vectopt_loop_substitute.h90" 70 173 !!---------------------------------------------------------------------- 71 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)174 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 72 175 !! $Id$ 73 176 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 83 186 !! defined through the namelist parameter nn_eos. 84 187 !! 85 !! ** Method : 3 cases: 86 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 87 !! the in situ density is computed directly as a function of 88 !! potential temperature relative to the surface (the opa t 89 !! variable), salt and pressure (assuming no pressure variation 90 !! along geopotential surfaces, i.e. the pressure p in decibars 91 !! is approximated by the depth in meters. 92 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 93 !! with pressure p decibars 94 !! potential temperature t deg celsius 95 !! salinity s psu 96 !! reference volumic mass rau0 kg/m**3 97 !! in situ volumic mass rho kg/m**3 98 !! in situ density anomalie prd no units 99 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 100 !! t = 40 deg celcius, s=40 psu 101 !! nn_eos = 1 : linear equation of state function of temperature only 102 !! prd(t) = 0.0285 - rn_alpha * t 103 !! nn_eos = 2 : linear equation of state function of temperature and 104 !! salinity 105 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 106 !! Note that no boundary condition problem occurs in this routine 107 !! as pts are defined over the whole domain. 188 !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 189 !! with prd in situ density anomaly no units 190 !! t TEOS10: CT or EOS80: PT Celsius 191 !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu 192 !! z depth meters 193 !! rho in situ density kg/m^3 194 !! rau0 reference density kg/m^3 195 !! 196 !! nn_eos = -1 : polynomial TEOS-10 equation of state is used for rho(t,s,z). 197 !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celcius, sa=35.5 g/kg 198 !! 199 !! nn_eos = 0 : polynomial EOS-80 equation of state is used for rho(t,s,z). 200 !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celcius, sp=35.5 psu 201 !! 202 !! nn_eos = 1 : simplified equation of state 203 !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0 204 !! linear case function of T only: rn_alpha<>0, other coefficients = 0 205 !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 206 !! Vallis like equation: use default values of coefficients 108 207 !! 109 208 !! ** Action : compute prd , the in situ density (no units) 110 209 !! 111 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 112 !!---------------------------------------------------------------------- 113 !! 114 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 115 ! ! 2 : salinity [psu] 116 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 117 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 118 !! 119 INTEGER :: ji, jj, jk ! dummy loop indices 120 REAL(wp) :: zt , zs , zh , zsr ! local scalars 121 REAL(wp) :: zr1, zr2, zr3, zr4 ! - - 122 REAL(wp) :: zrhop, ze, zbw, zb ! - - 123 REAL(wp) :: zd , zc , zaw, za ! - - 124 REAL(wp) :: zb1, za1, zkw, zk0 ! - - 125 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 126 !!---------------------------------------------------------------------- 127 128 ! 129 IF( nn_timing == 1 ) CALL timing_start('eos') 130 ! 131 CALL wrk_alloc( jpi, jpj, jpk, zws ) 210 !! References : Roquet et al, Ocean Modelling, in preparation (2014) 211 !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 212 !! TEOS-10 Manual, 2010 213 !!---------------------------------------------------------------------- 214 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 215 ! ! 2 : salinity [psu] 216 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 217 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 218 ! 219 INTEGER :: ji, jj, jk ! dummy loop indices 220 REAL(wp) :: zt , zh , zs , ztm ! local scalars 221 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 222 !!---------------------------------------------------------------------- 223 ! 224 IF( nn_timing == 1 ) CALL timing_start('eos-insitu') 132 225 ! 133 226 SELECT CASE( nn_eos ) 134 227 ! 135 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 136 !CDIR NOVERRCHK 137 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 228 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 138 229 ! 139 230 DO jk = 1, jpkm1 140 231 DO jj = 1, jpj 141 232 DO ji = 1, jpi 142 zt = pts (ji,jj,jk,jp_tem) 143 zs = pts (ji,jj,jk,jp_sal) 144 zh = pdep(ji,jj,jk) ! depth 145 zsr= zws (ji,jj,jk) ! square root salinity 146 ! 147 ! compute volumic mass pure water at atm pressure 148 zr1= ( ( ( ( 6.536332e-9_wp *zt - 1.120083e-6_wp )*zt + 1.001685e-4_wp )*zt & 149 & -9.095290e-3_wp )*zt + 6.793952e-2_wp )*zt + 999.842594_wp 150 ! seawater volumic mass atm pressure 151 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 152 & -4.0899e-3_wp ) *zt+0.824493_wp 153 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 154 zr4= 4.8314e-4_wp 155 ! 156 ! potential volumic mass (reference to the surface) 157 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 158 ! 159 ! add the compression terms 160 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 161 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 162 zb = zbw + ze * zs 163 ! 164 zd = -2.042967e-2_wp 165 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 166 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 167 za = ( zd*zsr + zc ) *zs + zaw 168 ! 169 zb1= (-0.1909078_wp*zt+7.390729_wp ) *zt-55.87545_wp 170 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp) *zt-65.00517_wp ) *zt+1044.077_wp 171 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 172 zk0= ( zb1*zsr + za1 )*zs + zkw 173 ! 174 ! masked in situ density anomaly 175 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 176 & - rau0 ) * r1_rau0 * tmask(ji,jj,jk) 233 ! 234 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 235 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 236 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 237 ztm = tmask(ji,jj,jk) ! tmask 238 ! 239 zn3 = EOS013*zt & 240 & + EOS103*zs+EOS003 241 ! 242 zn2 = (EOS022*zt & 243 & + EOS112*zs+EOS012)*zt & 244 & + (EOS202*zs+EOS102)*zs+EOS002 245 ! 246 zn1 = (((EOS041*zt & 247 & + EOS131*zs+EOS031)*zt & 248 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 249 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 250 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 251 ! 252 zn0 = (((((EOS060*zt & 253 & + EOS150*zs+EOS050)*zt & 254 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 255 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 256 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 257 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 258 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 259 ! 260 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 261 ! 262 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 263 ! 177 264 END DO 178 265 END DO 179 266 END DO 180 267 ! 181 CASE( 1 ) !== Linear formulation function of temperature only ==! 268 CASE( 1 ) !== simplified EOS ==! 269 ! 182 270 DO jk = 1, jpkm1 183 prd(:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 271 DO jj = 1, jpj 272 DO ji = 1, jpi 273 zt = pts (ji,jj,jk,jp_tem) - 10._wp 274 zs = pts (ji,jj,jk,jp_sal) - 35._wp 275 zh = pdep (ji,jj,jk) 276 ztm = tmask(ji,jj,jk) 277 ! 278 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & 279 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & 280 & - rn_nu * zt * zs 281 ! 282 prd(ji,jj,jk) = zn * r1_rau0 * ztm ! density anomaly (masked) 283 END DO 284 END DO 184 285 END DO 185 286 ! 186 CASE( 2 ) !== Linear formulation function of temperature and salinity ==!187 DO jk = 1, jpkm1188 prd(:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk)189 END DO190 !191 287 END SELECT 192 288 ! 193 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos : ', ovlap=1, kdim=jpk ) 194 ! 195 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 196 ! 197 IF( nn_timing == 1 ) CALL timing_stop('eos') 289 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', ovlap=1, kdim=jpk ) 290 ! 291 IF( nn_timing == 1 ) CALL timing_stop('eos-insitu') 198 292 ! 199 293 END SUBROUTINE eos_insitu … … 209 303 !! namelist parameter nn_eos. 210 304 !! 211 !! ** Method :212 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state.213 !! the in situ density is computed directly as a function of214 !! potential temperature relative to the surface (the opa t215 !! variable), salt and pressure (assuming no pressure variation216 !! along geopotential surfaces, i.e. the pressure p in decibars217 !! is approximated by the depth in meters.218 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0219 !! rhop(t,s) = rho(t,s,0)220 !! with pressure p decibars221 !! potential temperature t deg celsius222 !! salinity s psu223 !! reference volumic mass rau0 kg/m**3224 !! in situ volumic mass rho kg/m**3225 !! in situ density anomalie prd no units226 !!227 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar,228 !! t = 40 deg celcius, s=40 psu229 !!230 !! nn_eos = 1 : linear equation of state function of temperature only231 !! prd(t) = ( rho(t) - rau0 ) / rau0 = 0.028 - rn_alpha * t232 !! rhop(t,s) = rho(t,s)233 !!234 !! nn_eos = 2 : linear equation of state function of temperature and235 !! salinity236 !! prd(t,s) = ( rho(t,s) - rau0 ) / rau0237 !! = rn_beta * s - rn_alpha * tn - 1.238 !! rhop(t,s) = rho(t,s)239 !! Note that no boundary condition problem occurs in this routine240 !! as (tn,sn) or (ta,sa) are defined over the whole domain.241 !!242 305 !! ** Action : - prd , the in situ density (no units) 243 306 !! - prhop, the potential volumic mass (Kg/m3) 244 307 !! 245 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 246 !! Brown and Campana, Mon. Weather Rev., 1978 247 !!---------------------------------------------------------------------- 248 !! 308 !!---------------------------------------------------------------------- 249 309 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 250 310 ! ! 2 : salinity [psu] … … 253 313 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 254 314 ! 255 INTEGER :: ji, jj, jk ! dummy loop indices 256 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! local scalars 257 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0 ! - - 258 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 259 !!---------------------------------------------------------------------- 260 ! 261 IF( nn_timing == 1 ) CALL timing_start('eos-p') 262 ! 263 CALL wrk_alloc( jpi, jpj, jpk, zws ) 315 INTEGER :: ji, jj, jk ! dummy loop indices 316 REAL(wp) :: zt , zh , zs , ztm ! local scalars 317 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 318 !!---------------------------------------------------------------------- 319 ! 320 IF( nn_timing == 1 ) CALL timing_start('eos-pot') 264 321 ! 265 322 SELECT CASE ( nn_eos ) 266 323 ! 267 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 268 !CDIR NOVERRCHK 269 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 324 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 270 325 ! 271 326 DO jk = 1, jpkm1 272 327 DO jj = 1, jpj 273 328 DO ji = 1, jpi 274 zt = pts (ji,jj,jk,jp_tem) 275 zs = pts (ji,jj,jk,jp_sal) 276 zh = pdep(ji,jj,jk) ! depth 277 zsr= zws (ji,jj,jk) ! square root salinity 278 ! 279 ! compute volumic mass pure water at atm pressure 280 zr1= ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 281 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 282 ! seawater volumic mass atm pressure 283 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 284 & -4.0899e-3_wp ) *zt+0.824493_wp 285 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 286 zr4= 4.8314e-4_wp 287 ! 288 ! potential volumic mass (reference to the surface) 289 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 290 ! 291 ! save potential volumic mass 292 prhop(ji,jj,jk) = zrhop * tmask(ji,jj,jk) 293 ! 294 ! add the compression terms 295 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 296 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 297 zb = zbw + ze * zs 298 ! 299 zd = -2.042967e-2_wp 300 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 301 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 302 za = ( zd*zsr + zc ) *zs + zaw 303 ! 304 zb1= ( -0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 305 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt + 1044.077_wp 306 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 307 zk0= ( zb1*zsr + za1 )*zs + zkw 308 ! 309 ! masked in situ density anomaly 310 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 311 & - rau0 ) * r1_rau0 * tmask(ji,jj,jk) 329 ! 330 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 331 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 332 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 333 ztm = tmask(ji,jj,jk) ! tmask 334 ! 335 zn3 = EOS013*zt & 336 & + EOS103*zs+EOS003 337 ! 338 zn2 = (EOS022*zt & 339 & + EOS112*zs+EOS012)*zt & 340 & + (EOS202*zs+EOS102)*zs+EOS002 341 ! 342 zn1 = (((EOS041*zt & 343 & + EOS131*zs+EOS031)*zt & 344 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 345 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 346 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 347 ! 348 zn0 = (((((EOS060*zt & 349 & + EOS150*zs+EOS050)*zt & 350 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 351 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 352 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 353 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 354 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 355 ! 356 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 357 ! 358 prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface 359 ! 360 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 312 361 END DO 313 362 END DO 314 363 END DO 315 364 ! 316 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 365 CASE( 1 ) !== simplified EOS ==! 366 ! 317 367 DO jk = 1, jpkm1 318 prd (:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 319 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask(:,:,jk) 368 DO jj = 1, jpj 369 DO ji = 1, jpi 370 zt = pts (ji,jj,jk,jp_tem) - 10._wp 371 zs = pts (ji,jj,jk,jp_sal) - 35._wp 372 zh = pdep (ji,jj,jk) 373 ztm = tmask(ji,jj,jk) 374 ! ! potential density referenced at the surface 375 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & 376 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & 377 & - rn_nu * zt * zs 378 prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 379 ! ! density anomaly (masked) 380 zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 381 prd(ji,jj,jk) = zn * r1_rau0 * ztm 382 ! 383 END DO 384 END DO 320 385 END DO 321 386 ! 322 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==!323 DO jk = 1, jpkm1324 prd (:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk)325 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask(:,:,jk)326 END DO327 !328 387 END SELECT 329 388 ! 330 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-p: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 331 ! 332 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 333 ! 334 IF( nn_timing == 1 ) CALL timing_stop('eos-p') 389 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 390 ! 391 IF( nn_timing == 1 ) CALL timing_stop('eos-pot') 335 392 ! 336 393 END SUBROUTINE eos_insitu_pot … … 345 402 !! defined through the namelist parameter nn_eos. * 2D field case 346 403 !! 347 !! ** Method : 348 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 349 !! the in situ density is computed directly as a function of 350 !! potential temperature relative to the surface (the opa t 351 !! variable), salt and pressure (assuming no pressure variation 352 !! along geopotential surfaces, i.e. the pressure p in decibars 353 !! is approximated by the depth in meters. 354 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 355 !! with pressure p decibars 356 !! potential temperature t deg celsius 357 !! salinity s psu 358 !! reference volumic mass rau0 kg/m**3 359 !! in situ volumic mass rho kg/m**3 360 !! in situ density anomalie prd no units 361 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 362 !! t = 40 deg celcius, s=40 psu 363 !! nn_eos = 1 : linear equation of state function of temperature only 364 !! prd(t) = 0.0285 - rn_alpha * t 365 !! nn_eos = 2 : linear equation of state function of temperature and 366 !! salinity 367 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 368 !! Note that no boundary condition problem occurs in this routine 369 !! as pts are defined over the whole domain. 370 !! 371 !! ** Action : - prd , the in situ density (no units) 372 !! 373 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 374 !!---------------------------------------------------------------------- 375 !! 404 !! ** Action : - prd , the in situ density (no units) (unmasked) 405 !! 406 !!---------------------------------------------------------------------- 376 407 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 377 408 ! ! 2 : salinity [psu] 378 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m]409 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 379 410 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: prd ! in situ density 380 !! 381 INTEGER :: ji, jj ! dummy loop indices 382 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! temporary scalars 383 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zmask ! - - 384 REAL(wp), POINTER, DIMENSION(:,:) :: zws 385 !!---------------------------------------------------------------------- 386 ! 387 IF( nn_timing == 1 ) CALL timing_start('eos2d') 388 ! 389 CALL wrk_alloc( jpi, jpj, zws ) 390 ! 391 411 ! 412 INTEGER :: ji, jj, jk ! dummy loop indices 413 REAL(wp) :: zt , zh , zs ! local scalars 414 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 415 !!---------------------------------------------------------------------- 416 ! 417 IF( nn_timing == 1 ) CALL timing_start('eos2d') 418 ! 392 419 prd(:,:) = 0._wp 393 420 ! 394 421 SELECT CASE( nn_eos ) 395 422 ! 396 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 397 ! 398 !CDIR NOVERRCHK 399 DO jj = 1, jpj 400 !CDIR NOVERRCHK 401 DO ji = 1, jpi ! vector opt. 402 zws(ji,jj) = SQRT( ABS( pts(ji,jj,jp_sal) ) ) 423 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 424 ! 425 DO jj = 1, jpjm1 426 DO ji = 1, fs_jpim1 ! vector opt. 427 ! 428 zh = pdep(ji,jj) * r1_Z0 ! depth 429 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 430 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 431 ! 432 zn3 = EOS013*zt & 433 & + EOS103*zs+EOS003 434 ! 435 zn2 = (EOS022*zt & 436 & + EOS112*zs+EOS012)*zt & 437 & + (EOS202*zs+EOS102)*zs+EOS002 438 ! 439 zn1 = (((EOS041*zt & 440 & + EOS131*zs+EOS031)*zt & 441 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 442 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 443 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 444 ! 445 zn0 = (((((EOS060*zt & 446 & + EOS150*zs+EOS050)*zt & 447 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 448 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 449 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 450 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 451 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 452 ! 453 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 454 ! 455 prd(ji,jj) = zn * r1_rau0 - 1._wp ! unmasked in situ density anomaly 456 ! 403 457 END DO 404 458 END DO 405 DO jj = 1, jpj 406 DO ji = 1, jpi ! vector opt. 407 zmask = ssmask(ji,jj) ! land/sea bottom mask = surf. mask 408 zt = pts (ji,jj,jp_tem) ! interpolated T 409 zs = pts (ji,jj,jp_sal) ! interpolated S 410 zsr = zws (ji,jj) ! square root of interpolated S 411 zh = pdep (ji,jj) ! depth at the partial step level 412 ! 413 ! compute volumic mass pure water at atm pressure 414 zr1 = ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 415 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 416 ! seawater volumic mass atm pressure 417 zr2 = ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp )*zt+7.6438e-5_wp ) *zt & 418 & -4.0899e-3_wp ) *zt+0.824493_wp 419 zr3 = ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 420 zr4 = 4.8314e-4_wp 421 ! 422 ! potential volumic mass (reference to the surface) 423 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 424 ! 425 ! add the compression terms 426 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 427 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 428 zb = zbw + ze * zs 429 ! 430 zd = -2.042967e-2_wp 431 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 432 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt -4.721788_wp 433 za = ( zd*zsr + zc ) *zs + zaw 434 ! 435 zb1= (-0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 436 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt+1044.077_wp 437 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt & 438 & +2098.925_wp ) *zt+190925.6_wp 439 zk0= ( zb1*zsr + za1 )*zs + zkw 440 ! 441 ! masked in situ density anomaly 442 prd(ji,jj) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) - rau0 ) / rau0 * zmask 459 ! 460 CALL lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 461 ! 462 CASE( 1 ) !== simplified EOS ==! 463 ! 464 DO jj = 1, jpjm1 465 DO ji = 1, fs_jpim1 ! vector opt. 466 ! 467 zt = pts (ji,jj,jp_tem) - 10._wp 468 zs = pts (ji,jj,jp_sal) - 35._wp 469 zh = pdep (ji,jj) ! depth at the partial step level 470 ! 471 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & 472 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & 473 & - rn_nu * zt * zs 474 ! 475 prd(ji,jj) = zn * r1_rau0 ! unmasked in situ density anomaly 476 ! 443 477 END DO 444 478 END DO 445 479 ! 446 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 447 DO jj = 1, jpj 448 DO ji = 1, jpi ! vector opt. 449 prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * ssmask(ji,jj) 450 END DO 451 END DO 452 ! 453 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 454 DO jj = 1, jpj 455 DO ji = 1, jpi ! vector opt. 456 prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * ssmask(ji,jj) 457 END DO 458 END DO 480 CALL lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 459 481 ! 460 482 END SELECT 461 483 ! 462 484 IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 463 485 ! 464 CALL wrk_dealloc( jpi, jpj, zws ) 465 ! 466 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 486 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 467 487 ! 468 488 END SUBROUTINE eos_insitu_2d 469 489 470 490 471 SUBROUTINE eos_bn2( pts, pn2 ) 472 !!---------------------------------------------------------------------- 473 !! *** ROUTINE eos_bn2 *** 474 !! 475 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the time- 476 !! step of the input arguments 477 !! 478 !! ** Method : 479 !! * nn_eos = 0 : UNESCO sea water properties 480 !! The brunt-vaisala frequency is computed using the polynomial 481 !! polynomial expression of McDougall (1987): 482 !! N^2 = grav * beta * ( alpha/beta*dk[ t ] - dk[ s ] )/e3w 483 !! If lk_zdfddm=T, the heat/salt buoyancy flux ratio Rrau is 484 !! computed and used in zdfddm module : 485 !! Rrau = alpha/beta * ( dk[ t ] / dk[ s ] ) 486 !! * nn_eos = 1 : linear equation of state (temperature only) 487 !! N^2 = grav * rn_alpha * dk[ t ]/e3w 488 !! * nn_eos = 2 : linear equation of state (temperature & salinity) 489 !! N^2 = grav * (rn_alpha * dk[ t ] - rn_beta * dk[ s ] ) / e3w 490 !! The use of potential density to compute N^2 introduces e r r o r 491 !! in the sign of N^2 at great depths. We recommand the use of 492 !! nn_eos = 0, except for academical studies. 493 !! Macro-tasked on horizontal slab (jk-loop) 494 !! N.B. N^2 is set to zero at the first level (JK=1) in inidtr 495 !! and is never used at this level. 496 !! 497 !! ** Action : - pn2 : the brunt-vaisala frequency 498 !! 499 !! References : McDougall, J. Phys. Oceanogr., 17, 1950-1964, 1987. 500 !!---------------------------------------------------------------------- 501 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 502 ! ! 2 : salinity [psu] 503 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency [s-1] 504 !! 505 INTEGER :: ji, jj, jk ! dummy loop indices 506 REAL(wp) :: zgde3w, zt, zs, zh, zalbet, zbeta ! local scalars 507 #if defined key_zdfddm 508 REAL(wp) :: zds ! local scalars 509 #endif 510 !!---------------------------------------------------------------------- 511 512 ! 513 IF( nn_timing == 1 ) CALL timing_start('bn2') 514 ! 515 ! pn2 : interior points only (2=< jk =< jpkm1 ) 516 ! -------------------------- 517 ! 518 SELECT CASE( nn_eos ) 519 ! 520 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 521 DO jk = 2, jpkm1 491 SUBROUTINE rab_3d( pts, pab ) 492 !!---------------------------------------------------------------------- 493 !! *** ROUTINE rab_3d *** 494 !! 495 !! ** Purpose : Calculates thermal/haline expansion ratio at T-points 496 !! 497 !! ** Method : calculates alpha / beta at T-points 498 !! 499 !! ** Action : - pab : thermal/haline expansion ratio at T-points 500 !!---------------------------------------------------------------------- 501 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 502 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 503 ! 504 INTEGER :: ji, jj, jk ! dummy loop indices 505 REAL(wp) :: zt , zh , zs , ztm ! local scalars 506 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 507 !!---------------------------------------------------------------------- 508 ! 509 IF( nn_timing == 1 ) CALL timing_start('rab_3d') 510 ! 511 SELECT CASE ( nn_eos ) 512 ! 513 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 514 ! 515 DO jk = 1, jpkm1 522 516 DO jj = 1, jpj 523 517 DO ji = 1, jpi 524 zgde3w = grav / fse3w(ji,jj,jk) 525 zt = 0.5_wp * ( pts(ji,jj,jk,jp_tem) + pts(ji,jj,jk-1,jp_tem) ) ! potential temperature at w-pt 526 zs = 0.5_wp * ( pts(ji,jj,jk,jp_sal) + pts(ji,jj,jk-1,jp_sal) ) - 35.0_wp ! salinity anomaly (s-35) at w-pt 527 zh = fsdepw(ji,jj,jk) ! depth in meters at w-point 528 ! 529 zalbet = ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt & ! ratio alpha/beta 530 & - 0.203814e-03_wp ) * zt & 531 & + 0.170907e-01_wp ) * zt & 532 & + 0.665157e-01_wp & 533 & + ( - 0.678662e-05_wp * zs & 534 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs & 535 & + ( ( - 0.302285e-13_wp * zh & 536 & - 0.251520e-11_wp * zs & 537 & + 0.512857e-12_wp * zt * zt ) * zh & 538 & - 0.164759e-06_wp * zs & 539 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt & 540 & + 0.380374e-04_wp ) * zh 541 ! 542 zbeta = ( ( -0.415613e-09_wp * zt + 0.555579e-07_wp ) * zt & ! beta 543 & - 0.301985e-05_wp ) * zt & 544 & + 0.785567e-03_wp & 545 & + ( 0.515032e-08_wp * zs & 546 & + 0.788212e-08_wp * zt - 0.356603e-06_wp ) * zs & 547 & + ( ( 0.121551e-17_wp * zh & 548 & - 0.602281e-15_wp * zs & 549 & - 0.175379e-14_wp * zt + 0.176621e-12_wp ) * zh & 550 & + 0.408195e-10_wp * zs & 551 & + ( - 0.213127e-11_wp * zt + 0.192867e-09_wp ) * zt & 552 & - 0.121555e-07_wp ) * zh 553 ! 554 pn2(ji,jj,jk) = zgde3w * zbeta * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) & ! N^2 555 & * ( zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 556 & - ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) 557 #if defined key_zdfddm 558 ! !!bug **** caution a traiter zds=dk[S]= 0 !!!! 559 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ! Rrau = (alpha / beta) (dk[t] / dk[s]) 560 IF ( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 561 rrau(ji,jj,jk) = zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 562 #endif 518 ! 519 zh = fsdept(ji,jj,jk) * r1_Z0 ! depth 520 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 521 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 522 ztm = tmask(ji,jj,jk) ! tmask 523 ! 524 ! alpha 525 zn3 = ALP003 526 ! 527 zn2 = ALP012*zt + ALP102*zs+ALP002 528 ! 529 zn1 = ((ALP031*zt & 530 & + ALP121*zs+ALP021)*zt & 531 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 532 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 533 ! 534 zn0 = ((((ALP050*zt & 535 & + ALP140*zs+ALP040)*zt & 536 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 537 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 538 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 539 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 540 ! 541 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 542 ! 543 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 544 ! 545 ! beta 546 zn3 = BET003 547 ! 548 zn2 = BET012*zt + BET102*zs+BET002 549 ! 550 zn1 = ((BET031*zt & 551 & + BET121*zs+BET021)*zt & 552 & + (BET211*zs+BET111)*zs+BET011)*zt & 553 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 554 ! 555 zn0 = ((((BET050*zt & 556 & + BET140*zs+BET040)*zt & 557 & + (BET230*zs+BET130)*zs+BET030)*zt & 558 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 559 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 560 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 561 ! 562 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 563 ! 564 pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 565 ! 563 566 END DO 564 567 END DO 565 568 END DO 566 569 ! 567 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 568 DO jk = 2, jpkm1 569 pn2(:,:,jk) = grav * rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) & 570 & / fse3w(:,:,jk) * tmask(:,:,jk) * tmask(:,:,jk-1) 571 END DO 572 ! 573 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 574 DO jk = 2, jpkm1 575 pn2(:,:,jk) = grav * ( rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) & 576 & - rn_beta * ( pts(:,:,jk-1,jp_sal) - pts(:,:,jk,jp_sal) ) ) & 577 & / fse3w(:,:,jk) * tmask(:,:,jk) * tmask(:,:,jk-1) 578 END DO 579 #if defined key_zdfddm 580 DO jk = 2, jpkm1 ! Rrau = (alpha / beta) (dk[t] / dk[s]) 570 CASE( 1 ) !== simplified EOS ==! 571 ! 572 DO jk = 1, jpkm1 581 573 DO jj = 1, jpj 582 574 DO ji = 1, jpi 583 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) 584 IF ( ABS( zds ) <= 1.e-20_wp ) zds = 1.e-20_wp 585 rrau(ji,jj,jk) = ralpbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 575 zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 576 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 577 zh = fsdept(ji,jj,jk) ! depth in meters at t-point 578 ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask 579 ! 580 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 581 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm ! alpha 582 ! 583 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 584 pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm ! beta 585 ! 586 586 END DO 587 587 END DO 588 588 END DO 589 #endif590 END SELECT591 592 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk )593 #if defined key_zdfddm594 IF(ln_ctl) CALL prt_ctl( tab3d_1=rrau, clinfo1=' rrau : ', ovlap=1, kdim=jpk )595 #endif596 !597 IF( nn_timing == 1 ) CALL timing_stop('bn2')598 !599 END SUBROUTINE eos_bn2600 601 602 SUBROUTINE eos_alpbet( pts, palpbet, beta0 )603 !!----------------------------------------------------------------------604 !! *** ROUTINE eos_alpbet ***605 !!606 !! ** Purpose : Calculates the in situ thermal/haline expansion ratio at T-points607 !!608 !! ** Method : calculates alpha / beta ratio at T-points609 !! * nn_eos = 0 : UNESCO sea water properties610 !! The alpha/beta ratio is returned as 3-D array palpbet using the polynomial611 !! polynomial expression of McDougall (1987).612 !! Scalar beta0 is returned = 1.613 !! * nn_eos = 1 : linear equation of state (temperature only)614 !! The ratio is undefined, so we return alpha as palpbet615 !! Scalar beta0 is returned = 0.616 !! * nn_eos = 2 : linear equation of state (temperature & salinity)617 !! The alpha/beta ratio is returned as ralpbet618 !! Scalar beta0 is returned = 1.619 !!620 !! ** Action : - palpbet : thermal/haline expansion ratio at T-points621 !! : beta0 : 1. or 0.622 !!----------------------------------------------------------------------623 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity624 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: palpbet ! thermal/haline expansion ratio625 REAL(wp), INTENT( out) :: beta0 ! set = 1 except with case 1 eos, rho=rho(T)626 !!627 INTEGER :: ji, jj, jk ! dummy loop indices628 REAL(wp) :: zt, zs, zh ! local scalars629 !!----------------------------------------------------------------------630 !631 IF( nn_timing == 1 ) CALL timing_start('eos_alpbet')632 !633 SELECT CASE ( nn_eos )634 !635 CASE ( 0 ) ! Jackett and McDougall (1994) formulation636 DO jk = 1, jpk637 DO jj = 1, jpj638 DO ji = 1, jpi639 zt = pts(ji,jj,jk,jp_tem) ! potential temperature640 zs = pts(ji,jj,jk,jp_sal) - 35._wp ! salinity anomaly (s-35)641 zh = fsdept(ji,jj,jk) ! depth in meters642 !643 palpbet(ji,jj,jk) = &644 & ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt &645 & - 0.203814e-03_wp ) * zt &646 & + 0.170907e-01_wp ) * zt &647 & + 0.665157e-01_wp &648 & + ( - 0.678662e-05_wp * zs &649 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs &650 & + ( ( - 0.302285e-13_wp * zh &651 & - 0.251520e-11_wp * zs &652 & + 0.512857e-12_wp * zt * zt ) * zh &653 & - 0.164759e-06_wp * zs &654 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt &655 & + 0.380374e-04_wp ) * zh656 END DO657 END DO658 END DO659 beta0 = 1._wp660 !661 CASE ( 1 ) !== Linear formulation = F( temperature ) ==!662 palpbet(:,:,:) = rn_alpha663 beta0 = 0._wp664 !665 CASE ( 2 ) !== Linear formulation = F( temperature , salinity ) ==!666 palpbet(:,:,:) = ralpbet667 beta0 = 1._wp668 589 ! 669 590 CASE DEFAULT … … 674 595 END SELECT 675 596 ! 676 IF( nn_timing == 1 ) CALL timing_stop('eos_alpbet') 677 ! 678 END SUBROUTINE eos_alpbet 679 680 681 FUNCTION tfreez( psal, pdep ) RESULT( ptf ) 597 IF(ln_ctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 598 & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 599 ! 600 IF( nn_timing == 1 ) CALL timing_stop('rab_3d') 601 ! 602 END SUBROUTINE rab_3d 603 604 SUBROUTINE rab_2d( pts, pdep, pab ) 605 !!---------------------------------------------------------------------- 606 !! *** ROUTINE rab_2d *** 607 !! 608 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 609 !! 610 !! ** Action : - pab : thermal/haline expansion ratio at T-points 611 !!---------------------------------------------------------------------- 612 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 613 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 614 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 615 ! 616 INTEGER :: ji, jj, jk ! dummy loop indices 617 REAL(wp) :: zt , zh , zs ! local scalars 618 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 619 !!---------------------------------------------------------------------- 620 ! 621 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 622 ! 623 pab(:,:,:) = 0._wp 624 ! 625 SELECT CASE ( nn_eos ) 626 ! 627 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 628 ! 629 DO jj = 1, jpjm1 630 DO ji = 1, fs_jpim1 ! vector opt. 631 ! 632 zh = pdep(ji,jj) * r1_Z0 ! depth 633 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 634 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 635 ! 636 ! alpha 637 zn3 = ALP003 638 ! 639 zn2 = ALP012*zt + ALP102*zs+ALP002 640 ! 641 zn1 = ((ALP031*zt & 642 & + ALP121*zs+ALP021)*zt & 643 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 644 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 645 ! 646 zn0 = ((((ALP050*zt & 647 & + ALP140*zs+ALP040)*zt & 648 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 649 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 650 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 651 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 652 ! 653 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 654 ! 655 pab(ji,jj,jp_tem) = zn * r1_rau0 656 ! 657 ! beta 658 zn3 = BET003 659 ! 660 zn2 = BET012*zt + BET102*zs+BET002 661 ! 662 zn1 = ((BET031*zt & 663 & + BET121*zs+BET021)*zt & 664 & + (BET211*zs+BET111)*zs+BET011)*zt & 665 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 666 ! 667 zn0 = ((((BET050*zt & 668 & + BET140*zs+BET040)*zt & 669 & + (BET230*zs+BET130)*zs+BET030)*zt & 670 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 671 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 672 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 673 ! 674 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 675 ! 676 pab(ji,jj,jp_sal) = zn / zs * r1_rau0 677 ! 678 ! 679 END DO 680 END DO 681 ! 682 CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 683 CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 684 ! 685 CASE( 1 ) !== simplified EOS ==! 686 ! 687 DO jj = 1, jpjm1 688 DO ji = 1, fs_jpim1 ! vector opt. 689 ! 690 zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 691 zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 692 zh = pdep (ji,jj) ! depth at the partial step level 693 ! 694 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 695 pab(ji,jj,jp_tem) = zn * r1_rau0 ! alpha 696 ! 697 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 698 pab(ji,jj,jp_sal) = zn * r1_rau0 ! beta 699 ! 700 END DO 701 END DO 702 ! 703 CALL lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 704 CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 705 ! 706 CASE DEFAULT 707 IF(lwp) WRITE(numout,cform_err) 708 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 709 nstop = nstop + 1 710 ! 711 END SELECT 712 ! 713 IF(ln_ctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 714 & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 715 ! 716 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 717 ! 718 END SUBROUTINE rab_2d 719 720 721 SUBROUTINE rab_0d( pts, pdep, pab ) 722 !!---------------------------------------------------------------------- 723 !! *** ROUTINE rab_0d *** 724 !! 725 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 726 !! 727 !! ** Action : - pab : thermal/haline expansion ratio at T-points 728 !!---------------------------------------------------------------------- 729 REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 730 REAL(wp), INTENT(in ) :: pdep ! depth [m] 731 REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 732 ! 733 REAL(wp) :: zt , zh , zs ! local scalars 734 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 735 !!---------------------------------------------------------------------- 736 ! 737 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 738 ! 739 pab(:) = 0._wp 740 ! 741 SELECT CASE ( nn_eos ) 742 ! 743 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 744 ! 745 ! 746 zh = pdep * r1_Z0 ! depth 747 zt = pts (jp_tem) * r1_T0 ! temperature 748 zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 749 ! 750 ! alpha 751 zn3 = ALP003 752 ! 753 zn2 = ALP012*zt + ALP102*zs+ALP002 754 ! 755 zn1 = ((ALP031*zt & 756 & + ALP121*zs+ALP021)*zt & 757 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 758 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 759 ! 760 zn0 = ((((ALP050*zt & 761 & + ALP140*zs+ALP040)*zt & 762 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 763 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 764 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 765 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 766 ! 767 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 768 ! 769 pab(jp_tem) = zn * r1_rau0 770 ! 771 ! beta 772 zn3 = BET003 773 ! 774 zn2 = BET012*zt + BET102*zs+BET002 775 ! 776 zn1 = ((BET031*zt & 777 & + BET121*zs+BET021)*zt & 778 & + (BET211*zs+BET111)*zs+BET011)*zt & 779 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 780 ! 781 zn0 = ((((BET050*zt & 782 & + BET140*zs+BET040)*zt & 783 & + (BET230*zs+BET130)*zs+BET030)*zt & 784 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 785 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 786 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 787 ! 788 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 789 ! 790 pab(jp_sal) = zn / zs * r1_rau0 791 ! 792 ! 793 ! 794 CASE( 1 ) !== simplified EOS ==! 795 ! 796 zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 797 zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 798 zh = pdep ! depth at the partial step level 799 ! 800 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 801 pab(jp_tem) = zn * r1_rau0 ! alpha 802 ! 803 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 804 pab(jp_sal) = zn * r1_rau0 ! beta 805 ! 806 CASE DEFAULT 807 IF(lwp) WRITE(numout,cform_err) 808 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 809 nstop = nstop + 1 810 ! 811 END SELECT 812 ! 813 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 814 ! 815 END SUBROUTINE rab_0d 816 817 818 SUBROUTINE bn2( pts, pab, pn2 ) 819 !!---------------------------------------------------------------------- 820 !! *** ROUTINE bn2 *** 821 !! 822 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the 823 !! time-step of the input arguments 824 !! 825 !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 826 !! where alpha and beta are given in pab, and computed on T-points. 827 !! N.B. N^2 is set one for all to zero at jk=1 in istate module. 828 !! 829 !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point 830 !! 831 !!---------------------------------------------------------------------- 832 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celcius,psu] 833 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celcius-1,psu-1] 834 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 835 ! 836 INTEGER :: ji, jj, jk ! dummy loop indices 837 REAL(wp) :: zaw, zbw, zrw ! local scalars 838 !!---------------------------------------------------------------------- 839 ! 840 IF( nn_timing == 1 ) CALL timing_start('bn2') 841 ! 842 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) 843 DO jj = 1, jpj ! surface and bottom value set to zero one for all in istate.F90 844 DO ji = 1, jpi 845 zrw = ( fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk) ) & 846 & / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 847 ! 848 zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw 849 zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 850 ! 851 pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 852 & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & 853 & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 854 END DO 855 END DO 856 END DO 857 ! 858 IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk ) 859 ! 860 IF( nn_timing == 1 ) CALL timing_stop('bn2') 861 ! 862 END SUBROUTINE bn2 863 864 865 FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) 866 !!---------------------------------------------------------------------- 867 !! *** ROUTINE eos_pt_from_ct *** 868 !! 869 !! ** Purpose : Compute pot.temp. from cons. temp. [Celcius] 870 !! 871 !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm 872 !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC 873 !! 874 !! Reference : TEOS-10, UNESCO 875 !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) 876 !!---------------------------------------------------------------------- 877 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celcius] 878 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 879 ! Leave result array automatic rather than making explicitly allocated 880 REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celcius] 881 ! 882 INTEGER :: ji, jj ! dummy loop indices 883 REAL(wp) :: zt , zs , ztm ! local scalars 884 REAL(wp) :: zn , zd ! local scalars 885 REAL(wp) :: zdeltaS , z1_S0 , z1_T0 886 !!---------------------------------------------------------------------- 887 ! 888 IF ( nn_timing == 1 ) CALL timing_start('eos_pt_from_ct') 889 ! 890 zdeltaS = 5._wp 891 z1_S0 = 0.875_wp/35.16504_wp 892 z1_T0 = 1._wp/40._wp 893 ! 894 DO jj = 1, jpj 895 DO ji = 1, jpi 896 ! 897 zt = ctmp (ji,jj) * z1_T0 898 zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 899 ztm = tmask(ji,jj,1) 900 ! 901 zn = ((((-2.1385727895e-01_wp*zt & 902 & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & 903 & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt & 904 & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt & 905 & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs & 906 & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt & 907 & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs & 908 & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 909 ! 910 zd = (2.0035003456_wp*zt & 911 & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & 912 & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 913 ! 914 ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 915 ! 916 END DO 917 END DO 918 ! 919 IF( nn_timing == 1 ) CALL timing_stop('eos_pt_from_ct') 920 ! 921 END FUNCTION eos_pt_from_ct 922 923 924 FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 925 !!---------------------------------------------------------------------- 926 !! *** ROUTINE eos_fzp *** 927 !! 928 !! ** Purpose : Compute the freezing point temperature [Celcius] 929 !! 930 !! ** Method : UNESCO freezing point (ptf) in Celcius is given by 931 !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 932 !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 933 !! 934 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 935 !!---------------------------------------------------------------------- 936 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 937 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 938 REAL(wp), DIMENSION(jpi,jpj) :: ptf ! freezing temperature [Celcius] 939 ! 940 INTEGER :: ji, jj ! dummy loop indices 941 REAL(wp) :: zt, zs ! local scalars 942 !!---------------------------------------------------------------------- 943 ! 944 SELECT CASE ( nn_eos ) 945 ! 946 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 947 ! 948 DO jj = 1, jpj 949 DO ji = 1, jpi 950 zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 ) ! square root salinity 951 ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 952 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 953 END DO 954 END DO 955 ptf(:,:) = ptf(:,:) * psal(:,:) 956 ! 957 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 958 ! 959 CASE ( 0 ) !== PT,SP (UNESCO formulation) ==! 960 ! 961 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & 962 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) 963 ! 964 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 965 ! 966 CASE DEFAULT 967 IF(lwp) WRITE(numout,cform_err) 968 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 969 nstop = nstop + 1 970 ! 971 END SELECT 972 ! 973 END FUNCTION eos_fzp_2d 974 975 FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 976 !!---------------------------------------------------------------------- 977 !! *** ROUTINE eos_fzp *** 978 !! 979 !! ** Purpose : Compute the freezing point temperature [Celcius] 980 !! 981 !! ** Method : UNESCO freezing point (ptf) in Celcius is given by 982 !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z 983 !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 984 !! 985 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 986 !!---------------------------------------------------------------------- 987 REAL(wp), INTENT(in) :: psal ! salinity [psu] 988 REAL(wp), INTENT(in), OPTIONAL :: pdep ! depth [m] 989 REAL(wp) :: ptf ! freezing temperature [Celcius] 990 ! 991 REAL(wp) :: zs ! local scalars 992 !!---------------------------------------------------------------------- 993 ! 994 SELECT CASE ( nn_eos ) 995 ! 996 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 997 ! 998 zs = SQRT( ABS( psal ) * r1_S0 ) ! square root salinity 999 ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1000 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 1001 ptf = ptf * psal 1002 ! 1003 IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep 1004 ! 1005 CASE ( 0 ) !== PT,SP (UNESCO formulation) ==! 1006 ! 1007 ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & 1008 & - 2.154996e-4_wp * psal ) * psal 1009 ! 1010 IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep 1011 ! 1012 CASE DEFAULT 1013 IF(lwp) WRITE(numout,cform_err) 1014 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 1015 nstop = nstop + 1 1016 ! 1017 END SELECT 1018 ! 1019 END FUNCTION eos_fzp_0d 1020 1021 1022 SUBROUTINE eos_pen( pts, pab_pe, ppen ) 1023 !!---------------------------------------------------------------------- 1024 !! *** ROUTINE eos_pen *** 1025 !! 1026 !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points 1027 !! 1028 !! ** Method : PE is defined analytically as the vertical 1029 !! primitive of EOS times -g integrated between 0 and z>0. 1030 !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rau0 gz ) / rau0 gz - rd 1031 !! = 1/z * /int_0^z rd dz - rd 1032 !! where rd is the density anomaly (see eos_rhd function) 1033 !! ab_pe are partial derivatives of PE anomaly with respect to T and S: 1034 !! ab_pe(1) = - 1/(rau0 gz) * dPE/dT + drd/dT = - d(pen)/dT 1035 !! ab_pe(2) = 1/(rau0 gz) * dPE/dS + drd/dS = d(pen)/dS 1036 !! 1037 !! ** Action : - pen : PE anomaly given at T-points 1038 !! : - pab_pe : given at T-points 1039 !! pab_pe(:,:,:,jp_tem) is alpha_pe 1040 !! pab_pe(:,:,:,jp_sal) is beta_pe 1041 !!---------------------------------------------------------------------- 1042 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 1043 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe 1044 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly 1045 ! 1046 INTEGER :: ji, jj, jk ! dummy loop indices 1047 REAL(wp) :: zt , zh , zs , ztm ! local scalars 1048 REAL(wp) :: zn , zn0, zn1, zn2 ! - - 1049 !!---------------------------------------------------------------------- 1050 ! 1051 IF( nn_timing == 1 ) CALL timing_start('eos_pen') 1052 ! 1053 SELECT CASE ( nn_eos ) 1054 ! 1055 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 1056 ! 1057 DO jk = 1, jpkm1 1058 DO jj = 1, jpj 1059 DO ji = 1, jpi 1060 ! 1061 zh = fsdept(ji,jj,jk) * r1_Z0 ! depth 1062 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 1063 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 1064 ztm = tmask(ji,jj,jk) ! tmask 1065 ! 1066 ! potential energy non-linear anomaly 1067 zn2 = (PEN012)*zt & 1068 & + PEN102*zs+PEN002 1069 ! 1070 zn1 = ((PEN021)*zt & 1071 & + PEN111*zs+PEN011)*zt & 1072 & + (PEN201*zs+PEN101)*zs+PEN001 1073 ! 1074 zn0 = ((((PEN040)*zt & 1075 & + PEN130*zs+PEN030)*zt & 1076 & + (PEN220*zs+PEN120)*zs+PEN020)*zt & 1077 & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt & 1078 & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 1079 ! 1080 zn = ( zn2 * zh + zn1 ) * zh + zn0 1081 ! 1082 ppen(ji,jj,jk) = zn * zh * r1_rau0 * ztm 1083 ! 1084 ! alphaPE non-linear anomaly 1085 zn2 = APE002 1086 ! 1087 zn1 = (APE011)*zt & 1088 & + APE101*zs+APE001 1089 ! 1090 zn0 = (((APE030)*zt & 1091 & + APE120*zs+APE020)*zt & 1092 & + (APE210*zs+APE110)*zs+APE010)*zt & 1093 & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 1094 ! 1095 zn = ( zn2 * zh + zn1 ) * zh + zn0 1096 ! 1097 pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 1098 ! 1099 ! betaPE non-linear anomaly 1100 zn2 = BPE002 1101 ! 1102 zn1 = (BPE011)*zt & 1103 & + BPE101*zs+BPE001 1104 ! 1105 zn0 = (((BPE030)*zt & 1106 & + BPE120*zs+BPE020)*zt & 1107 & + (BPE210*zs+BPE110)*zs+BPE010)*zt & 1108 & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 1109 ! 1110 zn = ( zn2 * zh + zn1 ) * zh + zn0 1111 ! 1112 pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 1113 ! 1114 END DO 1115 END DO 1116 END DO 1117 ! 1118 CASE( 1 ) !== Vallis (2006) simplified EOS ==! 1119 ! 1120 DO jk = 1, jpkm1 1121 DO jj = 1, jpj 1122 DO ji = 1, jpi 1123 zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) 1124 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 1125 zh = fsdept(ji,jj,jk) ! depth in meters at t-point 1126 ztm = tmask(ji,jj,jk) ! tmask 1127 zn = 0.5_wp * zh * r1_rau0 * ztm 1128 ! ! Potential Energy 1129 ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 1130 ! ! alphaPE 1131 pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 1132 pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn 1133 ! 1134 END DO 1135 END DO 1136 END DO 1137 ! 1138 CASE DEFAULT 1139 IF(lwp) WRITE(numout,cform_err) 1140 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 1141 nstop = nstop + 1 1142 ! 1143 END SELECT 1144 ! 1145 IF( nn_timing == 1 ) CALL timing_stop('eos_pen') 1146 ! 1147 END SUBROUTINE eos_pen 1148 1149 1150 SUBROUTINE eos_init 682 1151 !!---------------------------------------------------------------------- 683 1152 !! *** ROUTINE eos_init *** 684 1153 !! 685 !! ** Purpose : Compute the sea surface freezing temperature [Celcius]686 !!687 !! ** Method : UNESCO freezing point at the surface (pressure = 0???)688 !! freezing point [Celcius]=(-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s-7.53e-4*p689 !! checkvalue: tf= -2.588567 Celsius for s=40.0psu, p=500. decibars690 !!691 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978692 !!----------------------------------------------------------------------693 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]694 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [decibars]695 ! Leave result array automatic rather than making explicitly allocated696 REAL(wp), DIMENSION(jpi,jpj) :: ptf ! freezing temperature [Celcius]697 !!----------------------------------------------------------------------698 !699 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &700 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:)701 IF ( PRESENT( pdep ) ) THEN702 ptf(:,:) = ptf(:,:) - 7.53e-4_wp * pdep(:,:)703 ENDIF704 !705 END FUNCTION tfreez706 707 FUNCTION tfreez1D( psal, pdep ) RESULT( ptf )708 !!----------------------------------------------------------------------709 !! *** ROUTINE eos_init ***710 !!711 !! ** Purpose : Compute the sea surface freezing temperature [Celcius]712 !!713 !! ** Method : UNESCO freezing point at the surface (pressure = 0???)714 !! freezing point [Celcius]=(-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s-7.53e-4*p715 !! checkvalue: tf= -2.588567 Celsius for s=40.0psu, p=500. decibars716 !!717 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978718 !!----------------------------------------------------------------------719 REAL(wp), INTENT(in ) :: psal ! salinity [psu]720 REAL(wp), INTENT(in ), OPTIONAL :: pdep ! pressure [dBar]721 ! Leave result array automatic rather than making explicitly allocated722 REAL(wp) :: ptf ! freezing temperature [Celcius]723 !!----------------------------------------------------------------------724 !725 ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) &726 & - 2.154996e-4_wp * psal ) * psal727 IF ( PRESENT( pdep ) ) THEN728 ptf = ptf - 7.53e-4_wp * pdep729 ENDIF730 !731 END FUNCTION tfreez1D732 733 734 735 SUBROUTINE eos_init736 !!----------------------------------------------------------------------737 !! *** ROUTINE eos_init ***738 !!739 1154 !! ** Purpose : initializations for the equation of state 740 1155 !! 741 1156 !! ** Method : Read the namelist nameos and control the parameters 742 1157 !!---------------------------------------------------------------------- 743 NAMELIST/nameos/ nn_eos, rn_alpha, rn_beta 744 !!---------------------------------------------------------------------- 745 INTEGER :: ios 1158 INTEGER :: ios ! local integer 1159 !! 1160 NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1, & 1161 & rn_lambda2, rn_mu2, rn_nu 1162 !!---------------------------------------------------------------------- 746 1163 ! 747 1164 REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state 748 1165 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 749 1166 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 750 1167 ! 751 1168 REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state 752 1169 READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 753 1170 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 754 IF(lwm) WRITE( numond, nameos ) 1171 WRITE( numond, nameos ) 1172 ! 1173 rau0 = 1026._wp !: volumic mass of reference [kg/m3] 1174 rcp = 3991.86795711963_wp !: heat capacity [J/K] 755 1175 ! 756 1176 IF(lwp) THEN ! Control print … … 760 1180 WRITE(numout,*) ' Namelist nameos : set eos parameters' 761 1181 WRITE(numout,*) ' flag for eq. of state and N^2 nn_eos = ', nn_eos 762 WRITE(numout,*) ' thermal exp. coef. (linear) rn_alpha = ', rn_alpha 763 WRITE(numout,*) ' saline exp. coef. (linear) rn_beta = ', rn_beta 1182 IF( ln_useCT ) THEN 1183 WRITE(numout,*) ' model uses Conservative Temperature' 1184 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 1185 ENDIF 764 1186 ENDIF 765 1187 ! 766 1188 SELECT CASE( nn_eos ) ! check option 767 1189 ! 768 CASE( 0 ) !== Jackett and McDougall (1994) formulation==!1190 CASE( -1 ) !== polynomial TEOS-10 ==! 769 1191 IF(lwp) WRITE(numout,*) 770 IF(lwp) WRITE(numout,*) ' use of Jackett & McDougall (1994) equation of state and' 771 IF(lwp) WRITE(numout,*) ' McDougall (1987) Brunt-Vaisala frequency' 772 ! 773 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 1192 IF(lwp) WRITE(numout,*) ' use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 1193 ! 1194 rdeltaS = 32._wp 1195 r1_S0 = 0.875_wp/35.16504_wp 1196 r1_T0 = 1._wp/40._wp 1197 r1_Z0 = 1.e-4_wp 1198 ! 1199 EOS000 = 8.0189615746e+02_wp 1200 EOS100 = 8.6672408165e+02_wp 1201 EOS200 = -1.7864682637e+03_wp 1202 EOS300 = 2.0375295546e+03_wp 1203 EOS400 = -1.2849161071e+03_wp 1204 EOS500 = 4.3227585684e+02_wp 1205 EOS600 = -6.0579916612e+01_wp 1206 EOS010 = 2.6010145068e+01_wp 1207 EOS110 = -6.5281885265e+01_wp 1208 EOS210 = 8.1770425108e+01_wp 1209 EOS310 = -5.6888046321e+01_wp 1210 EOS410 = 1.7681814114e+01_wp 1211 EOS510 = -1.9193502195_wp 1212 EOS020 = -3.7074170417e+01_wp 1213 EOS120 = 6.1548258127e+01_wp 1214 EOS220 = -6.0362551501e+01_wp 1215 EOS320 = 2.9130021253e+01_wp 1216 EOS420 = -5.4723692739_wp 1217 EOS030 = 2.1661789529e+01_wp 1218 EOS130 = -3.3449108469e+01_wp 1219 EOS230 = 1.9717078466e+01_wp 1220 EOS330 = -3.1742946532_wp 1221 EOS040 = -8.3627885467_wp 1222 EOS140 = 1.1311538584e+01_wp 1223 EOS240 = -5.3563304045_wp 1224 EOS050 = 5.4048723791e-01_wp 1225 EOS150 = 4.8169980163e-01_wp 1226 EOS060 = -1.9083568888e-01_wp 1227 EOS001 = 1.9681925209e+01_wp 1228 EOS101 = -4.2549998214e+01_wp 1229 EOS201 = 5.0774768218e+01_wp 1230 EOS301 = -3.0938076334e+01_wp 1231 EOS401 = 6.6051753097_wp 1232 EOS011 = -1.3336301113e+01_wp 1233 EOS111 = -4.4870114575_wp 1234 EOS211 = 5.0042598061_wp 1235 EOS311 = -6.5399043664e-01_wp 1236 EOS021 = 6.7080479603_wp 1237 EOS121 = 3.5063081279_wp 1238 EOS221 = -1.8795372996_wp 1239 EOS031 = -2.4649669534_wp 1240 EOS131 = -5.5077101279e-01_wp 1241 EOS041 = 5.5927935970e-01_wp 1242 EOS002 = 2.0660924175_wp 1243 EOS102 = -4.9527603989_wp 1244 EOS202 = 2.5019633244_wp 1245 EOS012 = 2.0564311499_wp 1246 EOS112 = -2.1311365518e-01_wp 1247 EOS022 = -1.2419983026_wp 1248 EOS003 = -2.3342758797e-02_wp 1249 EOS103 = -1.8507636718e-02_wp 1250 EOS013 = 3.7969820455e-01_wp 1251 ! 1252 ALP000 = -6.5025362670e-01_wp 1253 ALP100 = 1.6320471316_wp 1254 ALP200 = -2.0442606277_wp 1255 ALP300 = 1.4222011580_wp 1256 ALP400 = -4.4204535284e-01_wp 1257 ALP500 = 4.7983755487e-02_wp 1258 ALP010 = 1.8537085209_wp 1259 ALP110 = -3.0774129064_wp 1260 ALP210 = 3.0181275751_wp 1261 ALP310 = -1.4565010626_wp 1262 ALP410 = 2.7361846370e-01_wp 1263 ALP020 = -1.6246342147_wp 1264 ALP120 = 2.5086831352_wp 1265 ALP220 = -1.4787808849_wp 1266 ALP320 = 2.3807209899e-01_wp 1267 ALP030 = 8.3627885467e-01_wp 1268 ALP130 = -1.1311538584_wp 1269 ALP230 = 5.3563304045e-01_wp 1270 ALP040 = -6.7560904739e-02_wp 1271 ALP140 = -6.0212475204e-02_wp 1272 ALP050 = 2.8625353333e-02_wp 1273 ALP001 = 3.3340752782e-01_wp 1274 ALP101 = 1.1217528644e-01_wp 1275 ALP201 = -1.2510649515e-01_wp 1276 ALP301 = 1.6349760916e-02_wp 1277 ALP011 = -3.3540239802e-01_wp 1278 ALP111 = -1.7531540640e-01_wp 1279 ALP211 = 9.3976864981e-02_wp 1280 ALP021 = 1.8487252150e-01_wp 1281 ALP121 = 4.1307825959e-02_wp 1282 ALP031 = -5.5927935970e-02_wp 1283 ALP002 = -5.1410778748e-02_wp 1284 ALP102 = 5.3278413794e-03_wp 1285 ALP012 = 6.2099915132e-02_wp 1286 ALP003 = -9.4924551138e-03_wp 1287 ! 1288 BET000 = 1.0783203594e+01_wp 1289 BET100 = -4.4452095908e+01_wp 1290 BET200 = 7.6048755820e+01_wp 1291 BET300 = -6.3944280668e+01_wp 1292 BET400 = 2.6890441098e+01_wp 1293 BET500 = -4.5221697773_wp 1294 BET010 = -8.1219372432e-01_wp 1295 BET110 = 2.0346663041_wp 1296 BET210 = -2.1232895170_wp 1297 BET310 = 8.7994140485e-01_wp 1298 BET410 = -1.1939638360e-01_wp 1299 BET020 = 7.6574242289e-01_wp 1300 BET120 = -1.5019813020_wp 1301 BET220 = 1.0872489522_wp 1302 BET320 = -2.7233429080e-01_wp 1303 BET030 = -4.1615152308e-01_wp 1304 BET130 = 4.9061350869e-01_wp 1305 BET230 = -1.1847737788e-01_wp 1306 BET040 = 1.4073062708e-01_wp 1307 BET140 = -1.3327978879e-01_wp 1308 BET050 = 5.9929880134e-03_wp 1309 BET001 = -5.2937873009e-01_wp 1310 BET101 = 1.2634116779_wp 1311 BET201 = -1.1547328025_wp 1312 BET301 = 3.2870876279e-01_wp 1313 BET011 = -5.5824407214e-02_wp 1314 BET111 = 1.2451933313e-01_wp 1315 BET211 = -2.4409539932e-02_wp 1316 BET021 = 4.3623149752e-02_wp 1317 BET121 = -4.6767901790e-02_wp 1318 BET031 = -6.8523260060e-03_wp 1319 BET002 = -6.1618945251e-02_wp 1320 BET102 = 6.2255521644e-02_wp 1321 BET012 = -2.6514181169e-03_wp 1322 BET003 = -2.3025968587e-04_wp 1323 ! 1324 PEN000 = -9.8409626043_wp 1325 PEN100 = 2.1274999107e+01_wp 1326 PEN200 = -2.5387384109e+01_wp 1327 PEN300 = 1.5469038167e+01_wp 1328 PEN400 = -3.3025876549_wp 1329 PEN010 = 6.6681505563_wp 1330 PEN110 = 2.2435057288_wp 1331 PEN210 = -2.5021299030_wp 1332 PEN310 = 3.2699521832e-01_wp 1333 PEN020 = -3.3540239802_wp 1334 PEN120 = -1.7531540640_wp 1335 PEN220 = 9.3976864981e-01_wp 1336 PEN030 = 1.2324834767_wp 1337 PEN130 = 2.7538550639e-01_wp 1338 PEN040 = -2.7963967985e-01_wp 1339 PEN001 = -1.3773949450_wp 1340 PEN101 = 3.3018402659_wp 1341 PEN201 = -1.6679755496_wp 1342 PEN011 = -1.3709540999_wp 1343 PEN111 = 1.4207577012e-01_wp 1344 PEN021 = 8.2799886843e-01_wp 1345 PEN002 = 1.7507069098e-02_wp 1346 PEN102 = 1.3880727538e-02_wp 1347 PEN012 = -2.8477365341e-01_wp 1348 ! 1349 APE000 = -1.6670376391e-01_wp 1350 APE100 = -5.6087643219e-02_wp 1351 APE200 = 6.2553247576e-02_wp 1352 APE300 = -8.1748804580e-03_wp 1353 APE010 = 1.6770119901e-01_wp 1354 APE110 = 8.7657703198e-02_wp 1355 APE210 = -4.6988432490e-02_wp 1356 APE020 = -9.2436260751e-02_wp 1357 APE120 = -2.0653912979e-02_wp 1358 APE030 = 2.7963967985e-02_wp 1359 APE001 = 3.4273852498e-02_wp 1360 APE101 = -3.5518942529e-03_wp 1361 APE011 = -4.1399943421e-02_wp 1362 APE002 = 7.1193413354e-03_wp 1363 ! 1364 BPE000 = 2.6468936504e-01_wp 1365 BPE100 = -6.3170583896e-01_wp 1366 BPE200 = 5.7736640125e-01_wp 1367 BPE300 = -1.6435438140e-01_wp 1368 BPE010 = 2.7912203607e-02_wp 1369 BPE110 = -6.2259666565e-02_wp 1370 BPE210 = 1.2204769966e-02_wp 1371 BPE020 = -2.1811574876e-02_wp 1372 BPE120 = 2.3383950895e-02_wp 1373 BPE030 = 3.4261630030e-03_wp 1374 BPE001 = 4.1079296834e-02_wp 1375 BPE101 = -4.1503681096e-02_wp 1376 BPE011 = 1.7676120780e-03_wp 1377 BPE002 = 1.7269476440e-04_wp 1378 ! 1379 CASE( 0 ) !== polynomial EOS-80 formulation ==! 1380 ! 774 1381 IF(lwp) WRITE(numout,*) 775 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T) = rau0 * ( 1.0285 - rn_alpha * T )' 776 IF( lk_zdfddm ) CALL ctl_stop( ' double diffusive mixing parameterization requires', & 777 & ' that T and S are used as state variables' ) 778 ! 779 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 780 ralpbet = rn_alpha / rn_beta 781 IF(lwp) WRITE(numout,*) 782 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T,S) = rau0 * ( rn_beta * S - rn_alpha * T )' 1382 IF(lwp) WRITE(numout,*) ' use of EOS-80 equation of state (pot. temp. and pract. salinity)' 1383 ! 1384 rdeltaS = 20._wp 1385 r1_S0 = 1._wp/40._wp 1386 r1_T0 = 1._wp/40._wp 1387 r1_Z0 = 1.e-4_wp 1388 ! 1389 EOS000 = 9.5356891948e+02_wp 1390 EOS100 = 1.7136499189e+02_wp 1391 EOS200 = -3.7501039454e+02_wp 1392 EOS300 = 5.1856810420e+02_wp 1393 EOS400 = -3.7264470465e+02_wp 1394 EOS500 = 1.4302533998e+02_wp 1395 EOS600 = -2.2856621162e+01_wp 1396 EOS010 = 1.0087518651e+01_wp 1397 EOS110 = -1.3647741861e+01_wp 1398 EOS210 = 8.8478359933_wp 1399 EOS310 = -7.2329388377_wp 1400 EOS410 = 1.4774410611_wp 1401 EOS510 = 2.0036720553e-01_wp 1402 EOS020 = -2.5579830599e+01_wp 1403 EOS120 = 2.4043512327e+01_wp 1404 EOS220 = -1.6807503990e+01_wp 1405 EOS320 = 8.3811577084_wp 1406 EOS420 = -1.9771060192_wp 1407 EOS030 = 1.6846451198e+01_wp 1408 EOS130 = -2.1482926901e+01_wp 1409 EOS230 = 1.0108954054e+01_wp 1410 EOS330 = -6.2675951440e-01_wp 1411 EOS040 = -8.0812310102_wp 1412 EOS140 = 1.0102374985e+01_wp 1413 EOS240 = -4.8340368631_wp 1414 EOS050 = 1.2079167803_wp 1415 EOS150 = 1.1515380987e-01_wp 1416 EOS060 = -2.4520288837e-01_wp 1417 EOS001 = 1.0748601068e+01_wp 1418 EOS101 = -1.7817043500e+01_wp 1419 EOS201 = 2.2181366768e+01_wp 1420 EOS301 = -1.6750916338e+01_wp 1421 EOS401 = 4.1202230403_wp 1422 EOS011 = -1.5852644587e+01_wp 1423 EOS111 = -7.6639383522e-01_wp 1424 EOS211 = 4.1144627302_wp 1425 EOS311 = -6.6955877448e-01_wp 1426 EOS021 = 9.9994861860_wp 1427 EOS121 = -1.9467067787e-01_wp 1428 EOS221 = -1.2177554330_wp 1429 EOS031 = -3.4866102017_wp 1430 EOS131 = 2.2229155620e-01_wp 1431 EOS041 = 5.9503008642e-01_wp 1432 EOS002 = 1.0375676547_wp 1433 EOS102 = -3.4249470629_wp 1434 EOS202 = 2.0542026429_wp 1435 EOS012 = 2.1836324814_wp 1436 EOS112 = -3.4453674320e-01_wp 1437 EOS022 = -1.2548163097_wp 1438 EOS003 = 1.8729078427e-02_wp 1439 EOS103 = -5.7238495240e-02_wp 1440 EOS013 = 3.8306136687e-01_wp 1441 ! 1442 ALP000 = -2.5218796628e-01_wp 1443 ALP100 = 3.4119354654e-01_wp 1444 ALP200 = -2.2119589983e-01_wp 1445 ALP300 = 1.8082347094e-01_wp 1446 ALP400 = -3.6936026529e-02_wp 1447 ALP500 = -5.0091801383e-03_wp 1448 ALP010 = 1.2789915300_wp 1449 ALP110 = -1.2021756164_wp 1450 ALP210 = 8.4037519952e-01_wp 1451 ALP310 = -4.1905788542e-01_wp 1452 ALP410 = 9.8855300959e-02_wp 1453 ALP020 = -1.2634838399_wp 1454 ALP120 = 1.6112195176_wp 1455 ALP220 = -7.5817155402e-01_wp 1456 ALP320 = 4.7006963580e-02_wp 1457 ALP030 = 8.0812310102e-01_wp 1458 ALP130 = -1.0102374985_wp 1459 ALP230 = 4.8340368631e-01_wp 1460 ALP040 = -1.5098959754e-01_wp 1461 ALP140 = -1.4394226233e-02_wp 1462 ALP050 = 3.6780433255e-02_wp 1463 ALP001 = 3.9631611467e-01_wp 1464 ALP101 = 1.9159845880e-02_wp 1465 ALP201 = -1.0286156825e-01_wp 1466 ALP301 = 1.6738969362e-02_wp 1467 ALP011 = -4.9997430930e-01_wp 1468 ALP111 = 9.7335338937e-03_wp 1469 ALP211 = 6.0887771651e-02_wp 1470 ALP021 = 2.6149576513e-01_wp 1471 ALP121 = -1.6671866715e-02_wp 1472 ALP031 = -5.9503008642e-02_wp 1473 ALP002 = -5.4590812035e-02_wp 1474 ALP102 = 8.6134185799e-03_wp 1475 ALP012 = 6.2740815484e-02_wp 1476 ALP003 = -9.5765341718e-03_wp 1477 ! 1478 BET000 = 2.1420623987_wp 1479 BET100 = -9.3752598635_wp 1480 BET200 = 1.9446303907e+01_wp 1481 BET300 = -1.8632235232e+01_wp 1482 BET400 = 8.9390837485_wp 1483 BET500 = -1.7142465871_wp 1484 BET010 = -1.7059677327e-01_wp 1485 BET110 = 2.2119589983e-01_wp 1486 BET210 = -2.7123520642e-01_wp 1487 BET310 = 7.3872053057e-02_wp 1488 BET410 = 1.2522950346e-02_wp 1489 BET020 = 3.0054390409e-01_wp 1490 BET120 = -4.2018759976e-01_wp 1491 BET220 = 3.1429341406e-01_wp 1492 BET320 = -9.8855300959e-02_wp 1493 BET030 = -2.6853658626e-01_wp 1494 BET130 = 2.5272385134e-01_wp 1495 BET230 = -2.3503481790e-02_wp 1496 BET040 = 1.2627968731e-01_wp 1497 BET140 = -1.2085092158e-01_wp 1498 BET050 = 1.4394226233e-03_wp 1499 BET001 = -2.2271304375e-01_wp 1500 BET101 = 5.5453416919e-01_wp 1501 BET201 = -6.2815936268e-01_wp 1502 BET301 = 2.0601115202e-01_wp 1503 BET011 = -9.5799229402e-03_wp 1504 BET111 = 1.0286156825e-01_wp 1505 BET211 = -2.5108454043e-02_wp 1506 BET021 = -2.4333834734e-03_wp 1507 BET121 = -3.0443885826e-02_wp 1508 BET031 = 2.7786444526e-03_wp 1509 BET002 = -4.2811838287e-02_wp 1510 BET102 = 5.1355066072e-02_wp 1511 BET012 = -4.3067092900e-03_wp 1512 BET003 = -7.1548119050e-04_wp 1513 ! 1514 PEN000 = -5.3743005340_wp 1515 PEN100 = 8.9085217499_wp 1516 PEN200 = -1.1090683384e+01_wp 1517 PEN300 = 8.3754581690_wp 1518 PEN400 = -2.0601115202_wp 1519 PEN010 = 7.9263222935_wp 1520 PEN110 = 3.8319691761e-01_wp 1521 PEN210 = -2.0572313651_wp 1522 PEN310 = 3.3477938724e-01_wp 1523 PEN020 = -4.9997430930_wp 1524 PEN120 = 9.7335338937e-02_wp 1525 PEN220 = 6.0887771651e-01_wp 1526 PEN030 = 1.7433051009_wp 1527 PEN130 = -1.1114577810e-01_wp 1528 PEN040 = -2.9751504321e-01_wp 1529 PEN001 = -6.9171176978e-01_wp 1530 PEN101 = 2.2832980419_wp 1531 PEN201 = -1.3694684286_wp 1532 PEN011 = -1.4557549876_wp 1533 PEN111 = 2.2969116213e-01_wp 1534 PEN021 = 8.3654420645e-01_wp 1535 PEN002 = -1.4046808820e-02_wp 1536 PEN102 = 4.2928871430e-02_wp 1537 PEN012 = -2.8729602515e-01_wp 1538 ! 1539 APE000 = -1.9815805734e-01_wp 1540 APE100 = -9.5799229402e-03_wp 1541 APE200 = 5.1430784127e-02_wp 1542 APE300 = -8.3694846809e-03_wp 1543 APE010 = 2.4998715465e-01_wp 1544 APE110 = -4.8667669469e-03_wp 1545 APE210 = -3.0443885826e-02_wp 1546 APE020 = -1.3074788257e-01_wp 1547 APE120 = 8.3359333577e-03_wp 1548 APE030 = 2.9751504321e-02_wp 1549 APE001 = 3.6393874690e-02_wp 1550 APE101 = -5.7422790533e-03_wp 1551 APE011 = -4.1827210323e-02_wp 1552 APE002 = 7.1824006288e-03_wp 1553 ! 1554 BPE000 = 1.1135652187e-01_wp 1555 BPE100 = -2.7726708459e-01_wp 1556 BPE200 = 3.1407968134e-01_wp 1557 BPE300 = -1.0300557601e-01_wp 1558 BPE010 = 4.7899614701e-03_wp 1559 BPE110 = -5.1430784127e-02_wp 1560 BPE210 = 1.2554227021e-02_wp 1561 BPE020 = 1.2166917367e-03_wp 1562 BPE120 = 1.5221942913e-02_wp 1563 BPE030 = -1.3893222263e-03_wp 1564 BPE001 = 2.8541225524e-02_wp 1565 BPE101 = -3.4236710714e-02_wp 1566 BPE011 = 2.8711395266e-03_wp 1567 BPE002 = 5.3661089288e-04_wp 1568 ! 1569 CASE( 1 ) !== Simplified EOS ==! 1570 IF(lwp) THEN 1571 WRITE(numout,*) 1572 WRITE(numout,*) ' use of simplified eos: rhd(dT=T-10,dS=S-35,Z) = ' 1573 WRITE(numout,*) ' [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' 1574 WRITE(numout,*) 1575 WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 1576 WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 1577 WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 1578 WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 1579 WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 1580 WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 1581 WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu 1582 WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' 1583 ENDIF 783 1584 ! 784 1585 CASE DEFAULT !== ERROR in nn_eos ==! … … 788 1589 END SELECT 789 1590 ! 1591 r1_rau0 = 1._wp / rau0 1592 r1_rcp = 1._wp / rcp 1593 r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 1594 ! 1595 IF(lwp) WRITE(numout,*) 1596 IF(lwp) WRITE(numout,*) ' volumic mass of reference rau0 = ', rau0 , ' kg/m^3' 1597 IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' 1598 IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' 1599 IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp 1600 ! 790 1601 END SUBROUTINE eos_init 791 1602 -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r4666 r4946 4 4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!====================================================================== 6 !! History : 8.2 ! 2001-08 (G. Madec, E. Durand)trahad+trazad=traadv7 !! 8 !! 9.0! 2004-08 (C. Talandier) New trends organization6 !! History : OPA ! 2001-08 (G. Madec, E. Durand) v8.2 trahad+trazad=traadv 7 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 8 !! - ! 2004-08 (C. Talandier) New trends organization 9 9 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 10 10 !! 2.0 ! 2006-04 (R. Benshila, G. Madec) Step reorganization … … 21 21 USE dom_oce ! ocean space and time domain 22 22 USE eosbn2 ! equation of state 23 USE trd mod_oce ! tracers trends24 USE trdtra ! tr acers trends23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 25 USE closea ! closed sea 26 26 USE sbcrnf ! river runoffs … … 38 38 PRIVATE 39 39 40 PUBLIC tra_adv_cen2 ! routine called by step.F90 41 PUBLIC ups_orca_set ! routine used by traadv_cen2_jki.F90 42 43 LOGICAL :: l_trd ! flag to compute trends 40 PUBLIC tra_adv_cen2 ! routine called by traadv.F90 44 41 45 42 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits … … 56 53 57 54 SUBROUTINE tra_adv_cen2( kt, kit000, cdtype, pun, pvn, pwn, & 58 & ptb, ptn, pta, kjpt )55 & ptb, ptn, pta, kjpt ) 59 56 !!---------------------------------------------------------------------- 60 57 !! *** ROUTINE tra_adv_cen2 *** … … 86 83 !! * Add this trend now to the general trend of tracer (ta,sa): 87 84 !! pta = pta + ztra 88 !! * trend diagnostic ( 'key_trdtra' defined): the trend is85 !! * trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 89 86 !! saved for diagnostics. The trends saved is expressed as 90 !! Uh.gradh(T), i.e. 91 !! save trend = ztra + ptn divn 87 !! Uh.gradh(T), i.e. save trend = ztra + ptn divn 92 88 !! 93 89 !! Part II : vertical advection … … 105 101 !! Add this trend now to the general trend of tracer (ta,sa): 106 102 !! pta = pta + ztra 107 !! Trend diagnostic ( 'key_trdtra' defined): the trend is103 !! Trend diagnostic (l_trdtra=T or l_trctra=T): the trend is 108 104 !! saved for diagnostics. The trends saved is expressed as : 109 105 !! save trend = w.gradz(T) = ztra - ptn divn. … … 112 108 !! - save trends if needed 113 109 !!---------------------------------------------------------------------- 114 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as 3D workspace115 !116 110 INTEGER , INTENT(in ) :: kt ! ocean time-step index 117 111 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 122 116 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 123 117 ! 124 INTEGER :: ji, jj, jk, jn, ik ! dummy loop indices118 INTEGER :: ji, jj, jk, jn, ikt ! dummy loop indices 125 119 INTEGER :: ierr ! local integer 126 120 REAL(wp) :: zbtr, ztra ! local scalars … … 129 123 REAL(wp) :: zupsut, zcenut, zupst ! - - 130 124 REAL(wp) :: zupsvt, zcenvt, zcent, zice ! - - 131 REAL(wp), POINTER, DIMENSION(:,: ) :: ztfreez, zpress 132 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind 125 REAL(wp), POINTER, DIMENSION(:,:) :: zfzp, zpres ! 2D workspace 126 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zwy ! 3D - 127 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz, zind ! - - 133 128 !!---------------------------------------------------------------------- 134 129 ! 135 130 IF( nn_timing == 1 ) CALL timing_start('tra_adv_cen2') 136 131 ! 137 CALL wrk_alloc( jpi, jpj, z tfreez, zpress)138 CALL wrk_alloc( jpi, jpj, jpk, zw z, zind )132 CALL wrk_alloc( jpi, jpj, zpres, zfzp ) 133 CALL wrk_alloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 139 134 ! 140 135 … … 145 140 IF(lwp) WRITE(numout,*) 146 141 ! 147 IF 142 IF( .NOT. ALLOCATED( upsmsk ) ) THEN 148 143 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 149 144 IF( ierr /= 0 ) CALL ctl_stop('STOP', 'tra_adv_cen2: unable to allocate array') … … 163 158 ENDIF 164 159 ! 165 l_trd = .FALSE.166 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.167 !168 160 ! Upstream / centered scheme indicator 169 161 ! ------------------------------------ … … 173 165 DO jj = 1, jpj 174 166 DO ji = 1, jpi 175 ik =mikt(ji,jj)176 IF (ik > 1 ) THEN177 zpres s(ji,jj) = grav*rau0*fsdept(ji,jj,ik)*1.e-04167 ikt = mikt(ji,jj) 168 IF (ikt > 1 ) THEN 169 zpres(ji,jj) = grav * rau0 * fsdept(ji,jj,ikt) * 1.e-04 178 170 ELSE 179 zpres s(ji,jj) = 0.0171 zpres(ji,jj) = 0.0 180 172 ENDIF 181 173 END DO 182 174 END DO 183 ztfreez(:,:) = tfreez( tsn(:,:,1, jp_sal), zpress(:,:) ) 184 175 zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 185 176 DO jk = 1, jpk 186 177 DO jj = 1, jpj 187 178 DO ji = 1, jpi 188 179 ! ! below ice covered area (if tn < "freezing"+0.1 ) 189 IF( tsn(ji,jj,jk,jp_tem) <= z tfreez(ji,jj) + 0.1 ) THEN ; zice = 1.e0190 ELSE ; zice = 0.e0180 IF( tsn(ji,jj,jk,jp_tem) <= zfzp(ji,jj) + 0.1 ) THEN ; zice = 1._wp 181 ELSE ; zice = 0._wp 191 182 ENDIF 192 183 zind(ji,jj,jk) = MAX ( & … … 240 231 DO jj = 1, jpj ! vector opt. 241 232 DO ji = 1, jpi ! vector opt. 242 ik =mikt(ji,jj)243 zwz(ji,jj,ik ) = pwn(ji,jj,ik) * ptn(ji,jj,ik,jn) ! linear free surface244 zwz(ji,jj,1:ik -1) = 0.e0233 ikt = mikt(ji,jj) 234 zwz(ji,jj,ikt ) = pwn(ji,jj,ikt) * ptn(ji,jj,ikt,jn) ! linear free surface 235 zwz(ji,jj,1:ikt-1) = 0.e0 245 236 END DO 246 237 END DO … … 280 271 END DO 281 272 282 ! ! trend diagnostics (contribution of upstream fluxes) 283 IF( l_trd ) THEN 284 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 285 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 286 CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptn(:,:,:,jn) ) 273 ! ! trend diagnostics 274 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 275 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 276 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 277 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 278 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 287 279 END IF 288 280 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 289 281 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 290 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) )291 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) )282 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( zwy(:,:,:) ) 283 IF( jn == jp_sal ) str_adv(:) = ptr_vj( zwy(:,:,:) ) 292 284 ENDIF 293 285 ! 294 END DO286 END DO 295 287 296 288 ! --------------------------- required in restart file to ensure restartability) … … 301 293 ENDIF 302 294 ! 303 CALL wrk_dealloc( jpi, jpj, z tfreez, zpress)304 CALL wrk_dealloc( jpi, jpj, jpk, zw z, zind )295 CALL wrk_dealloc( jpi, jpj, zpres, zfzp ) 296 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zwy, zwz, zind ) 305 297 ! 306 298 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_cen2') … … 323 315 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 324 316 !!---------------------------------------------------------------------- 325 326 317 ! 327 318 IF( nn_timing == 1 ) CALL timing_start('ups_orca_set') -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90
r4499 r4946 16 16 !!---------------------------------------------------------------------- 17 17 USE oce ! ocean dynamics and active tracers 18 USE trc_oce ! share passive tracers/Ocean variables 18 19 USE dom_oce ! ocean space and time domain 19 USE trdmod_oce ! tracers trends 20 USE trdtra ! tracers trends 21 USE in_out_manager ! I/O manager 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! tracers trends manager 22 22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 23 USE trabbl ! tracers: bottom boundary layer 24 USE lib_mpp ! distribued memory computing 25 USE lbclnk ! ocean lateral boundary condition (or mpp link) 23 USE sbcrnf ! river runoffs 26 24 USE diaptr ! poleward transport diagnostics 27 USE trc_oce ! share passive tracers/Ocean variables25 ! 28 26 USE wrk_nemo ! Memory Allocation 29 27 USE timing ! Timing 30 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 31 USE eosbn2 ! equation of state 32 USE sbcrnf ! river runoffs 29 USE in_out_manager ! I/O manager 30 USE lib_mpp ! distribued memory computing 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 33 32 34 33 IMPLICIT NONE 35 34 PRIVATE 36 35 37 PUBLIC tra_adv_muscl ! routine called by step.F9038 39 LOGICAL :: l_trd ! flag to compute trends40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits41 ! ! and in closed seas (orca 2 and 4 configurations)42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index36 PUBLIC tra_adv_muscl ! routine called by traadv.F90 37 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits 39 ! ! and in closed seas (orca 2 and 4 configurations) 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index 41 43 42 !! * Substitutions 44 43 # include "domzgr_substitute.h90" … … 51 50 CONTAINS 52 51 53 SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn, &54 & ptb, pta, kjpt, ld_msc_ups )52 SUBROUTINE tra_adv_muscl( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & 53 & ptb, pta, kjpt, ld_msc_ups ) 55 54 !!---------------------------------------------------------------------- 56 55 !! *** ROUTINE tra_adv_muscl *** … … 68 67 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 69 68 !!---------------------------------------------------------------------- 70 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace71 !72 69 INTEGER , INTENT(in ) :: kt ! ocean time-step index 73 70 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 79 76 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before tracer field 80 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 81 82 !83 INTEGER :: ji, jj, jk, jn ! dummy loop indices78 ! 79 INTEGER :: ji, jj, jk, jn ! dummy loop indices 80 INTEGER :: ierr ! local integer 84 81 REAL(wp) :: zu, z0u, zzwx, zw ! local scalars 85 82 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 86 83 REAL(wp) :: ztra, zbtr, zdt, zalpha ! - - 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy88 INTEGER :: ierr84 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy ! 3D workspace 85 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx , zwy ! - - 89 86 !!---------------------------------------------------------------------- 90 87 ! 91 88 IF( nn_timing == 1 ) CALL timing_start('tra_adv_muscl') 92 89 ! 93 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy ) 94 ! 95 90 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 91 ! 96 92 IF( kt == kit000 ) THEN 97 93 IF(lwp) WRITE(numout,*) … … 117 113 118 114 ! 119 ! Upstream / centeredscheme indicator115 ! Upstream / MUSCL scheme indicator 120 116 ! ------------------------------------ 117 !!gm useless 121 118 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 119 !!gm 122 120 ! 123 121 IF( ld_msc_ups ) THEN 124 DO jk = 1, jpk 125 DO jj = 1, jpj 126 DO ji = 1, jpi 127 xind(ji,jj,jk) = 1 - MAX ( & 128 rnfmsk(ji,jj) * rnfmsk_z(jk), & ! near runoff mouths (& closed sea outflows) 129 upsmsk(ji,jj) ) * tmask(ji,jj,jk) ! some of some straits 130 END DO 131 END DO 122 DO jk = 1, jpkm1 123 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 124 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 125 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 near some straits 132 126 END DO 133 127 ENDIF 134 128 ! 135 129 ENDIF 136 ! 137 l_trd = .FALSE. 138 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 139 130 ! 140 131 ! ! =========== 141 132 DO jn = 1, kjpt ! tracer loop … … 192 183 zalpha = 0.5 - z0u 193 184 zu = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 194 zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk))195 zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * (zu * zslpx(ji ,jj,jk))185 zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 186 zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) 196 187 zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 197 188 ! … … 199 190 zalpha = 0.5 - z0v 200 191 zv = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 201 zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk))202 zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * (zv * zslpy(ji,jj ,jk))192 zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 193 zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) 203 194 zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 204 195 END DO … … 222 213 END DO 223 214 ! ! trend diagnostics (contribution of upstream fluxes) 224 IF( l_trd ) THEN 225 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 226 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 215 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 216 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 217 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 218 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 227 219 END IF 228 220 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 274 266 zalpha = 0.5 + z0w 275 267 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr 276 zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1))277 zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * (zw * zslpx(ji,jj,jk ))268 zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 269 zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) 278 270 zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 279 271 END DO … … 281 273 END DO 282 274 283 ! Compute & add the vertical advective trend 284 DO jk = 1, jpkm1 275 DO jk = 1, jpkm1 ! Compute & add the vertical advective trend 285 276 DO jj = 2, jpjm1 286 277 DO ji = fs_2, fs_jpim1 ! vector opt. 287 zbtr = 1. / ( e1 t(ji,jj) *e2t(ji,jj) * fse3t(ji,jj,jk) )278 zbtr = 1. / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 288 279 ! vertical advective trends 289 280 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) … … 294 285 END DO 295 286 ! ! Save the vertical advective trends for diagnostic 296 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 297 ! 298 ENDDO 299 ! 300 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy ) 287 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 288 &( cdtype == 'TRC' .AND. l_trdtrc ) ) & 289 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 290 ! 291 END DO 292 ! 293 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 301 294 ! 302 295 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_muscl') -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90
r4499 r4946 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and active tracers 15 USE trc_oce ! share passive tracers/Ocean variables 15 16 USE dom_oce ! ocean space and time domain 16 USE trd mod_oce ! tracers trends17 USE trdtra ! tr acers trends17 USE trd_oce ! trends: ocean variables 18 USE trdtra ! trends manager: tracers 18 19 USE in_out_manager ! I/O manager 19 20 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 20 USE trabbl ! tracers: bottom boundary layer 21 USE diaptr ! poleward transport diagnostics 22 ! 21 23 USE lib_mpp ! distribued memory computing 22 24 USE lbclnk ! ocean lateral boundary condition (or mpp link) 23 USE diaptr ! poleward transport diagnostics24 USE trc_oce ! share passive tracers/Ocean variables25 25 USE wrk_nemo ! Memory Allocation 26 26 USE timing ! Timing … … 31 31 32 32 PUBLIC tra_adv_muscl2 ! routine called by step.F90 33 34 LOGICAL :: l_trd ! flag to compute trends35 33 36 34 !! * Substitutions … … 61 59 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 62 60 !!---------------------------------------------------------------------- 63 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as 3D workspace64 !!65 61 INTEGER , INTENT(in ) :: kt ! ocean time-step index 66 62 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 76 72 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 77 73 REAL(wp) :: ztra, zbtr, zdt, zalpha ! - - 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy 74 REAL(wp), POINTER, DIMENSION(:,:,:) :: zslpx, zslpy , zwx, zwy 79 75 !!---------------------------------------------------------------------- 80 76 ! 81 77 IF( nn_timing == 1 ) CALL timing_start('tra_adv_muscl2') 82 78 ! 83 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy )79 CALL wrk_alloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 84 80 ! 85 81 … … 90 86 ENDIF 91 87 ! 92 l_trd = .FALSE.93 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.94 95 88 ! ! =========== 96 89 DO jn = 1, kjpt ! tracer loop … … 200 193 END DO 201 194 ! ! trend diagnostics (contribution of upstream fluxes) 202 IF( l_trd ) THEN 203 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptb(:,:,:,jn) ) 204 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptb(:,:,:,jn) ) 195 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 196 &( cdtype == 'TRC' .AND. l_trdtrc ) ) THEN 197 CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 198 CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 205 199 END IF 206 200 … … 284 278 END DO 285 279 ! ! trend diagnostics (contribution of upstream fluxes) 286 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptb(:,:,:,jn) ) 280 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. & 281 &( cdtype == 'TRC' .AND. l_trdtrc ) ) & 282 CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 287 283 ! 288 284 END DO 289 285 ! 290 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy )286 CALL wrk_dealloc( jpi, jpj, jpk, zslpx, zslpy, zwx, zwy ) 291 287 ! 292 288 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_muscl2') -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r4499 r4946 17 17 USE oce ! ocean dynamics and active tracers 18 18 USE dom_oce ! ocean space and time domain 19 USE trdmod_oce ! ocean space and time domain 20 USE trdtra ! ocean tracers trends 21 USE trabbl ! advective term in the BBL 19 USE trc_oce ! share passive tracers/Ocean variables 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 USE dynspg_oce ! surface pressure gradient variables 23 USE diaptr ! poleward transport diagnostics 24 ! 22 25 USE lib_mpp ! distribued memory computing 23 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 24 USE dynspg_oce ! surface pressure gradient variables25 27 USE in_out_manager ! I/O manager 26 USE diaptr ! poleward transport diagnostics27 USE trc_oce ! share passive tracers/Ocean variables28 28 USE wrk_nemo ! Memory Allocation 29 29 USE timing ! Timing … … 93 93 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend 94 94 !!---------------------------------------------------------------------- 95 96 95 ! 97 96 IF( nn_timing == 1 ) CALL timing_start('tra_adv_qck') … … 103 102 IF(lwp) WRITE(numout,*) 104 103 ENDIF 105 !106 104 l_trd = .FALSE. 107 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.108 105 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 106 ! 109 107 ! I. The horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 110 108 CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt ) … … 124 122 !! 125 123 !!---------------------------------------------------------------------- 126 USE oce , ONLY: zwx => ua ! ua used as workspace127 !128 124 INTEGER , INTENT(in ) :: kt ! ocean time-step index 129 125 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 136 132 INTEGER :: ji, jj, jk, jn ! dummy loop indices 137 133 REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk ! local scalars 138 REAL(wp), POINTER, DIMENSION(:,:,:) :: z fu, zfc, zfd134 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwx, zfu, zfc, zfd 139 135 !---------------------------------------------------------------------- 140 136 ! 141 CALL wrk_alloc( jpi, jpj, jpk, z fu, zfc, zfd )137 CALL wrk_alloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 142 138 ! ! =========== 143 139 DO jn = 1, kjpt ! tracer loop … … 233 229 END DO 234 230 ! ! trend diagnostics (contribution of upstream fluxes) 235 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) )231 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 236 232 ! 237 233 END DO 238 234 ! 239 CALL wrk_dealloc( jpi, jpj, jpk, z fu, zfc, zfd )235 CALL wrk_dealloc( jpi, jpj, jpk, zwx, zfu, zfc, zfd ) 240 236 ! 241 237 END SUBROUTINE tra_adv_qck_i … … 247 243 !! 248 244 !!---------------------------------------------------------------------- 249 USE oce , ONLY: zwy => ua ! ua used as workspace250 !251 245 INTEGER , INTENT(in ) :: kt ! ocean time-step index 252 246 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 259 253 INTEGER :: ji, jj, jk, jn ! dummy loop indices 260 254 REAL(wp) :: ztra, zbtr, zdir, zdx, zdt, zmsk ! local scalars 261 REAL(wp), POINTER, DIMENSION(:,:,:) :: z fu, zfc, zfd255 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwy, zfu, zfc, zfd 262 256 !---------------------------------------------------------------------- 263 257 ! 264 CALL wrk_alloc( jpi, jpj, jpk, z fu, zfc, zfd )258 CALL wrk_alloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 265 259 ! 266 260 ! ! =========== … … 359 353 END DO 360 354 ! ! trend diagnostics (contribution of upstream fluxes) 361 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) )355 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 362 356 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 363 357 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN … … 368 362 END DO 369 363 ! 370 CALL wrk_dealloc( jpi, jpj, jpk, z fu, zfc, zfd )364 CALL wrk_dealloc( jpi, jpj, jpk, zwy, zfu, zfc, zfd ) 371 365 ! 372 366 END SUBROUTINE tra_adv_qck_j … … 378 372 !! 379 373 !!---------------------------------------------------------------------- 380 USE oce, ONLY: zwz => ua ! ua used as workspace381 !382 374 INTEGER , INTENT(in ) :: kt ! ocean time-step index 383 375 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) … … 389 381 INTEGER :: ji, jj, jk, jn ! dummy loop indices 390 382 REAL(wp) :: zbtr , ztra ! local scalars 391 !!---------------------------------------------------------------------- 392 383 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwz 384 !!---------------------------------------------------------------------- 385 ! 386 CALL wrk_alloc( jpi, jpj, jpk, zwz ) 393 387 ! ! =========== 394 388 DO jn = 1, kjpt ! tracer loop … … 422 416 END DO 423 417 ! ! Save the vertical advective trends for diagnostic 424 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, zwz, pwn, ptn(:,:,:,jn) )418 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 425 419 ! 426 420 END DO 421 ! 422 CALL wrk_dealloc( jpi, jpj, jpk, zwz ) 427 423 ! 428 424 END SUBROUTINE tra_adv_cen2_k -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r4934 r4946 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE trdmod_oce ! tracers trends 24 USE trc_oce ! share passive tracers/Ocean variables 25 USE trd_oce ! trends: ocean variables 25 26 USE trdtra ! tracers trends 26 USE in_out_manager ! I/O manager27 27 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 28 USE diaptr ! poleward transport diagnostics 29 ! 28 30 USE lib_mpp ! MPP library 29 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 30 USE diaptr ! poleward transport diagnostics 31 USE trc_oce ! share passive tracers/Ocean variables 32 USE in_out_manager ! I/O manager 32 33 USE wrk_nemo ! Memory Allocation 33 34 USE timing ! Timing … … 95 96 IF(lwp) WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme on ', cdtype 96 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 98 ! 99 l_trd = .FALSE. 100 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 97 101 ENDIF 98 !99 l_trd = .FALSE.100 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.101 102 ! 102 103 IF( l_trd ) THEN … … 244 245 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 245 246 246 CALL trd_tra( kt, cdtype, jn, jptra_ trd_xad, ztrdx, pun, ptn(:,:,:,jn) )247 CALL trd_tra( kt, cdtype, jn, jptra_ trd_yad, ztrdy, pvn, ptn(:,:,:,jn) )248 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, ztrdz, pwn, ptn(:,:,:,jn) )247 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 248 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 249 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 249 250 END IF 250 251 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 518 519 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 519 520 520 CALL trd_tra( kt, cdtype, jn, jptra_ trd_xad, ztrdx, pun, ptn(:,:,:,jn) )521 CALL trd_tra( kt, cdtype, jn, jptra_ trd_yad, ztrdy, pvn, ptn(:,:,:,jn) )522 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, ztrdz, pwn, ptn(:,:,:,jn) )521 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 522 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 523 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 523 524 END IF 524 525 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 552 553 !! in-space based differencing for fluid 553 554 !!---------------------------------------------------------------------- 554 !555 !!----------------------------------------------------------------------556 555 REAL(wp), DIMENSION(jpk) , INTENT(in ) :: p2dt ! vertical profile of tracer time-step 557 556 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field 558 557 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 559 558 ! 560 INTEGER :: ji, jj, jk ! dummy loop indices561 INTEGER :: ikm1 ! local integer559 INTEGER :: ji, jj, jk ! dummy loop indices 560 INTEGER :: ikm1 ! local integer 562 561 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt ! local scalars 563 562 REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - … … 569 568 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) 570 569 ! 571 572 570 zbig = 1.e+40_wp 573 571 zrtrn = 1.e-15_wp 574 572 zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp 575 573 576 577 574 ! Search local extrema 578 575 ! -------------------- 579 576 ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 580 zbup = MAX( pbef * tmask - zbig * ( 1. e0- tmask ), &581 & paft * tmask - zbig * ( 1. e0- tmask ) )582 zbdo = MIN( pbef * tmask + zbig * ( 1. e0- tmask ), &583 & paft * tmask + zbig * ( 1. e0- tmask ) )577 zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & 578 & paft * tmask - zbig * ( 1._wp - tmask ) ) 579 zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & 580 & paft * tmask + zbig * ( 1._wp - tmask ) ) 584 581 585 582 DO jj = 2, jpjm1 … … 625 622 DO jj = 2, jpjm1 626 623 DO ji = fs_2, fs_jpim1 ! vector opt. 627 zau = MIN( 1. e0, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) )628 zbu = MIN( 1. e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) )624 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 625 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 629 626 zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) ) 630 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1. e0- zcu) * zbu )631 632 zav = MIN( 1. e0, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) )633 zbv = MIN( 1. e0, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) )627 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 628 629 zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 630 zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 634 631 zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 635 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1. e0- zcv) * zbv )632 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 636 633 637 634 ! monotonic flux in the k direction, i.e. pcc … … 640 637 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 641 638 zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 642 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1. e0- zc) * zb )639 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 643 640 END DO 644 641 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r4499 r4946 14 14 USE oce ! ocean dynamics and active tracers 15 15 USE dom_oce ! ocean space and time domain 16 USE trdmod_oce ! ocean space and time domain 17 USE trdtra 18 USE lib_mpp 16 USE trc_oce ! share passive tracers/Ocean variables 17 USE trd_oce ! trends: ocean variables 18 USE trdtra ! trends manager: tracers 19 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 20 USE diaptr ! poleward transport diagnostics 21 ! 22 USE lib_mpp ! I/O library 19 23 USE lbclnk ! ocean lateral boundary condition (or mpp link) 20 24 USE in_out_manager ! I/O manager 21 USE diaptr ! poleward transport diagnostics22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient23 USE trc_oce ! share passive tracers/Ocean variables24 25 USE wrk_nemo ! Memory Allocation 25 26 USE timing ! Timing … … 51 52 !! and add it to the general trend of passive tracer equations. 52 53 !! 53 !! ** Method : The upstream biased 3rd order scheme (UBS) is based on an54 !! ** Method : The upstream biased scheme (UBS) is based on a 3rd order 54 55 !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) 55 56 !! It is only used in the horizontal direction. 56 57 !! For example the i-component of the advective fluxes are given by : 57 58 !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 58 !! z wx= ! or59 !! ztu = ! or 59 60 !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 60 61 !! where zltu is the second derivative of the before temperature field: … … 76 77 !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741. 77 78 !!---------------------------------------------------------------------- 78 USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace79 !80 79 INTEGER , INTENT(in ) :: kt ! ocean time-step index 81 80 INTEGER , INTENT(in ) :: kit000 ! first time step index … … 98 97 CALL wrk_alloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) 99 98 ! 100 101 99 IF( kt == kit000 ) THEN 102 100 IF(lwp) WRITE(numout,*) … … 151 149 zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) ) 152 150 ! UBS advective fluxes 153 z wx(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) )154 z wy(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) )151 ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 152 ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 155 153 END DO 156 154 END DO … … 159 157 zltu(:,:,:) = pta(:,:,:,jn) ! store pta trends 160 158 161 ! Horizontal advective trends 162 DO jk = 1, jpkm1 163 ! Tracer flux divergence at t-point added to the general trend 159 DO jk = 1, jpkm1 ! Horizontal advective trends 164 160 DO jj = 2, jpjm1 165 161 DO ji = fs_2, fs_jpim1 ! vector opt. 166 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 167 ! horizontal advective 168 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & 169 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) 170 ! add it to the general tracer trends 171 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 162 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) & 163 & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & 164 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 172 165 END DO 173 166 END DO … … 178 171 zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:) 179 172 180 ! 3. Save the horizontal advective trends for diagnostic 181 ! ------------------------------------------------------ 182 ! ! trend diagnostics (contribution of upstream fluxes) 183 IF( l_trd ) THEN 184 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptn(:,:,:,jn) ) 185 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptn(:,:,:,jn) ) 173 ! 174 IF( l_trd ) THEN ! trend diagnostics 175 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) ) 176 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) ) 186 177 END IF 187 178 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 188 179 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 189 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( z wy(:,:,:) )190 IF( jn == jp_sal ) str_adv(:) = ptr_vj( z wy(:,:,:) )180 IF( jn == jp_tem ) htr_adv(:) = ptr_vj( ztv(:,:,:) ) 181 IF( jn == jp_sal ) str_adv(:) = ptr_vj( ztv(:,:,:) ) 191 182 ENDIF 192 183 … … 265 256 END DO 266 257 END DO 267 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, zltv )258 CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv ) 268 259 ENDIF 269 260 ! 270 END DO261 END DO 271 262 ! 272 263 CALL wrk_dealloc( jpi, jpj, jpk, ztu, ztv, zltu, zltv, zti, ztw ) … … 290 281 !! in-space based differencing for fluid 291 282 !!---------------------------------------------------------------------- 292 !293 283 REAL(wp), INTENT(in ), DIMENSION(jpk) :: p2dt ! vertical profile of tracer time-step 294 284 REAL(wp), DIMENSION (jpi,jpj,jpk) :: pbef ! before field … … 306 296 CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo ) 307 297 ! 308 309 298 zbig = 1.e+40_wp 310 299 zrtrn = 1.e-15_wp -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r4624 r4946 18 18 USE dom_oce ! domain: ocean 19 19 USE phycst ! physical constants 20 USE trd mod_oce ! trends: ocean variables21 USE trdtra ! trends : activetracers20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 22 22 USE in_out_manager ! I/O manager 23 23 USE prtctl ! Print control … … 84 84 ! 85 85 ! ! Add the geothermal heat flux trend on temperature 86 #if defined key_vectopt_loop87 DO jj = 1, 188 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)89 #else90 86 DO jj = 2, jpjm1 91 87 DO ji = 2, jpim1 92 #endif93 88 ik = mbkt(ji,jj) 94 89 zqgh_trd = qgh_trd0(ji,jj) / fse3t(ji,jj,ik) … … 99 94 IF( l_trdtra ) THEN ! Save the geothermal heat flux trend for diagnostics 100 95 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 101 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_bbc, ztrdt )96 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 102 97 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 103 98 ENDIF … … 130 125 INTEGER :: inum ! temporary logical unit 131 126 INTEGER :: ios ! Local integer output status for namelist read 132 ! !127 ! 133 128 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst 134 129 !!---------------------------------------------------------------------- -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r4726 r4946 12 12 !! - ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC 13 13 !! - ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level 14 !! - ! 2013-04 (F. Roquet, G. Madec) use of eosbn2 instead of local hard coded alpha and beta 14 15 !!---------------------------------------------------------------------- 15 16 #if defined key_trabbl || defined key_esopa … … 28 29 USE phycst ! physical constant 29 30 USE eosbn2 ! equation of state 30 USE trd mod_oce ! trends: ocean variables31 USE trd_oce ! trends: ocean variables 31 32 USE trdtra ! trends: active tracers 32 USE iom ! IOM server 33 ! 34 USE iom ! IOM library 33 35 USE in_out_manager ! I/O manager 34 36 USE lbclnk ! ocean lateral boundary conditions … … 36 38 USE wrk_nemo ! Memory Allocation 37 39 USE timing ! Timing 38 40 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 39 41 40 42 IMPLICIT NONE … … 57 59 REAL(wp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] 58 60 59 LOGICAL , PUBLIC :: l_bbl 61 LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport 60 62 61 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer … … 84 86 & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d (jpi,jpj) , mgrhv(jpi,jpj) , & 85 87 & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & 86 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT= tra_bbl_alloc)88 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) 87 89 ! 88 90 IF( lk_mpp ) CALL mpp_sum ( tra_bbl_alloc ) … … 104 106 !!---------------------------------------------------------------------- 105 107 INTEGER, INTENT( in ) :: kt ! ocean time-step 106 ! !108 ! 107 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 108 110 !!---------------------------------------------------------------------- … … 110 112 IF( nn_timing == 1 ) CALL timing_start( 'tra_bbl') 111 113 ! 112 IF( l_trdtra ) THEN !* Save ta and sa trends114 IF( l_trdtra ) THEN !* Save ta and sa trends 113 115 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 114 116 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 116 118 ENDIF 117 119 118 IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl)119 120 IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl120 IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl) 121 122 IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl 121 123 ! 122 124 CALL tra_bbl_dif( tsb, tsa, jpts ) 123 125 IF( ln_ctl ) & 124 126 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 125 &tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )127 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 126 128 ! lateral boundary conditions ; just need for outputs 127 129 CALL lbc_lnk( ahu_bbl, 'U', 1. ) ; CALL lbc_lnk( ahv_bbl, 'V', 1. ) … … 131 133 END IF 132 134 133 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl135 IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl 134 136 ! 135 137 CALL tra_bbl_adv( tsb, tsa, jpts ) 136 138 IF(ln_ctl) & 137 139 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 138 &tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )140 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 139 141 ! lateral boundary conditions ; just need for outputs 140 142 CALL lbc_lnk( utr_bbl, 'U', 1. ) ; CALL lbc_lnk( vtr_bbl, 'V', 1. ) … … 147 149 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 148 150 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 149 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_bbl, ztrdt )150 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_bbl, ztrds )151 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 152 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 151 153 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 152 154 ENDIF … … 164 166 !! advection terms. 165 167 !! 166 !! ** Method : 167 !! * diffusive bbl (nn_bbl_ldf=1) : 168 !! ** Method : * diffusive bbl only (nn_bbl_ldf=1) : 168 169 !! When the product grad( rho) * grad(h) < 0 (where grad is an 169 170 !! along bottom slope gradient) an additional lateral 2nd order … … 179 180 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 180 181 !!---------------------------------------------------------------------- 181 !182 182 INTEGER , INTENT(in ) :: kjpt ! number of tracers 183 183 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields … … 196 196 DO jn = 1, kjpt ! tracer loop 197 197 ! ! =========== 198 # if defined key_vectopt_loop199 DO jj = 1, 1 ! vector opt. (forced unrolling)200 DO ji = 1, jpij201 #else202 198 DO jj = 1, jpj 203 199 DO ji = 1, jpi 204 #endif 205 ik = mbkt(ji,jj) ! bottom T-level index 206 zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S 200 ik = mbkt(ji,jj) ! bottom T-level index 201 zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S 207 202 END DO 208 203 END DO 209 ! ! Compute the trend 210 # if defined key_vectopt_loop 211 DO jj = 1, 1 ! vector opt. (forced unrolling) 212 DO ji = jpi+1, jpij-jpi-1 213 # else 214 DO jj = 2, jpjm1 204 ! 205 DO jj = 2, jpjm1 ! Compute the trend 215 206 DO ji = 2, jpim1 216 # endif 217 ik = mbkt(ji,jj) ! bottom T-level index 207 ik = mbkt(ji,jj) ! bottom T-level index 218 208 zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,ik) 219 209 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn) & … … 264 254 DO jn = 1, kjpt ! tracer loop 265 255 ! ! =========== 266 # if defined key_vectopt_loop267 DO jj = 1, 1268 DO ji = 1, jpij-jpi-1 ! vector opt. (forced unrolling)269 # else270 256 DO jj = 1, jpjm1 271 257 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 272 # endif273 258 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 274 259 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) … … 333 318 !! advection terms. 334 319 !! 335 !! ** Method : 336 !! * diffusive bbl (nn_bbl_ldf=1) : 320 !! ** Method : * diffusive bbl (nn_bbl_ldf=1) : 337 321 !! When the product grad( rho) * grad(h) < 0 (where grad is an 338 322 !! along bottom slope gradient) an additional lateral 2nd order … … 342 326 !! a downslope velocity of 20 cm/s if the condition for slope 343 327 !! convection is satified) 344 !! * advective bbl (nn_bbl_adv=1 or 2) :328 !! * advective bbl (nn_bbl_adv=1 or 2) : 345 329 !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity 346 330 !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation … … 353 337 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 354 338 !!---------------------------------------------------------------------- 355 !356 339 INTEGER , INTENT(in ) :: kt ! ocean time-step index 357 INTEGER , INTENT(in ) :: kit000 340 INTEGER , INTENT(in ) :: kit000 ! first time step index 358 341 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 359 342 !! 360 343 INTEGER :: ji, jj ! dummy loop indices 361 344 INTEGER :: ik ! local integers 362 INTEGER :: iis , iid , ijs , ijd ! - - 363 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 364 REAL(wp) :: zsign, zsigna, zgbbl ! local scalars 365 REAL(wp) :: zgdrho, zt, zs, zh ! - - 366 !! 367 REAL(wp) :: fsalbt, fsbeta, pft, pfs, pfh ! statement function 368 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb, ztb, zsb, zdep 369 !!----------------------- zv_bbl----------------------------------------------- 370 ! ratio alpha/beta = fsalbt : ratio of thermal over saline expension coefficients 371 ! ================ pft : potential temperature in degrees celcius 372 ! pfs : salinity anomaly (s-35) in psu 373 ! pfh : depth in meters 374 ! nn_eos = 0 (Jackett and McDougall 1994 formulation) 375 fsalbt( pft, pfs, pfh ) = & ! alpha/beta 376 ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft & 377 - 0.203814e-03 ) * pft & 378 + 0.170907e-01 ) * pft & 379 + 0.665157e-01 & 380 +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs & 381 + ( ( - 0.302285e-13 * pfh & 382 - 0.251520e-11 * pfs & 383 + 0.512857e-12 * pft * pft ) * pfh & 384 - 0.164759e-06 * pfs & 385 +( 0.791325e-08 * pft - 0.933746e-06 ) * pft & 386 + 0.380374e-04 ) * pfh 387 fsbeta( pft, pfs, pfh ) = & ! beta 388 ( ( -0.415613e-09 * pft + 0.555579e-07 ) * pft & 389 - 0.301985e-05 ) * pft & 390 + 0.785567e-03 & 391 + ( 0.515032e-08 * pfs & 392 + 0.788212e-08 * pft - 0.356603e-06 ) * pfs & 393 +( ( 0.121551e-17 * pfh & 394 - 0.602281e-15 * pfs & 395 - 0.175379e-14 * pft + 0.176621e-12 ) * pfh & 396 + 0.408195e-10 * pfs & 397 + ( - 0.213127e-11 * pft + 0.192867e-09 ) * pft & 398 - 0.121555e-07 ) * pfh 399 !!---------------------------------------------------------------------- 400 345 INTEGER :: iis, iid, ikus, ikud ! - - 346 INTEGER :: ijs, ijd, ikvs, ikvd ! - - 347 REAL(wp) :: za, zb, zgdrho ! local scalars 348 REAL(wp) :: zsign, zsigna, zgbbl ! - - 349 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 350 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 351 !!---------------------------------------------------------------------- 401 352 ! 402 353 IF( nn_timing == 1 ) CALL timing_start( 'bbl') 403 354 ! 404 CALL wrk_alloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )405 !406 407 355 IF( kt == kit000 ) THEN 408 356 IF(lwp) WRITE(numout,*) … … 410 358 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 411 359 ENDIF 412 413 ! !* bottom temperature, salinity, velocity and depth 414 #if defined key_vectopt_loop 415 DO jj = 1, 1 ! vector opt. (forced unrolling) 416 DO ji = 1, jpij 417 #else 360 ! !* bottom variables (T, S, alpha, beta, depth, velocity) 418 361 DO jj = 1, jpj 419 362 DO ji = 1, jpi 420 #endif 421 ik = mbkt(ji,jj) ! bottom T-level index 422 ztb (ji,jj) = tsb(ji,jj,ik,jp_tem) * ssmask(ji,jj) ! bottom before T and S 423 zsb (ji,jj) = tsb(ji,jj,ik,jp_sal) * ssmask(ji,jj) 424 zdep(ji,jj) = gdept_0(ji,jj,ik) ! bottom T-level reference depth 363 ik = mbkt(ji,jj) ! bottom T-level index 364 zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem) ! bottom before T and S 365 zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 425 366 ! 426 zub(ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 427 zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 367 zdep(ji,jj) = fsdept(ji,jj,ik) ! bottom T-level reference depth 368 zub (ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 369 zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 428 370 END DO 429 371 END DO 430 372 ! 373 CALL eos_rab( zts, zdep, zab ) 374 ! 431 375 ! !-------------------! 432 376 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 433 377 ! !-------------------! 434 378 DO jj = 1, jpjm1 ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 435 DO ji = 1, jpim1 436 ! ! i-direction 437 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 438 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 439 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 440 ! ! masked bbl i-gradient of density 441 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 442 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 379 DO ji = 1, fs_jpim1 ! vector opt. 380 ! ! i-direction 381 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 382 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 383 ! ! 2*masked bottom density gradient 384 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 385 & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 443 386 ! 444 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope )445 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) 387 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) 388 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. 446 389 ! 447 ! ! j-direction 448 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 449 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 450 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 451 ! ! masked bbl j-gradient of density 452 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 453 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 390 ! ! j-direction 391 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 392 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 393 ! ! 2*masked bottom density gradient 394 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 395 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 454 396 ! 455 zsign 397 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) 456 398 ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 457 !458 399 END DO 459 400 END DO … … 469 410 DO jj = 1, jpjm1 ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 470 411 DO ji = 1, fs_jpim1 ! vector opt. 471 ! ! i-direction 472 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 473 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 474 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 475 ! ! masked bbl i-gradient of density 476 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 477 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 478 ! 479 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 480 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 481 ! 482 ! ! bbl velocity 412 ! ! i-direction 413 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 414 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 415 ! ! 2*masked bottom density gradient 416 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 417 - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 418 ! 419 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 420 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 421 ! 422 ! ! bbl velocity 483 423 utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 484 424 ! 485 ! ! j-direction 486 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 487 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 488 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 489 ! ! masked bbl j-gradient of density 490 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 491 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 492 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 493 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 494 ! 495 ! ! bbl velocity 425 ! ! j-direction 426 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 427 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 428 ! ! 2*masked bottom density gradient 429 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 430 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 431 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 432 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 433 ! 434 ! ! bbl transport 496 435 vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 497 436 END DO … … 502 441 DO jj = 1, jpjm1 ! criteria: rho_up > rho_down 503 442 DO ji = 1, fs_jpim1 ! vector opt. 504 ! ! i-direction443 ! ! i-direction 505 444 ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) 506 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 507 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 508 ! 509 ! ! mid-depth density anomalie (up-slope minus down-slope) 510 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! mid slope depth of T, S, and depth 511 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 512 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 513 zgdrho = fsbeta( zt, zs, zh ) & 514 & * ( fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) ) & 515 & - ( zsb(iid,jj) - zsb(iis,jj) ) ) * umask(ji,jj,1) 516 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 517 ! 518 ! ! bbl transport (down-slope direction) 445 iid = ji + MAX( 0, mgrhu(ji,jj) ) 446 iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 447 ! 448 ikud = mbku_d(ji,jj) 449 ikus = mbku(ji,jj) 450 ! 451 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 452 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 453 ! ! masked bottom density gradient 454 zgdrho = 0.5 * ( za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) ) & 455 & - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) ) ) * umask(ji,jj,1) 456 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 457 ! 458 ! ! bbl transport (down-slope direction) 519 459 utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 520 460 ! 521 ! ! j-direction461 ! ! j-direction 522 462 ! down-slope T-point j/k-index (deep) & of the up -slope T-point j/k-index (shelf) 523 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 524 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 525 ! 526 ! ! mid-depth density anomalie (up-slope minus down-slope) 527 zt = 0.5 * ( ztb (ji,jj) + ztb (ji,jj+1) ) ! mid slope depth of T, S, and depth 528 zs = 0.5 * ( zsb (ji,jj) + zsb (ji,jj+1) ) - 35.0 529 zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 530 zgdrho = fsbeta( zt, zs, zh ) & 531 & * ( fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) ) & 532 & - ( zsb(ji,ijd) - zsb(ji,ijs) ) ) * vmask(ji,jj,1) 533 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 534 ! 535 ! ! bbl transport (down-slope direction) 463 ijd = jj + MAX( 0, mgrhv(ji,jj) ) 464 ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 465 ! 466 ikvd = mbkv_d(ji,jj) 467 ikvs = mbkv(ji,jj) 468 ! 469 za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point 470 zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 471 ! ! masked bottom density gradient 472 zgdrho = 0.5 * ( za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) ) & 473 & - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) ) ) * vmask(ji,jj,1) 474 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 475 ! 476 ! ! bbl transport (down-slope direction) 536 477 vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 537 478 END DO … … 541 482 ENDIF 542 483 ! 543 CALL wrk_dealloc( jpi, jpj, zub, zvb, ztb, zsb, zdep )544 !545 484 IF( nn_timing == 1 ) CALL timing_stop( 'bbl') 546 485 ! … … 558 497 !!---------------------------------------------------------------------- 559 498 INTEGER :: ji, jj ! dummy loop indices 560 INTEGER :: ii0, ii1, ij0, ij1 ! temporaryinteger561 INTEGER :: ios ! Local integer output status for namelist read499 INTEGER :: ii0, ii1, ij0, ij1 ! local integer 500 INTEGER :: ios ! - - 562 501 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 563 502 !! … … 598 537 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 599 538 600 IF( nn_eos /= 0 ) CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' )601 602 539 ! !* vertical index of "deep" bottom u- and v-points 603 540 DO jj = 1, jpjm1 ! (the "shelf" bottom k-indices are mbku and mbkv) … … 607 544 END DO 608 545 END DO 609 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk546 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 610 547 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 611 548 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 612 549 613 !* sign of grad(H) at u- and v-points614 mgrhu(jpi,:) = 0 . ; mgrhu(:,jpj) = 0. ; mgrhv(jpi,:) = 0. ; mgrhv(:,jpj) = 0.550 !* sign of grad(H) at u- and v-points 551 mgrhu(jpi,:) = 0 ; mgrhu(:,jpj) = 0 ; mgrhv(jpi,:) = 0 ; mgrhv(:,jpj) = 0 615 552 DO jj = 1, jpjm1 616 553 DO ji = 1, jpim1 … … 621 558 622 559 DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point 623 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0)560 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0) 624 561 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 625 562 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r4624 r4946 28 28 USE dom_oce ! ocean: domain variables 29 29 USE c1d ! 1D vertical configuration 30 USE trd mod_oce ! ocean: trendvariables31 USE trdtra ! active tracers: trends30 USE trd_oce ! trends: ocean variables 31 USE trdtra ! trends manager: tracers 32 32 USE zdf_oce ! ocean: vertical physics 33 33 USE phycst ! physical constants … … 48 48 PUBLIC dtacof_zoom ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90 49 49 50 !!gm why all namelist variable public???? only ln_tradmp should be sufficient 51 50 52 ! !!* Namelist namtra_dmp : T & S newtonian damping * 51 53 LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag … … 112 114 ! 113 115 CALL wrk_alloc( jpi, jpj, jpk, jpts, zts_dta ) 116 ! 114 117 ! !== input T-S data at kt ==! 115 118 CALL dta_tsd( kt, zts_dta ) ! read and interpolates T-S data at kt … … 172 175 ! 173 176 IF( l_trdtra ) THEN ! trend diagnostic 174 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_dmp, ttrdmp )175 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_dmp, strdmp )177 CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ttrdmp ) 178 CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, strdmp ) 176 179 ENDIF 177 180 ! ! Control print … … 194 197 !! ** Method : read the namtra_dmp namelist and check the parameters 195 198 !!---------------------------------------------------------------------- 199 INTEGER :: ios ! Local integer output status for namelist read 200 !! 196 201 NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file 197 INTEGER :: ios ! Local integer output status for namelist read 198 !!---------------------------------------------------------------------- 199 202 !!---------------------------------------------------------------------- 203 ! 200 204 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term 201 205 READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 202 206 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 203 207 ! 204 208 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term 205 209 READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) … … 228 232 IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 229 233 ! 234 !!gm I don't understand the specificities of c1d case...... 235 !!gm to be check with the autor of these lines 236 230 237 #if ! defined key_c1d 231 238 SELECT CASE ( nn_hdmp ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r4666 r4946 23 23 USE traldf_iso_grif ! lateral mixing (tra_ldf_iso_grif routine) 24 24 USE traldf_lap ! lateral mixing (tra_ldf_lap routine) 25 USE trdmod_oce ! ocean space and time domain 26 USE trdtra ! ocean active tracers trends 25 USE trd_oce ! trends: ocean variables 26 USE trdtra ! trends manager: tracers 27 ! 27 28 USE prtctl ! Print control 28 29 USE in_out_manager ! I/O manager … … 35 36 PRIVATE 36 37 37 PUBLIC tra_ldf 38 PUBLIC tra_ldf_init 38 PUBLIC tra_ldf ! called by step.F90 39 PUBLIC tra_ldf_init ! called by opa.F90 39 40 ! 40 41 INTEGER :: nldf = 0 ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) … … 118 119 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 119 120 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 120 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_ldf, ztrdt )121 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_ldf, ztrds )121 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 122 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 122 123 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 123 124 ENDIF … … 180 181 IF ( ln_traldf_iso ) nldf = 1 ! isoneutral ( rotation) 181 182 ENDIF 182 IF ( ln_zps ) THEN ! z -coordinate183 IF ( ln_zps ) THEN ! zps-coordinate 183 184 IF ( ln_traldf_level ) ierr = 1 ! iso-level not allowed 184 185 IF ( ln_traldf_hor ) nldf = 0 ! horizontal (no rotation) 185 186 IF ( ln_traldf_iso ) nldf = 1 ! isoneutral ( rotation) 186 187 ENDIF 187 IF ( ln_sco ) THEN ! z-coordinate188 IF ( ln_sco ) THEN ! s-coordinate 188 189 IF ( ln_traldf_level ) nldf = 0 ! iso-level (no rotation) 189 190 IF ( ln_traldf_hor ) nldf = 1 ! horizontal ( rotation) … … 198 199 IF ( ln_traldf_iso ) ierr = 2 ! isoneutral ( rotation) 199 200 ENDIF 200 IF ( ln_zps ) THEN ! z -coordinate201 IF ( ln_zps ) THEN ! zps-coordinate 201 202 IF ( ln_traldf_level ) ierr = 1 ! iso-level not allowed 202 203 IF ( ln_traldf_hor ) nldf = 2 ! horizontal (no rotation) 203 204 IF ( ln_traldf_iso ) ierr = 2 ! isoneutral ( rotation) 204 205 ENDIF 205 IF ( ln_sco ) THEN ! z-coordinate206 IF ( ln_sco ) THEN ! s-coordinate 206 207 IF ( ln_traldf_level ) nldf = 2 ! iso-level (no rotation) 207 208 IF ( ln_traldf_hor ) nldf = 3 ! horizontal ( rotation) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90
r3632 r4946 252 252 END DO 253 253 IF( ln_zps.and.l_grad_zps ) THEN ! partial steps: correction at the last level 254 # if defined key_vectopt_loop255 DO jj = 1, 1256 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling)257 # else258 254 DO jj = 1, jpjm1 259 255 DO ji = 1, jpim1 260 # endif261 256 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 262 257 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90
r4313 r4946 2 2 !!============================================================================== 3 3 !! *** MODULE tranpc *** 4 !! Ocean active tracers: non penetrative convecti onscheme4 !! Ocean active tracers: non penetrative convective adjustment scheme 5 5 !!============================================================================== 6 6 !! History : 1.0 ! 1990-09 (G. Madec) Original code … … 9 9 !! 3.0 ! 2008-06 (G. Madec) applied on ta, sa and called before tranxt in step.F90 10 10 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 11 !! 3.7 ! 2014-06 (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 11 12 !!---------------------------------------------------------------------- 12 13 … … 14 15 !! tra_npc : apply the non penetrative convection scheme 15 16 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and active tracers 17 USE oce ! ocean dynamics and active tracers 17 18 USE dom_oce ! ocean space and time domain 19 USE phycst ! physical constants 18 20 USE zdf_oce ! ocean vertical physics 19 USE trd mod_oce! ocean active tracer trends21 USE trd_oce ! ocean active tracer trends 20 22 USE trdtra ! ocean active tracer trends 21 USE eosbn2 ! equation of state (eos routine) 23 USE eosbn2 ! equation of state (eos routine) 24 ! 22 25 USE lbclnk ! lateral boundary conditions (or mpp link) 23 26 USE in_out_manager ! I/O manager … … 29 32 PRIVATE 30 33 31 PUBLIC tra_npc 34 PUBLIC tra_npc ! routine called by step.F90 32 35 33 36 !! * Substitutions 34 37 # include "domzgr_substitute.h90" 35 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 37 !! $Id$ 38 # include "vectopt_loop_substitute.h90" 39 !!---------------------------------------------------------------------- 40 !! NEMO/OPA 3.6 , NEMO Consortium (2014) 41 !! $Id$ 38 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 39 43 !!---------------------------------------------------------------------- … … 44 48 !! *** ROUTINE tranpc *** 45 49 !! 46 !! ** Purpose : Non penetrative convective adjustment scheme. solve50 !! ** Purpose : Non-penetrative convective adjustment scheme. solve 47 51 !! the static instability of the water column on after fields 48 52 !! while conserving heat and salt contents. 49 53 !! 50 !! ** Method : The algorithm used converges in a maximium of jpk 51 !! iterations. instabilities are treated when the vertical density 52 !! gradient is less than 1.e-5. 53 !! l_trdtra=T: the trend associated with this algorithm is saved. 54 !! ** Method : updated algorithm able to deal with non-linear equation of state 55 !! (i.e. static stability computed locally) 54 56 !! 55 57 !! ** Action : - (ta,sa) after the application od the npc scheme 56 !! - s ave the associated trends (ttrd,strd) ('key_trdtra')58 !! - send the associated trends for on-line diagnostics (l_trdtra=T) 57 59 !! 58 !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371.60 !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. 59 61 !!---------------------------------------------------------------------- 60 !61 62 INTEGER, INTENT(in) :: kt ! ocean time-step index 62 63 ! 63 64 INTEGER :: ji, jj, jk ! dummy loop indices 64 65 INTEGER :: inpcc ! number of statically instable water column 65 INTEGER :: inpci ! number of iteration for npc scheme 66 INTEGER :: jiter, jkdown, jkp ! ??? 67 INTEGER :: ikbot, ik, ikup, ikdown ! ??? 68 REAL(wp) :: ze3tot, zta, zsa, zraua, ze3dwn 69 REAL(wp), POINTER, DIMENSION(:,: ) :: zwx, zwy, zwz 70 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds, zrhop 66 INTEGER :: jiter, ikbot, ik, ikup, ikdown, ilayer, ikm ! local integers 67 LOGICAL :: l_bottom_reached, l_column_treated 68 REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 69 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 70 REAL(wp), POINTER, DIMENSION(:) :: zvn2 ! vertical profile of N2 at 1 given point... 71 REAL(wp), POINTER, DIMENSION(:,:) :: zvts ! vertical profile of T and S at 1 given point... 72 REAL(wp), POINTER, DIMENSION(:,:) :: zvab ! vertical profile of alpha and beta 73 REAL(wp), POINTER, DIMENSION(:,:,:) :: zn2 ! N^2 74 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zab ! alpha and beta 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 76 ! 77 !!LB debug: 78 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. 79 INTEGER :: ilc1, jlc1, klc1, nncpu 80 LOGICAL :: lp_monitor_point = .FALSE. 81 !!LB debug. 71 82 !!---------------------------------------------------------------------- 72 83 ! 73 84 IF( nn_timing == 1 ) CALL timing_start('tra_npc') 74 85 ! 75 CALL wrk_alloc(jpi, jpj, jpk, zrhop )76 CALL wrk_alloc(jpi, jpk, zwx, zwy, zwz )77 !78 86 IF( MOD( kt, nn_npc ) == 0 ) THEN 79 80 inpcc = 081 inpci = 082 83 CALL eos( tsa, rhd, zrhop, fsdept_n(:,:,:) ) ! Potential density84 85 IF( l_trdtra ) THEN !* Save ta and sa trends87 ! 88 CALL wrk_alloc( jpi, jpj, jpk, zn2 ) ! N2 89 CALL wrk_alloc( jpi, jpj, jpk, 2, zab ) ! Alpha and Beta 90 CALL wrk_alloc( jpk, 2, zvts, zvab ) ! 1D column vector at point ji,jj 91 CALL wrk_alloc( jpk, zvn2 ) ! 1D column vector at point ji,jj 92 93 IF( l_trdtra ) THEN !* Save initial after fields 86 94 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 87 95 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 89 97 ENDIF 90 98 91 ! ! =============== 92 DO jj = 1, jpj ! Vertical slab 93 ! ! =============== 94 ! Static instability pointer 95 ! ---------------------------- 96 DO jk = 1, jpkm1 97 DO ji = 1, jpi 98 zwx(ji,jk) = ( zrhop(ji,jj,jk) - zrhop(ji,jj,jk+1) ) * tmask(ji,jj,jk+1) 99 END DO 100 END DO 101 102 ! 1.1 do not consider the boundary points 103 104 ! even if east-west cyclic b. c. do not considere ji=1 or jpi 105 DO jk = 1, jpkm1 106 zwx( 1 ,jk) = 0.e0 107 zwx(jpi,jk) = 0.e0 108 END DO 109 ! even if south-symmetric b. c. used, do not considere jj=1 110 IF( jj == 1 ) zwx(:,:) = 0.e0 111 112 DO jk = 1, jpkm1 113 DO ji = 1, jpi 114 zwx(ji,jk) = 1. 115 IF( zwx(ji,jk) < 1.e-5 ) zwx(ji,jk) = 0.e0 116 END DO 117 END DO 118 119 zwy(:,1) = 0.e0 120 DO ji = 1, jpi 121 DO jk = 1, jpkm1 122 zwy(ji,1) = zwy(ji,1) + zwx(ji,jk) 123 END DO 124 END DO 125 126 zwz(1,1) = 0.e0 127 DO ji = 1, jpi 128 zwz(1,1) = zwz(1,1) + zwy(ji,1) 129 END DO 130 131 inpcc = inpcc + NINT( zwz(1,1) ) 132 133 134 ! 2. Vertical mixing for each instable portion of the density profil 135 ! ------------------------------------------------------------------ 136 137 IF( zwz(1,1) /= 0.e0 ) THEN ! -->> the density profil is statically instable : 138 DO ji = 1, jpi 139 IF( zwy(ji,1) /= 0.e0 ) THEN 99 !LB debug: 100 IF( lwp .AND. l_LB_debug ) THEN 101 WRITE(numout,*) 102 WRITE(numout,*) 'LOLO: entering tra_npc, kt, narea =', kt, narea 103 ENDIF 104 !LBdebug: Monitoring of 1 column subject to convection... 105 IF( l_LB_debug ) THEN 106 ! Location of 1 known convection spot to follow what's happening in the water column 107 ilc1 = 54 ; jlc1 = 15 ; ! Labrador ORCA1 4x4 cpus: 108 nncpu = 15 ; ! the CPU domain contains the convection spot 109 !ilc1 = 14 ; jlc1 = 13 ; ! Labrador ORCA1 8x8 cpus: 110 !nncpu = 54 ; ! the CPU domain contains the convection spot 111 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 112 ENDIF 113 !LBdebug. 114 115 CALL eos_rab( tsa, zab ) ! after alpha and beta 116 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala 117 118 inpcc = 0 119 120 DO jj = 2, jpjm1 ! interior column only 121 DO ji = fs_2, fs_jpim1 122 ! 123 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points 124 ! ! consider one ocean column 125 zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem) ! temperature 126 zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal) ! salinity 127 128 zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha 129 zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta 130 zvn2(:) = zn2(ji,jj,:) ! N^2 131 132 IF( l_LB_debug ) THEN !LB debug: 133 lp_monitor_point = .FALSE. 134 IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 135 ! writing only if on CPU domain where conv region is: 136 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 137 138 IF(lp_monitor_point) THEN 139 WRITE(numout,*) '' ;WRITE(numout,*) '' ; 140 WRITE(numout,'("Time step = ",i6.6," !!!")') kt 141 WRITE(numout,'(" *** BEFORE anything, N^2 for point ",i3,",",i3,":" )') ji,jj 142 DO jk = 1, klc1 143 WRITE(numout,*) jk, zvn2(jk) 144 END DO 145 WRITE(numout,*) ' ' 146 ENDIF 147 ENDIF !LB debug end 148 149 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 150 ik = 1 ! because N2 is irrelevant at the surface level (will start at ik=2) 151 ilayer = 0 152 jiter = 0 153 l_column_treated = .FALSE. 154 155 DO WHILE ( .NOT. l_column_treated ) 140 156 ! 141 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 157 jiter = jiter + 1 158 159 IF( jiter >= 400 ) EXIT 160 161 l_bottom_reached = .FALSE. 162 163 DO WHILE ( .NOT. l_bottom_reached ) 164 165 ik = ik + 1 166 167 !! Checking level ik for instability 168 !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 169 170 IF( zvn2(ik) < 0. ) THEN ! Instability found! 171 172 ikm = ik ! first level whith negative N2 173 ilayer = ilayer + 1 ! yet another layer found.... 174 IF(jiter == 1) inpcc = inpcc + 1 175 176 IF(l_LB_debug .AND. lp_monitor_point) & 177 & WRITE(numout,*) 'Negative N2 at ik =', ikm, ' layer nb.', ilayer, & 178 & ' inpcc =', inpcc 179 180 !! Case we mix with upper regions where N2==0: 181 !! All the points above ikup where N2 == 0 must also be mixed => we go 182 !! upward to find a new ikup, where the layer doesn't have N2==0 183 ikup = ikm 184 DO jk = ikm, 2, -1 185 ikup = ikup - 1 186 IF( (zvn2(jk-1) > 0.).OR.(ikup == 1) ) EXIT 187 END DO 188 189 ! adjusting ikup if the upper part of the unstable column was neutral (N2=0) 190 IF((zvn2(ikup+1) == 0.).AND.(ikup /= 1)) ikup = ikup+1 ; 191 192 193 IF( lp_monitor_point ) WRITE(numout,*) ' => ikup is =', ikup, ' layer nb.', ilayer 194 195 zsum_temp = 0._wp 196 zsum_sali = 0._wp 197 zsum_alfa = 0._wp 198 zsum_beta = 0._wp 199 zsum_z = 0._wp 200 201 DO jk = ikup, ikbot+1 ! Inside the instable (and overlying neutral) portion of the column 202 ! 203 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' -> summing for jk =', jk 204 ! 205 zdz = fse3t(ji,jj,jk) 206 zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 207 zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 208 zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 209 zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 210 zsum_z = zsum_z + zdz 211 ! 212 !! EXIT if we found the bottom of the unstable portion of the water column 213 IF( (zvn2(jk+1) > 0.).OR.(jk == ikbot ).OR.((jk==ikm).AND.(zvn2(jk+1) == 0.)) ) EXIT 214 END DO 215 216 !ik = jk !LB remove? 217 ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative N2 218 219 IF(l_LB_debug .AND. lp_monitor_point) & 220 & WRITE(numout,*) ' => ikdown =', ikdown, ' layer nb.', ilayer 221 222 ! Mixing Temperature and salinity between ikup and ikdown: 223 zta = zsum_temp/zsum_z 224 zsa = zsum_sali/zsum_z 225 zalfa = zsum_alfa/zsum_z 226 zbeta = zsum_beta/zsum_z 227 228 IF(l_LB_debug .AND. lp_monitor_point) THEN 229 WRITE(numout,*) ' => Mean temp. in that portion =', zta 230 WRITE(numout,*) ' => Mean sali. in that portion =', zsa 231 WRITE(numout,*) ' => Mean Alpha in that portion =', zalfa 232 WRITE(numout,*) ' => Mean Beta in that portion =', zbeta 233 ENDIF 234 235 !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 236 DO jk = ikup, ikdown 237 zvts(jk,jp_tem) = zta 238 zvts(jk,jp_sal) = zsa 239 zvab(jk,jp_tem) = zalfa 240 zvab(jk,jp_sal) = zbeta 241 END DO 242 ! 243 !! Before updating N2, it is possible that another unstable 244 !! layer exists underneath the one we just homogeneized! 245 ik = ikdown 246 ! 247 ENDIF ! IF( zvn2(ik+1) < 0. ) THEN 248 ! 249 IF( ik == ikbot ) l_bottom_reached = .TRUE. 250 ! 251 END DO ! DO WHILE ( .NOT. l_bottom_reached ) 252 253 IF( ik /= ikbot ) STOP 'ERROR: tranpc.F90 => PROBLEM #1' 254 255 ! ******* At this stage ik == ikbot ! ******* 256 257 IF( ilayer > 0 ) THEN 258 !! least an unstable layer has been found 259 !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 260 !! => Need to re-compute N2! will use Alpha and Beta! 261 ! 262 DO jk = ikup+1, ikdown+1 ! we must go 1 point deeper than ikdown! 263 !! Doing exactly as in eosbn2.F90: 264 !! * Except that we only are interested in the sign of N2 !!! 265 !! => just considering the vertical gradient of density 266 zrw = (fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk)) & 267 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 268 zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 269 zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 270 271 !zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 272 ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & 273 ! & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 274 zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 275 & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) 276 END DO 277 278 IF(l_LB_debug .AND. lp_monitor_point) THEN 279 WRITE(numout, '(" *** After iteration #",i3.3,", N^2 for point ",i3,",",i3,":" )') & 280 & jiter, ji,jj 281 DO jk = 1, klc1 282 WRITE(numout,*) jk, zvn2(jk) 283 END DO 284 WRITE(numout,*) ' ' 285 ENDIF 286 287 ik = 1 ! starting again at the surface for the next iteration 288 ilayer = 0 289 ENDIF 142 290 ! 143 DO jiter = 1, jpk ! vertical iteration 144 ! 145 ! search of ikup : the first static instability from the sea surface 146 ! 147 ik = 0 148 220 CONTINUE 149 ik = ik + 1 150 IF( ik >= ikbot ) GO TO 200 151 zwx(ji,ik) = zrhop(ji,jj,ik) - zrhop(ji,jj,ik+1) 152 IF( zwx(ji,ik) <= 0.e0 ) GO TO 220 153 ikup = ik 154 ! the density profil is instable below ikup 155 ! ikdown : bottom of the instable portion of the density profil 156 ! search of ikdown and vertical mixing from ikup to ikdown 157 ! 158 ze3tot= fse3t(ji,jj,ikup) 159 zta = tsa (ji,jj,ikup,jp_tem) 160 zsa = tsa (ji,jj,ikup,jp_sal) 161 zraua = zrhop(ji,jj,ikup) 162 ! 163 DO jkdown = ikup+1, ikbot-1 164 IF( zraua <= zrhop(ji,jj,jkdown) ) THEN 165 ikdown = jkdown 166 GO TO 240 167 ENDIF 168 ze3dwn = fse3t(ji,jj,jkdown) 169 ze3tot = ze3tot + ze3dwn 170 zta = ( zta*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_tem)*ze3dwn )/ze3tot 171 zsa = ( zsa*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_sal)*ze3dwn )/ze3tot 172 zraua = ( zraua*(ze3tot-ze3dwn) + zrhop(ji,jj,jkdown)*ze3dwn )/ze3tot 173 inpci = inpci+1 174 END DO 175 ikdown = ikbot-1 176 240 CONTINUE 177 ! 178 DO jkp = ikup, ikdown-1 179 tsa (ji,jj,jkp,jp_tem) = zta 180 tsa (ji,jj,jkp,jp_sal) = zsa 181 zrhop(ji,jj,jkp ) = zraua 182 END DO 183 IF (ikdown == ikbot-1 .AND. zraua >= zrhop(ji,jj,ikdown) ) THEN 184 tsa (ji,jj,jkp,jp_tem) = zta 185 tsa (ji,jj,jkp,jp_sal) = zsa 186 zrhop(ji,jj,ikdown ) = zraua 187 ENDIF 188 END DO 189 ENDIF 190 200 CONTINUE 191 END DO 192 ! <<-- no more static instability on slab jj 193 ENDIF 194 ! ! =============== 195 END DO ! End of slab 196 ! ! =============== 197 ! 198 IF( l_trdtra ) THEN ! save the Non penetrative mixing trends for diagnostic 199 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 200 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 201 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_npc, ztrdt ) 202 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_npc, ztrds ) 291 IF( ik >= ikbot ) THEN 292 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' --- exiting jiter loop ---' 293 l_column_treated = .TRUE. 294 ENDIF 295 ! 296 END DO ! DO WHILE ( .NOT. l_column_treated ) 297 298 !! Updating tsa: 299 tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem) 300 tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 301 302 !! lolo: Should we update something else???? 303 !! => like alpha and beta? 304 305 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) '' 306 307 ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 308 309 END DO ! ji 310 END DO ! jj 311 ! 312 IF( l_trdtra ) THEN ! send the Non penetrative mixing trends for diagnostic 313 z1_r2dt = 1._wp / (2._wp * rdt) 314 ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt 315 ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt 316 CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 317 CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 203 318 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 204 319 ENDIF 205 206 ! Lateral boundary conditions on ( ta, sa ) ( Unchanged sign) 207 ! ------------------------------============ 320 ! 208 321 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ; CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 209 210 211 ! 2. non penetrative convective scheme statistics212 ! -----------------------------------------------213 IF( nn_npcp /= 0 .AND. MOD( kt, nn_npcp ) == 0 ) THEN214 IF(lwp) WRITE(numout,*)' kt=',kt, ' number of statically instable', &215 & ' water column : ',inpcc, ' number of iteration : ',inpci216 ENDIF217 !218 ENDIF219 !220 CALL wrk_dealloc(jpi, jpj, jpk, zrhop )221 CALL wrk_dealloc(jpi, jpk, zwx, zwy, zwz )322 ! 323 IF(lwp) THEN 324 WRITE(numout,*) 'LOLO: exiting tra_npc, kt =', kt 325 WRITE(numout,*)' => number of statically instable water column : ',inpcc 326 WRITE(numout,*) '' ; WRITE(numout,*) '' 327 ENDIF 328 ! 329 CALL wrk_dealloc(jpi, jpj, jpk, zn2 ) 330 CALL wrk_dealloc(jpi, jpj, jpk, 2, zab ) 331 CALL wrk_dealloc(jpk, zvn2 ) 332 CALL wrk_dealloc(jpk, 2, zvts, zvab ) 333 ! 334 ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN 222 335 ! 223 336 IF( nn_timing == 1 ) CALL timing_stop('tra_npc') -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r4328 r4946 27 27 USE dom_oce ! ocean space and time domain variables 28 28 USE sbc_oce ! surface boundary condition: ocean 29 USE zdf_oce ! ???29 USE zdf_oce ! ocean vertical mixing 30 30 USE domvvl ! variable volume 31 31 USE dynspg_oce ! surface pressure gradient variables 32 32 USE dynhpg ! hydrostatic pressure gradient 33 USE trdmod_oce ! ocean space and time domain variables 34 USE trdtra ! ocean active tracers trends 35 USE phycst 36 USE bdy_oce 33 USE trd_oce ! trends: ocean variables 34 USE trdtra ! trends manager: tracers 35 USE traqsr ! penetrative solar radiation (needed for nksr) 36 USE phycst ! physical constant 37 USE ldftra_oce ! lateral physics on tracers 38 USE bdy_oce ! BDY open boundary condition variables 37 39 USE bdytra ! open boundary condition (bdy_tra routine) 40 ! 38 41 USE in_out_manager ! I/O manager 39 42 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 40 43 USE prtctl ! Print control 41 USE traqsr ! penetrative solar radiation (needed for nksr) 44 USE wrk_nemo ! Memory allocation 45 USE timing ! Timing 42 46 #if defined key_agrif 43 47 USE agrif_opa_update 44 48 USE agrif_opa_interp 45 49 #endif 46 USE wrk_nemo ! Memory allocation47 USE timing ! Timing48 50 49 51 IMPLICIT NONE … … 80 82 !! at the local domain boundaries through lbc_lnk call, 81 83 !! at the one-way open boundaries (lk_bdy=T), 82 !! at the AGRIF zoom 84 !! at the AGRIF zoom boundaries (lk_agrif=T) 83 85 !! 84 86 !! - Update lateral boundary conditions on AGRIF children … … 127 129 ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 128 130 ztrds(:,:,:) = tsn(:,:,:,jp_sal) 131 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 132 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 133 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 134 ENDIF 129 135 ENDIF 130 136 … … 150 156 IF( l_trdtra ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 151 157 DO jk = 1, jpkm1 152 zfact = 1. e0_wp / r2dtra(jk)158 zfact = 1._wp / r2dtra(jk) 153 159 ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 154 160 ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 155 161 END DO 156 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_atf, ztrdt )157 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_atf, ztrds )162 CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) 163 CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) 158 164 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 159 165 END IF … … 163 169 & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) 164 170 ! 165 ! 166 IF( nn_timing == 1 ) CALL timing_stop('tra_nxt') 171 IF( nn_timing == 1 ) CALL timing_stop('tra_nxt') 167 172 ! 168 173 END SUBROUTINE tra_nxt -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r4924 r4946 21 21 USE sbc_oce ! surface boundary condition: ocean 22 22 USE trc_oce ! share SMS/Ocean variables 23 USE trd mod_oce ! ocean variables trends24 USE trdtra ! ocean active tracers trends23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 25 USE in_out_manager ! I/O manager 26 26 USE phycst ! physical constants … … 169 169 DO ji = 1, jpi 170 170 IF ( qsr(ji,jj) /= 0._wp ) THEN 171 oatte(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 172 iatte(ji,jj) = oatte(ji,jj) 171 fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 173 172 ENDIF 174 173 END DO … … 241 240 zzc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 242 241 zzc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 243 oatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2) 244 iatte(ji,jj) = 1.0 - ( zzc0 + zzc1 + zcoef + zcoef ) * tmask(ji,jj,2) 242 fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2) 245 243 END DO 246 244 END DO … … 259 257 ! clem: store attenuation coefficient of the first ocean level 260 258 IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 261 oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 262 iatte(:,:) = oatte(:,:) 259 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 263 260 ENDIF 264 261 ENDIF … … 287 284 zc0 = zz0 * EXP( -fsdepw(ji,jj,1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,1)*xsi1r ) 288 285 zc1 = zz0 * EXP( -fsdepw(ji,jj,2)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,2)*xsi1r ) 289 oatte(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 290 iatte(ji,jj) = oatte(ji,jj) 286 fraqsr_1lev(ji,jj) = ( zc0*tmask(ji,jj,1) - zc1*tmask(ji,jj,2) ) / r1_rau0_rcp 291 287 END DO 292 288 END DO … … 303 299 ! clem: store attenuation coefficient of the first ocean level 304 300 IF ( lk_lim3 .AND. ln_qsr_ice ) THEN 305 oatte(:,:) = etot3(:,:,1) / r1_rau0_rcp 306 iatte(:,:) = oatte(:,:) 301 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 307 302 ENDIF 308 303 ! … … 335 330 IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics 336 331 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 337 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_qsr, ztrdt )332 CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 338 333 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt ) 339 334 ENDIF … … 385 380 IF( nn_timing == 1 ) CALL timing_start('tra_qsr_init') 386 381 ! 387 ! clem init for oatte and iatte382 ! Default value for fraqsr_1lev 388 383 IF( .NOT. ln_rstart ) THEN 389 oatte(:,:) = 1._wp 390 iatte(:,:) = 1._wp 384 fraqsr_1lev(:,:) = 1._wp 391 385 ENDIF 392 386 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r4726 r4946 18 18 USE dom_oce ! ocean space domain variables 19 19 USE phycst ! physical constant 20 USE sbcmod ! ln_rnf 21 USE sbcrnf ! River runoff 20 22 USE traqsr ! solar radiation penetration 21 USE trdmod_oce ! ocean trends 22 USE trdtra ! ocean trends 23 USE trd_oce ! trends: ocean variables 24 USE trdtra ! trends manager: tracers 25 ! 23 26 USE in_out_manager ! I/O manager 24 27 USE prtctl ! Print control … … 41 44 # include "vectopt_loop_substitute.h90" 42 45 !!---------------------------------------------------------------------- 43 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)46 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 44 47 !! $Id$ 45 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 93 96 !! where emp, the surface freshwater budget (evaporation minus 94 97 !! precipitation minus runoff) given in kg/m2/s is divided 95 !! by rau0 = 1020 kg/m3(density of sea water) to obtain m/s.98 !! by rau0 (density of sea water) to obtain m/s. 96 99 !! Note: even though Fwe does not appear explicitly for 97 100 !! temperature in this routine, the heat carried by the water … … 109 112 !! ** Action : - Update the 1st level of (ta,sa) with the trend associated 110 113 !! with the tracer surface boundary condition 111 !! - s ave the trend it in ttrd ('key_trdtra')114 !! - send trends to trdtra module (l_trdtra=T) 112 115 !!---------------------------------------------------------------------- 113 116 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 130 133 ENDIF 131 134 132 IF( l_trdtra ) 135 IF( l_trdtra ) THEN !* Save ta and sa trends 133 136 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 134 137 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) … … 143 146 144 147 !---------------------------------------- 145 ! EMP, EMPSand QNS effects148 ! EMP, SFX and QNS effects 146 149 !---------------------------------------- 147 150 ! Set before sbc tracer content fields … … 152 155 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 153 156 IF(lwp) WRITE(numout,*) ' nit000-1 surface tracer content forcing fields red in the restart file' 154 zfact = 0.5 e0157 zfact = 0.5_wp 155 158 CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend 156 159 CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 157 160 ELSE ! No restart or restart not found: Euler forward time stepping 158 zfact = 1. e0159 sbc_tsc_b(:,:,:) = 0. e0161 zfact = 1._wp 162 sbc_tsc_b(:,:,:) = 0._wp 160 163 ENDIF 161 164 ELSE ! Swap of forcing fields 162 165 ! ! ---------------------- 163 zfact = 0.5 e0166 zfact = 0.5_wp 164 167 sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 165 168 ENDIF … … 217 220 !---------------------------------------- 218 221 ! 219 IF (nn_isf .GT. 0) THEN222 IF( nn_isf > 0 ) THEN 220 223 zfact = 0.5e0 221 224 DO jj = 2, jpj … … 231 234 ! compute tfreez for the temperature correction (we add water at freezing temperature) 232 235 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 233 zt_frz = -1.9 ! tfreez1D( tsn(ji,jj,jk,jp_sal), zpress )236 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 234 237 ! compute trend 235 238 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & … … 244 247 ! compute tfreez for the temperature correction (we add water at freezing temperature) 245 248 ! zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 246 zt_frz = -1.9 ! tfreez1D( tsn(ji,jj,ikb,jp_sal), zpress )249 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 247 250 ! compute trend 248 251 tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem) & … … 286 289 ENDIF 287 290 288 IF( l_trdtra ) THEN ! s ave the horizontal diffusivetrends for further diagnostics291 IF( l_trdtra ) THEN ! send trends for further diagnostics 289 292 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 290 293 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 291 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_nsr, ztrdt )292 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_nsr, ztrds )294 CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 295 CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 293 296 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 294 297 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90
r3294 r4946 19 19 USE sbc_oce ! surface boundary condition: ocean 20 20 USE dynspg_oce 21 22 21 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 23 22 USE trazdf_imp ! vertical diffusion: implicit (tra_zdf_imp routine) 24 25 23 USE ldftra_oce ! ocean active tracers: lateral physics 26 USE trdmod_oce ! ocean active tracers: lateral physics 27 USE trdtra ! ocean tracers trends 24 USE trd_oce ! trends: ocean variables 25 USE trdtra ! trends manager: tracers 26 ! 28 27 USE in_out_manager ! I/O manager 29 28 USE prtctl ! Print control … … 32 31 USE wrk_nemo ! Memory allocation 33 32 USE timing ! Timing 34 35 33 36 34 IMPLICIT NONE … … 47 45 # include "vectopt_loop_substitute.h90" 48 46 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)47 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 50 48 !! $Id$ 51 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 96 94 ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 97 95 END DO 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 99 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 96 CALL lbc_lnk( ztrdt, 'T', 1. ) 97 CALL lbc_lnk( ztrds, 'T', 1. ) 98 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 99 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 100 100 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 101 101 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90
r4812 r4946 75 75 !! Idem for di(s) and dj(s) 76 76 !! 77 !! For rho, we call eos _insitu_2d which will compute rd~(t~,s~) at78 !! the good depth zh from interpolated T and S for the different79 !! formulationof the equation of state (eos).77 !! For rho, we call eos which will compute rd~(t~,s~) at the right 78 !! depth zh from interpolated T and S for the different formulations 79 !! of the equation of state (eos). 80 80 !! Gradient formulation for rho : 81 !! di(rho) = rd~ - rd(i,j,k) orrd(i+1,j,k) - rd~81 !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ 82 82 !! 83 83 !! ** Action : compute for top and bottom interfaces … … 88 88 !! - pge3ru, pge3rv, sge3ru, sge3rv: horizontal gradient of rho weighted by local e3w at u- & v-points 89 89 !!---------------------------------------------------------------------- 90 !91 90 INTEGER , INTENT(in ) :: kt ! ocean time-step index 92 91 INTEGER , INTENT(in ) :: kjpt ! number of tracers … … 107 106 INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points 108 107 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv, zdzwu, zdzwv, zdzwuip1, zdzwvjp1 ! temporary scalars 109 REAL(wp), POINTER, DIMENSION(:,: ) :: zri, zrj, zhi, zhj110 REAL(wp), POINTER, DIMENSION(:,:,:) :: zti, ztj ! interpolated value of tracer108 REAL(wp), DIMENSION(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 109 REAL(wp), DIMENSION(jpi,jpj,kjpt) :: zti, ztj ! 111 110 !!---------------------------------------------------------------------- 112 111 ! 113 112 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde') 114 113 ! 115 CALL wrk_alloc( jpi, jpj, zri, zrj, zhi, zhj )116 CALL wrk_alloc( jpi, jpj, kjpt, zti, ztj )117 !118 114 pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 119 115 ! 120 116 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 121 117 ! 122 # if defined key_vectopt_loop 123 jj = 1 124 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 125 # else 126 DO jj = 1, jpjm1 127 DO ji = 1, jpim1 128 # endif 118 DO jj = 1, jpjm1 119 DO ji = 1, jpim1 129 120 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 130 121 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 … … 138 129 ! i- direction 139 130 IF (iku .GT. 1) THEN 140 IF( ze3wu >= 0._wp ) THEN ! case 1141 zmaxu = ze3wu / fse3w(ji+1,jj,iku)142 ! interpolated values of tracers143 zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )144 ! gradient of tracers145 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )146 ELSE ! case 2147 zmaxu = -ze3wu / fse3w(ji,jj,iku)148 ! interpolated values of tracers149 zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )150 ! gradient of tracers151 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )152 ENDIF131 IF( ze3wu >= 0._wp ) THEN ! case 1 132 zmaxu = ze3wu / fse3w(ji+1,jj,iku) 133 ! interpolated values of tracers 134 zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 135 ! gradient of tracers 136 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 137 ELSE ! case 2 138 zmaxu = -ze3wu / fse3w(ji,jj,iku) 139 ! interpolated values of tracers 140 zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 141 ! gradient of tracers 142 pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 143 ENDIF 153 144 ENDIF 154 145 ! 155 146 ! j- direction 156 147 IF (ikv .GT. 1) THEN 157 IF( ze3wv >= 0._wp ) THEN ! case 1 158 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 159 ! interpolated values of tracers 160 ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 161 ! gradient of tracers 162 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 163 ELSE ! case 2 164 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 165 ! interpolated values of tracers 166 ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 167 ! gradient of tracers 168 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 169 ENDIF 170 ENDIF 171 # if ! defined key_vectopt_loop 172 END DO 173 # endif 148 IF( ze3wv >= 0._wp ) THEN ! case 1 149 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 150 ! interpolated values of tracers 151 ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 152 ! gradient of tracers 153 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 154 ELSE ! case 2 155 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 156 ! interpolated values of tracers 157 ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 158 ! gradient of tracers 159 pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 160 ENDIF 161 ENDIF 162 END DO 174 163 END DO 175 164 CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond. … … 180 169 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 181 170 pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp 182 # if defined key_vectopt_loop 183 jj = 1 184 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 185 # else 186 DO jj = 1, jpjm1 187 DO ji = 1, jpim1 188 # endif 171 DO jj = 1, jpjm1 172 DO ji = 1, jpim1 189 173 iku = mbku(ji,jj) 190 174 ikv = mbkv(ji,jj) … … 198 182 ELSE ; zhj(ji,jj) = fsdept(ji,jj ,ikv) + ze3wv ! - - case 2 199 183 ENDIF 200 # if ! defined key_vectopt_loop 201 END DO 202 # endif 184 END DO 203 185 END DO 204 186 … … 209 191 210 192 ! Gradient of density at the last level 211 # if defined key_vectopt_loop 212 jj = 1 213 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 214 # else 215 DO jj = 1, jpjm1 216 DO ji = 1, jpim1 217 # endif 193 DO jj = 1, jpjm1 194 DO ji = 1, jpim1 218 195 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 219 196 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! last and before last ocean level at u- & v-points … … 250 227 -(fse3w(ji,jj ,ikv) + ze3wv) * ( zrj(ji,jj ) + prd(ji,jj ,ikvm1) + 2._wp) ) ! j: 2 251 228 ENDIF 252 # if ! defined key_vectopt_loop 253 END DO 254 # endif 229 END DO 255 230 END DO 256 231 CALL lbc_lnk( pgru , 'U', -1. ) ; CALL lbc_lnk( pgrv , 'V', -1. ) ! Lateral boundary conditions … … 262 237 ! (ISH) compute grui and gruvi 263 238 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! 264 # if defined key_vectopt_loop 265 jj = 1 266 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 267 # else 268 DO jj = 1, jpjm1 269 DO ji = 1, jpim1 270 # endif 239 DO jj = 1, jpjm1 240 DO ji = 1, jpim1 271 241 iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 272 242 ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 … … 307 277 sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 308 278 ENDIF 309 # if ! defined key_vectopt_loop 310 END DO 311 # endif 279 END DO!! 312 280 END DO!! 313 281 CALL lbc_lnk( sgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( sgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond. … … 317 285 ! horizontal derivative of density anomalies (rd) 318 286 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 319 # if defined key_vectopt_loop 320 jj = 1 321 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 322 # else 323 DO jj = 1, jpjm1 324 DO ji = 1, jpim1 325 # endif 287 DO jj = 1, jpjm1 288 DO ji = 1, jpim1 326 289 iku = miku(ji,jj) 327 290 ikv = mikv(ji,jj) … … 335 298 ELSE ; zhj(ji,jj) = fsdept(ji,jj ,ikv) - ze3wv ! - - case 2 336 299 ENDIF 337 # if ! defined key_vectopt_loop 338 END DO 339 # endif 300 END DO 340 301 END DO 341 302 … … 346 307 347 308 ! Gradient of density at the last level 348 # if defined key_vectopt_loop 349 jj = 1 350 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 351 # else 352 DO jj = 1, jpjm1 353 DO ji = 1, jpim1 354 # endif 309 DO jj = 1, jpjm1 310 DO ji = 1, jpim1 355 311 iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 356 312 ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 … … 388 344 -(fse3w(ji,jj ,ikv+1) + ze3wv) * ( zrj(ji,jj ) + prd(ji,jj ,ikv+1) + 2._wp) ) ! j: 2 389 345 ENDIF 390 # if ! defined key_vectopt_loop 391 END DO 392 # endif 346 END DO 393 347 END DO 394 348 CALL lbc_lnk( sgru , 'U', -1. ) ; CALL lbc_lnk( sgrv , 'V', -1. ) ! Lateral boundary conditions … … 399 353 END IF 400 354 ! 401 CALL wrk_dealloc( jpi, jpj, zri, zrj, zhi, zhj)402 CALL wrk_dealloc( jpi, jpj, kjpt, zti, ztj )403 !404 355 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde') 405 356 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r3632 r4946 2 2 !!====================================================================== 3 3 !! *** MODULE trdtra *** 4 !! Ocean diagnostics: ocean tracers trends 4 !! Ocean diagnostics: ocean tracers trends pre-processing 5 5 !!===================================================================== 6 !! History : 1.0 ! 2004-08 (C. Talandier) Original code 7 !! 2.0 ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget 8 !! 3.3 ! 2010-06 (C. Ethe) merge TRA-TRC 9 !!---------------------------------------------------------------------- 10 #if defined key_trdtra || defined key_trdtrc || defined key_trdmld || defined key_trdmld_trc 11 !!---------------------------------------------------------------------- 12 !! trd_tra : Call the trend to be computed 13 !!---------------------------------------------------------------------- 14 USE dom_oce ! ocean domain 15 USE trdmod_oce ! ocean active mixed layer tracers trends 16 USE trdmod ! ocean active mixed layer tracers trends 17 USE trdmod_trc ! ocean passive mixed layer tracers trends 18 USE in_out_manager ! I/O manager 19 USE lib_mpp ! MPP library 20 USE wrk_nemo ! Memory allocation 21 6 !! History : 3.3 ! 2010-06 (C. Ethe) creation for the TRA/TRC merge 7 !! 3.5 ! 2012-02 (G. Madec) update the comments 8 !!---------------------------------------------------------------------- 9 10 !!---------------------------------------------------------------------- 11 !! trd_tra : pre-process the tracer trends 12 !! trd_tra_adv : transform a div(U.T) trend into a U.grad(T) trend 13 !! trd_tra_mng : tracer trend manager: dispatch to the diagnostic modules 14 !! trd_tra_iom : output 3D tracer trends using IOM 15 !!---------------------------------------------------------------------- 16 USE oce ! ocean dynamics and tracers variables 17 USE dom_oce ! ocean domain 18 USE sbc_oce ! surface boundary condition: ocean 19 USE zdf_oce ! ocean vertical physics 20 USE trd_oce ! trends: ocean variables 21 USE trdtrc ! ocean passive mixed layer tracers trends 22 USE trdglo ! trends: global domain averaged 23 USE trdpen ! trends: Potential ENergy 24 USE trdmxl ! ocean active mixed layer tracers trends 25 USE ldftra_oce ! ocean active tracers lateral physics 26 USE zdfddm ! vertical physics: double diffusion 27 USE phycst ! physical constants 28 USE in_out_manager ! I/O manager 29 USE iom ! I/O manager library 30 USE lib_mpp ! MPP library 31 USE wrk_nemo ! Memory allocation 22 32 23 33 IMPLICIT NONE 24 34 PRIVATE 25 35 26 PUBLIC trd_tra ! called by all traXX modules 27 28 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt !: 36 PUBLIC trd_tra ! called by all tra_... modules 37 38 REAL(wp) :: r2dt ! time-step, = 2 rdttra except at nit000 (=rdttra) if neuler=0 39 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends 29 41 30 42 !! * Substitutions 31 43 # include "domzgr_substitute.h90" 44 # include "zdfddm_substitute.h90" 32 45 # include "vectopt_loop_substitute.h90" 33 46 !!---------------------------------------------------------------------- 34 !! NEMO/OPA 4.0 , NEMO Consortium (2011)47 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 35 48 !! $Id$ 36 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 39 52 40 53 INTEGER FUNCTION trd_tra_alloc() 41 !!--------------------------------------------------------------------- -------54 !!--------------------------------------------------------------------- 42 55 !! *** FUNCTION trd_tra_alloc *** 43 !!--------------------------------------------------------------------- -------56 !!--------------------------------------------------------------------- 44 57 ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , STAT= trd_tra_alloc ) 45 58 ! … … 53 66 !! *** ROUTINE trd_tra *** 54 67 !! 55 !! ** Purpose : Dispatch all trends computation, e.g. vorticity, mld or 56 !! integral constraints 68 !! ** Purpose : pre-process tracer trends 57 69 !! 58 !! ** Method /usage : For the mixed-layer trend, the control surface can be either59 !! a mixed layer depth (time varying) or a fixed surface (jk level or bowl).60 !! Choose control surface with nn_ctls in namelist NAMTRD :61 !! nn_ctls = 0 : use mixed layer with density criterion62 !! nn_ctls = 1 : read index from file 'ctlsurf_idx'63 !! nn_ctls > 1 : use fixed level surface jk = nn_ctls64 !!---------------------------------------------------------------------- 65 !66 INTEGER , INTENT(in) :: kt ! time step67 CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC'68 INTEGER , INTENT(in) :: ktra ! tracerindex69 INTEGER , INTENT(in) :: ktrd ! tracer trend index70 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux71 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pun ! velocity72 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! Tracer variablea73 !74 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrds75 !!---------------------------------------------------------------------- 76 70 !! ** Method : - mask the trend 71 !! - advection (ptra present) converte the incoming flux (U.T) 72 !! into trend (U.T => -U.grat(T)=div(U.T)-T.div(U)) through a 73 !! call to trd_tra_adv 74 !! - 'TRA' case : regroup T & S trends 75 !! - send the trends to trd_tra_mng (trdtrc) for further processing 76 !!---------------------------------------------------------------------- 77 INTEGER , INTENT(in) :: kt ! time step 78 CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC' 79 INTEGER , INTENT(in) :: ktra ! tracer index 80 INTEGER , INTENT(in) :: ktrd ! tracer trend index 81 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux 82 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pun ! now velocity 83 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable 84 ! 85 INTEGER :: jk ! loop indices 86 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwt, zws, ztrdt, ztrds ! 3D workspace 87 !!---------------------------------------------------------------------- 88 ! 77 89 CALL wrk_alloc( jpi, jpj, jpk, ztrds ) 78 79 IF( .NOT. ALLOCATED( trdtx ) ) THEN 90 ! 91 IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays 80 92 IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) 81 93 ENDIF 82 83 ! Control of optional arguments 84 IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN 85 IF( PRESENT( ptra ) ) THEN 86 SELECT CASE( ktrd ) ! shift depending on the direction 87 CASE( jptra_trd_xad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'X', trdtx ) 88 CASE( jptra_trd_yad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Y', trdty ) 89 CASE( jptra_trd_zad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Z', trdt ) 90 END SELECT 91 ELSE 92 trdt(:,:,:) = ptrd(:,:,:) 93 IF( ktrd == jptra_trd_bbc .OR. ktrd == jptra_trd_qsr ) THEN 94 ztrds(:,:,:) = 0. 95 CALL trd_mod( trdt, ztrds, ktrd, ctype, kt ) 96 END IF 97 END IF 98 END IF 99 100 IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN 101 IF( PRESENT( ptra ) ) THEN 102 SELECT CASE( ktrd ) ! shift depending on the direction 103 CASE( jptra_trd_xad ) 104 CALL trd_tra_adv( ptrd, pun, ptra, 'X', ztrds ) 105 CALL trd_mod( trdtx, ztrds, ktrd, ctype, kt ) 106 CASE( jptra_trd_yad ) 107 CALL trd_tra_adv( ptrd, pun, ptra, 'Y', ztrds ) 108 CALL trd_mod( trdty, ztrds, ktrd, ctype, kt ) 109 CASE( jptra_trd_zad ) 110 CALL trd_tra_adv( ptrd, pun, ptra, 'Z', ztrds ) 111 CALL trd_mod( trdt , ztrds, ktrd, ctype, kt ) 112 END SELECT 113 ELSE 114 ztrds(:,:,:) = ptrd(:,:,:) 115 CALL trd_mod( trdt, ztrds, ktrd, ctype, kt ) 116 END IF 117 END IF 118 119 IF( ctype == 'TRC' ) THEN 120 ! 121 IF( PRESENT( ptra ) ) THEN 122 SELECT CASE( ktrd ) ! shift depending on the direction 123 CASE( jptra_trd_xad ) 124 CALL trd_tra_adv( ptrd, pun, ptra, 'X', ztrds ) 125 CALL trd_mod_trc( ztrds, ktra, ktrd, kt ) 126 CASE( jptra_trd_yad ) 127 CALL trd_tra_adv( ptrd, pun, ptra, 'Y', ztrds ) 128 CALL trd_mod_trc( ztrds, ktra, ktrd, kt ) 129 CASE( jptra_trd_zad ) 130 CALL trd_tra_adv( ptrd, pun, ptra, 'Z', ztrds ) 131 CALL trd_mod_trc( ztrds, ktra, ktrd, kt ) 132 END SELECT 133 ELSE 134 ztrds(:,:,:) = ptrd(:,:,:) 135 CALL trd_mod_trc( ztrds, ktra, ktrd, kt ) 136 END IF 94 95 IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN !== Temperature trend ==! 96 ! 97 SELECT CASE( ktrd ) 98 ! ! advection: transform the advective flux into a trend 99 CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'X', trdtx ) 100 CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Y', trdty ) 101 CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Z', trdt ) 102 CASE( jptra_bbc, & ! qsr, bbc: on temperature only, send to trd_tra_mng 103 & jptra_qsr ) ; trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 104 ztrds(:,:,:) = 0._wp 105 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 106 CASE DEFAULT ! other trends: masked trends 107 trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store 108 END SELECT 109 ! 110 ENDIF 111 112 IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN !== Salinity trends ==! 113 ! 114 SELECT CASE( ktrd ) 115 ! ! advection: transform the advective flux into a trend 116 ! ! and send T & S trends to trd_tra_mng 117 CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'X' , ztrds ) 118 CALL trd_tra_mng( trdtx, ztrds, ktrd, kt ) 119 CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Y' , ztrds ) 120 CALL trd_tra_mng( trdty, ztrds, ktrd, kt ) 121 CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Z' , ztrds ) 122 CALL trd_tra_mng( trdt , ztrds, ktrd, kt ) 123 CASE( jptra_zdfp ) ! diagnose the "PURE" Kz trend (here: just before the swap) 124 ! ! iso-neutral diffusion case otherwise jptra_zdf is "PURE" 125 CALL wrk_alloc( jpi, jpj, jpk, zwt, zws, ztrdt ) 126 ! 127 zwt(:,:, 1 ) = 0._wp ; zws(:,:, 1 ) = 0._wp ! vertical diffusive fluxes 128 zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp 129 DO jk = 2, jpk 130 zwt(:,:,jk) = avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 131 zws(:,:,jk) = fsavs(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 132 END DO 133 ! 134 ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp 135 DO jk = 1, jpkm1 136 ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / fse3t(:,:,jk) 137 ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / fse3t(:,:,jk) 138 END DO 139 CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt ) 140 ! 141 CALL wrk_dealloc( jpi, jpj, jpk, zwt, zws, ztrdt ) 142 ! 143 CASE DEFAULT ! other trends: mask and send T & S trends to trd_tra_mng 144 ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 145 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 146 END SELECT 147 ENDIF 148 149 IF( ctype == 'TRC' ) THEN !== passive tracer trend ==! 150 ! 151 SELECT CASE( ktrd ) 152 ! ! advection: transform the advective flux into a masked trend 153 CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'X', ztrds ) 154 CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Y', ztrds ) 155 CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Z', ztrds ) 156 CASE DEFAULT ! other trends: just masked 157 ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 158 END SELECT 159 ! ! send trend to trd_trc 160 CALL trd_trc( ztrds, ktra, ktrd, kt ) 137 161 ! 138 162 ENDIF … … 147 171 !! *** ROUTINE trd_tra_adv *** 148 172 !! 149 !! ** Purpose : transformed the i-, j- or k-advective flux into thes 150 !! i-, j- or k-advective trends, resp. 151 !! ** Method : i-advective trends = -un. di-1[T] = -( di-1[fi] - tn di-1[un] ) 152 !! k-advective trends = -un. di-1[T] = -( dj-1[fi] - tn dj-1[un] ) 153 !! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) 154 !!---------------------------------------------------------------------- 155 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pf ! advective flux in one direction 156 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun ! now velocity in one direction 157 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: ptn ! now or before tracer 158 CHARACTER(len=1), INTENT(in ) :: cdir ! X/Y/Z direction 159 REAL(wp) , INTENT(out), DIMENSION(jpi,jpj,jpk) :: ptrd ! advective trend in one direction 173 !! ** Purpose : transformed a advective flux into a masked advective trends 174 !! 175 !! ** Method : use the following transformation: -div(U.T) = - U grad(T) + T.div(U) 176 !! i-advective trends = -un. di-1[T] = -( di-1[fi] - tn di-1[un] ) 177 !! j-advective trends = -un. di-1[T] = -( dj-1[fi] - tn dj-1[un] ) 178 !! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) 179 !! where fi is the incoming advective flux. 180 !!---------------------------------------------------------------------- 181 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction 182 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pun ! now velocity in one direction 183 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: ptn ! now or before tracer 184 CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction 185 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction 160 186 ! 161 187 INTEGER :: ji, jj, jk ! dummy loop indices 162 INTEGER :: ii, ij, ik ! index shift function of the direction 163 REAL(wp) :: zbtr ! local scalar 164 !!---------------------------------------------------------------------- 165 166 SELECT CASE( cdir ) ! shift depending on the direction 167 CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-advective trend 168 CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-advective trend 169 CASE( 'Z' ) ; ii = 0 ; ij = 0 ; ik =-1 ! k-advective trend 188 INTEGER :: ii, ij, ik ! index shift as function of the direction 189 !!---------------------------------------------------------------------- 190 ! 191 SELECT CASE( cdir ) ! shift depending on the direction 192 CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend 193 CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend 194 CASE( 'Z' ) ; ii = 0 ; ij = 0 ; ik =-1 ! k-trend 170 195 END SELECT 171 172 ! ! set to zero uncomputed values 173 ptrd(jpi,:,:) = 0.e0 ; ptrd(1,:,:) = 0.e0 174 ptrd(:,jpj,:) = 0.e0 ; ptrd(:,1,:) = 0.e0 175 ptrd(:,:,jpk) = 0.e0 176 ! 177 ! 178 DO jk = 1, jpkm1 196 ! 197 ! ! set to zero uncomputed values 198 ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp 199 ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp 200 ptrd(:,:,jpk) = 0._wp 201 ! 202 DO jk = 1, jpkm1 ! advective trend 179 203 DO jj = 2, jpjm1 180 204 DO ji = fs_2, fs_jpim1 ! vector opt. 181 zbtr = 1.e0/ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )182 ptrd(ji,jj,jk) = - zbtr * ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik)&183 & - ( pun(ji,jj,jk) - pun(ji-ii,jj-ij,jk-ik) ) * ptn(ji,jj,jk))205 ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & 206 & - ( pun(ji,jj,jk) - pun(ji-ii,jj-ij,jk-ik) ) * ptn(ji,jj,jk) ) & 207 & / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) * tmask(ji,jj,jk) 184 208 END DO 185 209 END DO … … 188 212 END SUBROUTINE trd_tra_adv 189 213 190 # else 191 !!---------------------------------------------------------------------- 192 !! Default case : Dummy module No trend diagnostics 193 !!---------------------------------------------------------------------- 194 USE par_oce ! ocean variables trends 195 CONTAINS 196 SUBROUTINE trd_tra( kt, ctype, ktra, ktrd, ptrd, pu, ptra ) 197 !!---------------------------------------------------------------------- 198 INTEGER , INTENT(in) :: kt ! time step 199 CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC' 200 INTEGER , INTENT(in) :: ktra ! tracer index 201 INTEGER , INTENT(in) :: ktrd ! tracer trend index 202 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend 203 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! velocity 204 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! Tracer variable 205 WRITE(*,*) 'trd_3d: You should not have seen this print! error ?', ptrd(1,1,1), ptra(1,1,1), pu(1,1,1), & 206 & ktrd, ktra, ctype, kt 207 END SUBROUTINE trd_tra 208 # endif 214 215 SUBROUTINE trd_tra_mng( ptrdx, ptrdy, ktrd, kt ) 216 !!--------------------------------------------------------------------- 217 !! *** ROUTINE trd_tra_mng *** 218 !! 219 !! ** Purpose : Dispatch all tracer trends computation, e.g. 3D output, 220 !! integral constraints, potential energy, and/or 221 !! mixed layer budget. 222 !!---------------------------------------------------------------------- 223 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend 224 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend 225 INTEGER , INTENT(in ) :: ktrd ! tracer trend index 226 INTEGER , INTENT(in ) :: kt ! time step 227 !!---------------------------------------------------------------------- 228 229 IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! = rdtra (restart with Euler time stepping) 230 ELSEIF( kt <= nit000 + 1) THEN ; r2dt = 2. * rdt ! = 2 rdttra (leapfrog) 231 ENDIF 232 233 ! ! 3D output of tracers trends using IOM interface 234 IF( ln_tra_trd ) CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt ) 235 236 ! ! Integral Constraints Properties for tracers trends !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 237 IF( ln_glo_trd ) CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt ) 238 239 ! ! Potential ENergy trends 240 IF( ln_PE_trd ) CALL trd_pen( ptrdx, ptrdy, ktrd, kt, r2dt ) 241 242 ! ! Mixed layer trends for active tracers 243 IF( ln_tra_mxl ) THEN 244 !----------------------------------------------------------------------------------------------- 245 ! W.A.R.N.I.N.G : 246 ! jptra_ldf : called by traldf.F90 247 ! at this stage we store: 248 ! - the lateral geopotential diffusion (here, lateral = horizontal) 249 ! - and the iso-neutral diffusion if activated 250 ! jptra_zdf : called by trazdf.F90 251 ! * in case of iso-neutral diffusion we store the vertical diffusion component in the 252 ! lateral trend including the K_z contrib, which will be removed later (see trd_mxl) 253 !----------------------------------------------------------------------------------------------- 254 255 SELECT CASE ( ktrd ) 256 CASE ( jptra_xad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_xad, '3D' ) ! zonal advection 257 CASE ( jptra_yad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_yad, '3D' ) ! merid. advection 258 CASE ( jptra_zad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zad, '3D' ) ! vertical advection 259 CASE ( jptra_ldf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion 260 CASE ( jptra_bbl ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbl, '3D' ) ! bottom boundary layer 261 CASE ( jptra_zdf ) 262 IF( ln_traldf_iso ) THEN ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion (K_z) 263 ELSE ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zdf, '3D' ) ! vertical diffusion (K_z) 264 ENDIF 265 CASE ( jptra_dmp ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_dmp, '3D' ) ! internal 3D restoring (tradmp) 266 CASE ( jptra_qsr ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '3D' ) ! air-sea : penetrative sol radiat 267 CASE ( jptra_nsr ) ; ptrdx(:,:,2:jpk) = 0._wp ; ptrdy(:,:,2:jpk) = 0._wp 268 CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '2D' ) ! air-sea : non penetr sol radiation 269 CASE ( jptra_bbc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbc, '3D' ) ! bottom bound cond (geoth flux) 270 CASE ( jptra_npc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_npc, '3D' ) ! non penetr convect adjustment 271 CASE ( jptra_atf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_atf, '3D' ) ! asselin time filter (last trend) 272 ! 273 CALL trd_mxl( kt, r2dt ) ! trends: Mixed-layer (output) 274 END SELECT 275 ! 276 ENDIF 277 ! 278 END SUBROUTINE trd_tra_mng 279 280 281 SUBROUTINE trd_tra_iom( ptrdx, ptrdy, ktrd, kt ) 282 !!--------------------------------------------------------------------- 283 !! *** ROUTINE trd_tra_iom *** 284 !! 285 !! ** Purpose : output 3D tracer trends using IOM 286 !!---------------------------------------------------------------------- 287 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend 288 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend 289 INTEGER , INTENT(in ) :: ktrd ! tracer trend index 290 INTEGER , INTENT(in ) :: kt ! time step 291 !! 292 INTEGER :: ji, jj, jk ! dummy loop indices 293 INTEGER :: ikbu, ikbv ! local integers 294 REAL(wp), POINTER, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace 295 !!---------------------------------------------------------------------- 296 ! 297 !!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added 298 ! 299 SELECT CASE( ktrd ) 300 CASE( jptra_xad ) ; CALL iom_put( "ttrd_xad" , ptrdx ) ! x- horizontal advection 301 CALL iom_put( "strd_xad" , ptrdy ) 302 CASE( jptra_yad ) ; CALL iom_put( "ttrd_yad" , ptrdx ) ! y- horizontal advection 303 CALL iom_put( "strd_yad" , ptrdy ) 304 CASE( jptra_zad ) ; CALL iom_put( "ttrd_zad" , ptrdx ) ! z- vertical advection 305 CALL iom_put( "strd_zad" , ptrdy ) 306 IF( .NOT. lk_vvl ) THEN ! cst volume : adv flux through z=0 surface 307 CALL wrk_alloc( jpi, jpj, z2dx, z2dy ) 308 z2dx(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / fse3t(:,:,1) 309 z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / fse3t(:,:,1) 310 CALL iom_put( "ttrd_sad", z2dx ) 311 CALL iom_put( "strd_sad", z2dy ) 312 CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 313 ENDIF 314 CASE( jptra_ldf ) ; CALL iom_put( "ttrd_ldf" , ptrdx ) ! lateral diffusion 315 CALL iom_put( "strd_ldf" , ptrdy ) 316 CASE( jptra_zdf ) ; CALL iom_put( "ttrd_zdf" , ptrdx ) ! vertical diffusion (including Kz contribution) 317 CALL iom_put( "strd_zdf" , ptrdy ) 318 CASE( jptra_zdfp ) ; CALL iom_put( "ttrd_zdfp", ptrdx ) ! PURE vertical diffusion (no isoneutral contribution) 319 CALL iom_put( "strd_zdfp", ptrdy ) 320 CASE( jptra_dmp ) ; CALL iom_put( "ttrd_dmp" , ptrdx ) ! internal restoring (damping) 321 CALL iom_put( "strd_dmp" , ptrdy ) 322 CASE( jptra_bbl ) ; CALL iom_put( "ttrd_bbl" , ptrdx ) ! bottom boundary layer 323 CALL iom_put( "strd_bbl" , ptrdy ) 324 CASE( jptra_npc ) ; CALL iom_put( "ttrd_npc" , ptrdx ) ! static instability mixing 325 CALL iom_put( "strd_npc" , ptrdy ) 326 CASE( jptra_nsr ) ; CALL iom_put( "ttrd_qns" , ptrdx ) ! surface forcing + runoff (ln_rnf=T) 327 CALL iom_put( "strd_cdt" , ptrdy ) 328 CASE( jptra_qsr ) ; CALL iom_put( "ttrd_qsr" , ptrdx ) ! penetrative solar radiat. (only on temperature) 329 CASE( jptra_bbc ) ; CALL iom_put( "ttrd_bbc" , ptrdx ) ! geothermal heating (only on temperature) 330 CASE( jptra_atf ) ; CALL iom_put( "ttrd_atf" , ptrdx ) ! asselin time Filter 331 CALL iom_put( "strd_atf" , ptrdy ) 332 END SELECT 333 ! 334 END SUBROUTINE trd_tra_iom 335 209 336 !!====================================================================== 210 337 END MODULE trdtra -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRD/trdvor.F90
r3294 r4946 4 4 !! Ocean diagnostics: momentum trends 5 5 !!===================================================================== 6 !! History : 1.0 ! 04-2006 (L. Brunier, A-M. Treguier) Original code 7 !! 2.0 ! 04-2008 (C. Talandier) New trends organization 6 !! History : 1.0 ! 2006-01 (L. Brunier, A-M. Treguier) Original code 7 !! 2.0 ! 2008-04 (C. Talandier) New trends organization 8 !! 3.5 ! 2012-02 (G. Madec) regroup beta.V computation with pvo trend 8 9 !!---------------------------------------------------------------------- 9 #if defined key_trdvor || defined key_esopa 10 !!---------------------------------------------------------------------- 11 !! 'key_trdvor' : momentum trend diagnostics 10 12 11 !!---------------------------------------------------------------------- 13 12 !! trd_vor : momentum trends averaged over the depth … … 17 16 USE oce ! ocean dynamics and tracers variables 18 17 USE dom_oce ! ocean space and time domain variables 19 USE trd mod_oce ! ocean variables trends18 USE trd_oce ! trends: ocean variables 20 19 USE zdf_oce ! ocean vertical physics 21 USE in_out_manager ! I/O manager20 USE sbc_oce ! surface boundary condition: ocean 22 21 USE phycst ! Define parameters for the routines 23 22 USE ldfdyn_oce ! ocean active tracers: lateral physics 24 23 USE dianam ! build the name of file (routine) 25 24 USE zdfmxl ! mixed layer depth 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE in_out_manager ! I/O manager 26 27 USE ioipsl ! NetCDF library 27 USE lbclnk ! ocean lateral boundary conditions (or mpp link)28 28 USE lib_mpp ! MPP library 29 29 USE wrk_nemo ! Memory allocation 30 31 30 32 31 IMPLICIT NONE … … 37 36 END INTERFACE 38 37 39 PUBLIC trd_vor ! routine called by step.F90 40 PUBLIC trd_vor_zint ! routine called by dynamics routines 38 PUBLIC trd_vor ! routine called by trddyn.F90 41 39 PUBLIC trd_vor_init ! routine called by opa.F90 42 40 PUBLIC trd_vor_alloc ! routine called by nemogcm.F90 … … 80 78 IF( trd_vor_alloc /= 0 ) CALL ctl_warn('trd_vor_alloc: failed to allocate arrays') 81 79 END FUNCTION trd_vor_alloc 80 81 82 SUBROUTINE trd_vor( putrd, pvtrd, ktrd, kt ) 83 !!---------------------------------------------------------------------- 84 !! *** ROUTINE trd_vor *** 85 !! 86 !! ** Purpose : computation of cumulated trends over analysis period 87 !! and make outputs (NetCDF or DIMG format) 88 !!---------------------------------------------------------------------- 89 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends 90 INTEGER , INTENT(in ) :: ktrd ! trend index 91 INTEGER , INTENT(in ) :: kt ! time step 92 ! 93 INTEGER :: ji, jj ! dummy loop indices 94 REAL(wp), POINTER, DIMENSION(:,:) :: ztswu, ztswv ! 2D workspace 95 !!---------------------------------------------------------------------- 96 97 CALL wrk_alloc( jpi, jpj, ztswu, ztswv ) 98 99 SELECT CASE( ktrd ) 100 CASE( jpdyn_hpg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_prg ) ! Hydrostatique Pressure Gradient 101 CASE( jpdyn_keg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_keg ) ! KE Gradient 102 CASE( jpdyn_rvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_rvo ) ! Relative Vorticity 103 CASE( jpdyn_pvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_pvo ) ! Planetary Vorticity Term 104 CASE( jpdyn_ldf ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_ldf ) ! Horizontal Diffusion 105 CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad ) ! Vertical Advection 106 CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg ) ! Surface Pressure Grad. 107 CASE( jpdyn_zdf ) ! Vertical Diffusion 108 ztswu(:,:) = 0.e0 ; ztswv(:,:) = 0.e0 109 DO jj = 2, jpjm1 ! wind stress trends 110 DO ji = fs_2, fs_jpim1 ! vector opt. 111 ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( fse3u(ji,jj,1) * rau0 ) 112 ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( fse3v(ji,jj,1) * rau0 ) 113 END DO 114 END DO 115 ! 116 CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf ) ! zdf trend including surf./bot. stresses 117 CALL trd_vor_zint( ztswu, ztswv, jpvor_swf ) ! surface wind stress 118 CASE( jpdyn_bfr ) 119 CALL trd_vor_zint( putrd, pvtrd, jpvor_bfr ) ! Bottom stress 120 ! 121 CASE( jpdyn_atf ) ! last trends: perform the output of 2D vorticity trends 122 CALL trd_vor_iom( kt ) 123 END SELECT 124 ! 125 CALL wrk_dealloc( jpi, jpj, ztswu, ztswv ) 126 ! 127 END SUBROUTINE trd_vor 82 128 83 129 … … 109 155 !! trends output in netCDF format using ioipsl 110 156 !!---------------------------------------------------------------------- 111 !112 157 INTEGER , INTENT(in ) :: ktrd ! ocean trend index 113 158 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: putrdvor ! u vorticity trend … … 131 176 ! ===================================== 132 177 133 SELECT CASE (ktrd)134 ! 135 CASE (jpvor_bfr) ! bottom friction178 SELECT CASE( ktrd ) 179 ! 180 CASE( jpvor_bfr ) ! bottom friction 136 181 DO jj = 2, jpjm1 137 182 DO ji = fs_2, fs_jpim1 … … 143 188 END DO 144 189 ! 145 CASE (jpvor_swf) ! wind stress190 CASE( jpvor_swf ) ! wind stress 146 191 zudpvor(:,:) = putrdvor(:,:) * fse3u(:,:,1) * e1u(:,:) * umask(:,:,1) 147 192 zvdpvor(:,:) = pvtrdvor(:,:) * fse3v(:,:,1) * e2v(:,:) * vmask(:,:,1) … … 154 199 155 200 ! Curl 156 DO ji =1,jpim1157 DO jj =1,jpjm1201 DO ji = 1, jpim1 202 DO jj = 1, jpjm1 158 203 vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & 159 204 & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) … … 229 274 END DO 230 275 231 ! Save Beta.V term to avoid average before Curl232 ! Beta.V : intergration, noaverage233 IF( ktrd == jpvor_ bev) THEN276 ! Planetary vorticity: 2nd computation (Beta.V term) store the vertical sum 277 ! as Beta.V term need intergration, not average 278 IF( ktrd == jpvor_pvo ) THEN 234 279 zubet(:,:) = zudpvor(:,:) 235 280 zvbet(:,:) = zvdpvor(:,:) 236 ENDIF 237 238 ! Average except for Beta.V 281 DO ji = 1, jpim1 282 DO jj = 1, jpjm1 283 vortrd(ji,jj,jpvor_bev) = ( zvbet(ji+1,jj) - zvbet(ji,jj) & 284 & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 285 END DO 286 END DO 287 ! Average of the Curl and Surface mask 288 vortrd(:,:,jpvor_bev) = vortrd(:,:,jpvor_bev) * hur(:,:) * fmask(:,:,1) 289 ENDIF 290 ! 291 ! Average 239 292 zudpvor(:,:) = zudpvor(:,:) * hur(:,:) 240 293 zvdpvor(:,:) = zvdpvor(:,:) * hvr(:,:) 241 294 ! 242 295 ! Curl 243 296 DO ji=1,jpim1 … … 247 300 END DO 248 301 END DO 249 250 302 ! Surface mask 251 303 vortrd(:,:,ktrd) = vortrd(:,:,ktrd) * fmask(:,:,1) 252 253 ! Special treatement for the Beta.V term254 ! Compute the Curl of the Beta.V term which is not averaged255 IF( ktrd == jpvor_bev ) THEN256 DO ji=1,jpim1257 DO jj=1,jpjm1258 vortrd(ji,jj,jpvor_bev) = ( zvbet(ji+1,jj) - zvbet(ji,jj) &259 & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )260 END DO261 END DO262 263 ! Average on the Curl264 vortrd(:,:,jpvor_bev) = vortrd(:,:,jpvor_bev) * hur(:,:)265 266 ! Surface mask267 vortrd(:,:,jpvor_bev) = vortrd(:,:,jpvor_bev) * fmask(:,:,1)268 ENDIF269 304 270 305 IF( ndebug /= 0 ) THEN … … 278 313 279 314 280 SUBROUTINE trd_vor ( kt )315 SUBROUTINE trd_vor_iom( kt ) 281 316 !!---------------------------------------------------------------------- 282 317 !! *** ROUTINE trd_vor *** … … 285 320 !! and make outputs (NetCDF or DIMG format) 286 321 !!---------------------------------------------------------------------- 287 ! 288 INTEGER, INTENT(in) :: kt ! ocean time-step index 322 INTEGER , INTENT(in ) :: kt ! time step 289 323 ! 290 324 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 305 339 306 340 IF( kt > nit000 ) vor_avrb(:,:) = vor_avr(:,:) 307 308 IF( ndebug /= 0 ) THEN309 WRITE(numout,*) ' debuging trd_vor: I.1 done '310 CALL FLUSH(numout)311 ENDIF312 341 313 342 ! I.2 vertically integrated vorticity … … 330 359 331 360 ! Curl 332 DO ji =1,jpim1333 DO jj =1,jpjm1361 DO ji = 1, jpim1 362 DO jj = 1, jpjm1 334 363 vor_avr(ji,jj) = ( ( zvn(ji+1,jj) - zvn(ji,jj) ) & 335 364 & - ( zun(ji,jj+1) - zun(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) … … 337 366 END DO 338 367 339 IF( ndebug /= 0 ) THEN340 WRITE(numout,*) ' debuging trd_vor: I.2 done'341 CALL FLUSH(numout)342 ENDIF343 344 368 ! ================================= 345 369 ! II. Cumulated trends … … 351 375 vor_avrbb(:,:) = vor_avrb(:,:) 352 376 vor_avrbn(:,:) = vor_avr (:,:) 353 ENDIF354 355 IF( ndebug /= 0 ) THEN356 WRITE(numout,*) ' debuging trd_vor: I1.1 done'357 CALL FLUSH(numout)358 377 ENDIF 359 378 … … 371 390 ENDIF 372 391 373 IF( ndebug /= 0 ) THEN374 WRITE(numout,*) ' debuging trd_vor: II.2 done'375 CALL FLUSH(numout)376 ENDIF377 378 392 ! ============================================= 379 393 ! III. Output in netCDF + residual computation … … 391 405 vor_avrtot(:,:) = ( vor_avr(:,:) - vor_avrbn(:,:) + vor_avrb(:,:) - vor_avrbb(:,:) ) * zmean 392 406 393 IF( ndebug /= 0 ) THEN394 WRITE(numout,*) ' zmean = ',zmean395 WRITE(numout,*) ' debuging trd_vor: III.1 done'396 CALL FLUSH(numout)397 ENDIF398 407 399 408 ! III.2 compute residual … … 406 415 CALL lbc_lnk( vor_avrres, 'F', 1. ) 407 416 408 IF( ndebug /= 0 ) THEN409 WRITE(numout,*) ' debuging trd_vor: III.2 done'410 CALL FLUSH(numout)411 ENDIF412 417 413 418 ! III.3 time evolution array swap … … 415 420 vor_avrbb(:,:) = vor_avrb(:,:) 416 421 vor_avrbn(:,:) = vor_avr (:,:) 417 418 IF( ndebug /= 0 ) THEN419 WRITE(numout,*) ' debuging trd_vor: III.3 done'420 CALL FLUSH(numout)421 ENDIF422 422 ! 423 423 nmoydpvor = 0 … … 463 463 CALL wrk_dealloc( jpi, jpj, zun, zvn ) 464 464 ! 465 END SUBROUTINE trd_vor 465 END SUBROUTINE trd_vor_iom 466 466 467 467 … … 587 587 END SUBROUTINE trd_vor_init 588 588 589 #else590 !!----------------------------------------------------------------------591 !! Default option : Empty module592 !!----------------------------------------------------------------------593 INTERFACE trd_vor_zint594 MODULE PROCEDURE trd_vor_zint_2d, trd_vor_zint_3d595 END INTERFACE596 CONTAINS597 SUBROUTINE trd_vor( kt ) ! Empty routine598 WRITE(*,*) 'trd_vor: You should not have seen this print! error?', kt599 END SUBROUTINE trd_vor600 SUBROUTINE trd_vor_zint_2d( putrdvor, pvtrdvor, ktrd )601 REAL, DIMENSION(:,:), INTENT( inout ) :: putrdvor, pvtrdvor602 INTEGER, INTENT( in ) :: ktrd ! ocean trend index603 WRITE(*,*) 'trd_vor_zint_2d: You should not have seen this print! error?', putrdvor(1,1), pvtrdvor(1,1), ktrd604 END SUBROUTINE trd_vor_zint_2d605 SUBROUTINE trd_vor_zint_3d( putrdvor, pvtrdvor, ktrd )606 REAL, DIMENSION(:,:,:), INTENT( inout ) :: putrdvor, pvtrdvor607 INTEGER, INTENT( in ) :: ktrd ! ocean trend index608 WRITE(*,*) 'trd_vor_zint_3d: You should not have seen this print! error?', putrdvor(1,1,1), pvtrdvor(1,1,1), ktrd609 END SUBROUTINE trd_vor_zint_3d610 SUBROUTINE trd_vor_init ! Empty routine611 WRITE(*,*) 'trd_vor_init: You should not have seen this print! error?'612 END SUBROUTINE trd_vor_init613 #endif614 589 !!====================================================================== 615 590 END MODULE trdvor -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/TRD/trdvor_oce.F90
r2715 r4946 4 4 !! Ocean trends : set vorticity trend variables 5 5 !!====================================================================== 6 !! History : 9.0 ! 04-2006 (L. Brunier, A-M. Treguier) Original code6 !! History : 1.0 ! 04-2006 (L. Brunier, A-M. Treguier) Original code 7 7 !!---------------------------------------------------------------------- 8 9 !!---------------------------------------------------------------------- 8 10 9 USE par_oce ! ocean parameters 11 10 … … 13 12 PRIVATE 14 13 15 #if defined key_trdvor16 LOGICAL, PUBLIC, PARAMETER :: lk_trdvor = .TRUE. !: momentum trend flag17 #else18 LOGICAL, PUBLIC, PARAMETER :: lk_trdvor = .FALSE. !: momentum trend flag19 #endif20 14 ! !!* vorticity trends index 21 15 INTEGER, PUBLIC, PARAMETER :: jpltot_vor = 11 !: Number of vorticity trend terms -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90
r4924 r4946 113 113 IF ( ln_loglayer.AND.lk_vvl ) THEN ! "log layer" bottom friction coefficient 114 114 115 # if defined key_vectopt_loop116 DO jj = 1, 1117 !CDIR NOVERRCHK118 DO ji = 1, jpij ! vector opt. (forced unrolling)119 # else120 !CDIR NOVERRCHK121 115 DO jj = 1, jpj 122 !CDIR NOVERRCHK123 116 DO ji = 1, jpi 124 # endif125 117 ikbt = mbkt(ji,jj) 126 ! JC: possible WAD implementation should modify line below if layers vanish118 !! JC: possible WAD implementation should modify line below if layers vanish 127 119 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 128 120 zbfrt(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) … … 143 135 ENDIF 144 136 145 # if defined key_vectopt_loop146 DO jj = 1, 1147 !CDIR NOVERRCHK148 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)149 # else150 !CDIR NOVERRCHK151 137 DO jj = 2, jpjm1 152 !CDIR NOVERRCHK153 138 DO ji = 2, jpim1 154 # endif155 139 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 156 140 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) … … 206 190 END DO 207 191 END DO 208 209 192 ! 210 193 CALL lbc_lnk( bfrua, 'U', 1. ) ; CALL lbc_lnk( bfrva, 'V', 1. ) ! Lateral boundary condition … … 342 325 ! 343 326 IF ( ln_loglayer.AND.(.NOT.lk_vvl) ) THEN ! set "log layer" bottom friction once for all 344 # if defined key_vectopt_loop345 DO jj = 1, 1346 !CDIR NOVERRCHK347 DO ji = 1, jpij ! vector opt. (forced unrolling)348 # else349 !CDIR NOVERRCHK350 327 DO jj = 1, jpj 351 !CDIR NOVERRCHK352 328 DO ji = 1, jpi 353 # endif354 329 ikbt = mbkt(ji,jj) 355 330 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp … … 388 363 zmaxtfr = -1.e10_wp ! initialise tracker for maximum of bottom friction coefficient 389 364 ! 390 # if defined key_vectopt_loop391 DO jj = 1, 1392 !CDIR NOVERRCHK393 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)394 # else395 !CDIR NOVERRCHK396 365 DO jj = 2, jpjm1 397 !CDIR NOVERRCHK398 366 DO ji = 2, jpim1 399 # endif400 367 ikbu = mbku(ji,jj) ! deepest ocean level at u- and v-points 401 368 ikbv = mbkv(ji,jj) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r4812 r4946 6 6 !! History : OPA ! 2000-08 (G. Madec) double diffusive mixing 7 7 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 8 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 8 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 9 !! 3.6 ! 2013-04 (G. Madec, F. Roquet) zrau compute locally using interpolation of alpha & beta 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_zdfddm || defined key_esopa … … 18 19 USE dom_oce ! ocean space and time domain variables 19 20 USE zdf_oce ! ocean vertical physics variables 21 USE eosbn2 ! equation of state 22 ! 20 23 USE in_out_manager ! I/O manager 21 24 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 34 37 LOGICAL , PUBLIC, PARAMETER :: lk_zdfddm = .TRUE. !: double diffusive mixing flag 35 38 36 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avs !: salinity vertical diffusivity coeff. at w-point 37 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: rrau !: heat/salt buoyancy flux ratio 38 39 ! !!* Namelist namzdf_ddm : double diffusive mixing * 40 REAL(wp) :: rn_avts ! maximum value of avs for salt fingering 41 REAL(wp) :: rn_hsbfr ! heat/salt buoyancy flux ratio 39 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avs !: salinity vertical diffusivity coeff. at w-point 40 41 ! !!* Namelist namzdf_ddm : double diffusive mixing * 42 REAL(wp) :: rn_avts ! maximum value of avs for salt fingering 43 REAL(wp) :: rn_hsbfr ! heat/salt buoyancy flux ratio 42 44 43 45 !! * Substitutions 46 # include "domzgr_substitute.h90" 44 47 # include "vectopt_loop_substitute.h90" 45 48 !!---------------------------------------------------------------------- 46 !! NEMO/OPA 4.0 , NEMO Consortium (2011)49 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 47 50 !! $Id$ 48 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 54 57 !! *** ROUTINE zdf_ddm_alloc *** 55 58 !!---------------------------------------------------------------------- 56 ALLOCATE( avs(jpi,jpj,jpk), rrau(jpi,jpj,jpk), STAT= zdf_ddm_alloc ) 57 ! 59 ALLOCATE( avs(jpi,jpj,jpk) , STAT= zdf_ddm_alloc ) 58 60 IF( lk_mpp ) CALL mpp_sum ( zdf_ddm_alloc ) 59 61 IF( zdf_ddm_alloc /= 0 ) CALL ctl_warn('zdf_ddm_alloc: failed to allocate arrays') … … 71 73 !! diffusive mixing (i.e. salt fingering and diffusive layering) 72 74 !! following Merryfield et al. (1999). The rate of double diffusive 73 !! mixing depend on the buoyancy ratio: Rrau=alpha/beta dk[T]/dk[S] 74 !! which is computed in rn2.F 75 !! mixing depend on the buoyancy ratio (R=alpha/beta dk[T]/dk[S]): 75 76 !! * salt fingering (Schmitt 1981): 76 !! for R rau > 1 and rn2 > 0 : zavfs = rn_avts / ( 1 + (Rrau/rn_hsbfr)^6 )77 !! for R rau> 1 and rn2 > 0 : zavfs = O78 !! otherwise : zavft = 0.7 zavs / R rau77 !! for R > 1 and rn2 > 0 : zavfs = rn_avts / ( 1 + (R/rn_hsbfr)^6 ) 78 !! for R > 1 and rn2 > 0 : zavfs = O 79 !! otherwise : zavft = 0.7 zavs / R 79 80 !! * diffusive layering (Federov 1988): 80 !! for 0< Rrau < 1 and rn2 > 0 : zavdt = 1.3635e-6 81 !! * exp( 4.6 exp(-0.54 (1/Rrau-1) ) ) 81 !! for 0< R < 1 and N^2 > 0 : zavdt = 1.3635e-6 * exp( 4.6 exp(-0.54 (1/R-1) ) ) 82 82 !! otherwise : zavdt = 0 83 !! for .5 < R rau < 1 and rn2 > 0 : zavds = zavdt (1.885 Rrau-0.85)84 !! for 0 < R rau <.5 and rn2 > 0 : zavds = zavdt 0.15 Rrau83 !! for .5 < R < 1 and N^2 > 0 : zavds = zavdt (1.885 R -0.85) 84 !! for 0 < R <.5 and N^2 > 0 : zavds = zavdt 0.15 R 85 85 !! otherwise : zavds = 0 86 86 !! * update the eddy diffusivity: … … 96 96 ! 97 97 INTEGER :: ji, jj , jk ! dummy loop indices 98 REAL(wp) :: zinr, zrr ! temporary scalars 99 REAL(wp) :: zavft, zavfs ! - - 100 REAL(wp) :: zavdt, zavds ! - - 101 REAL(wp), POINTER, DIMENSION(:,:) :: zmsks, zmskf, zmskd1, zmskd2, zmskd3 98 REAL(wp) :: zaw, zbw, zrw ! local scalars 99 REAL(wp) :: zdt, zds 100 REAL(wp) :: zinr, zrr ! - - 101 REAL(wp) :: zavft, zavfs ! - - 102 REAL(wp) :: zavdt, zavds ! - - 103 REAL(wp), POINTER, DIMENSION(:,:) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 102 104 !!---------------------------------------------------------------------- 103 105 ! 104 106 IF( nn_timing == 1 ) CALL timing_start('zdf_ddm') 105 107 ! 106 CALL wrk_alloc( jpi,jpj, z msks, zmskf, zmskd1, zmskd2, zmskd3 )107 108 CALL wrk_alloc( jpi,jpj, zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 ) 109 ! 108 110 ! ! =============== 109 !! Horizontal slab111 DO jk = 2, jpkm1 ! Horizontal slab 110 112 ! ! =============== 111 DO jj = 1, jpj ! indicators:112 DO ji = 1, jpi113 DO jk = mikt(ji,jj)+1, jpkm1 ! Horizontal slab114 113 ! Define the mask 115 114 ! --------------- 116 rrau(ji,jj,jk) = MAX( 1.e-20, rrau(ji,jj,jk) ) ! only retains positive value of rrau 117 115 DO jj = 1, jpj ! R=zrau = (alpha / beta) (dk[t] / dk[s]) 116 DO ji = 1, jpi 117 zrw = ( fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk) ) & 118 & / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 119 ! 120 zaw = ( rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem) * zrw ) & 121 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 122 zbw = ( rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal) * zrw ) & 123 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 124 ! 125 zdt = zaw * ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) 126 zds = zbw * ( tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) 127 IF( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 128 zrau(ji,jj) = MAX( 1.e-20, zdt / zds ) ! only retains positive value of zrau 129 END DO 130 END DO 131 132 DO jj = 1, jpj ! indicators: 133 DO ji = 1, jpi 118 134 ! stability indicator: msks=1 if rn2>0; 0 elsewhere 119 135 IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp 120 136 ELSE ; zmsks(ji,jj) = 1._wp 121 137 ENDIF 122 ! salt fingering indicator: msksf=1 if rrau>1; 0 elsewhere123 IF( rrau(ji,jj,jk) <= 1.) THEN ; zmskf(ji,jj) = 0._wp138 ! salt fingering indicator: msksf=1 if R>1; 0 elsewhere 139 IF( zrau(ji,jj) <= 1. ) THEN ; zmskf(ji,jj) = 0._wp 124 140 ELSE ; zmskf(ji,jj) = 1._wp 125 141 ENDIF 126 142 ! diffusive layering indicators: 127 ! ! mskdl1=1 if 0< rrau<1; 0 elsewhere128 IF( rrau(ji,jj,jk) >= 1.) THEN ; zmskd1(ji,jj) = 0._wp143 ! ! mskdl1=1 if 0< R <1; 0 elsewhere 144 IF( zrau(ji,jj) >= 1. ) THEN ; zmskd1(ji,jj) = 0._wp 129 145 ELSE ; zmskd1(ji,jj) = 1._wp 130 146 ENDIF 131 ! ! mskdl2=1 if 0< rrau<0.5; 0 elsewhere132 IF( rrau(ji,jj,jk) >= 0.5) THEN ; zmskd2(ji,jj) = 0._wp147 ! ! mskdl2=1 if 0< R <0.5; 0 elsewhere 148 IF( zrau(ji,jj) >= 0.5 ) THEN ; zmskd2(ji,jj) = 0._wp 133 149 ELSE ; zmskd2(ji,jj) = 1._wp 134 150 ENDIF 135 ! mskdl3=1 if 0.5<rrau<1; 0 elsewhere 136 IF( rrau(ji,jj,jk) <= 0.5 .OR. rrau(ji,jj,jk) >= 1. ) THEN ; zmskd3(ji,jj) = 0._wp 137 ELSE ; zmskd3(ji,jj) = 1._wp 138 ENDIF 151 ! mskdl3=1 if 0.5< R <1; 0 elsewhere 152 IF( zrau(ji,jj) <= 0.5 .OR. zrau(ji,jj) >= 1. ) THEN ; zmskd3(ji,jj) = 0._wp 153 ELSE ; zmskd3(ji,jj) = 1._wp 154 ENDIF 155 END DO 156 END DO 139 157 ! mask zmsk in order to have avt and avs masked 140 zmsks(ji,jj) = zmsks(ji,jj) * tmask(ji,jj,jk)158 zmsks(:,:) = zmsks(:,:) * tmask(:,:,jk) 141 159 142 160 … … 144 162 ! ------------------ 145 163 ! Constant eddy coefficient: reset to the background value 146 zinr = 1./rrau(ji,jj,jk) 164 !CDIR NOVERRCHK 165 DO jj = 1, jpj 166 !CDIR NOVERRCHK 167 DO ji = 1, jpi 168 zinr = 1._wp / zrau(ji,jj) 147 169 ! salt fingering 148 zrr = rrau(ji,jj,jk)/rn_hsbfr170 zrr = zrau(ji,jj) / rn_hsbfr 149 171 zrr = zrr * zrr 150 172 zavfs = rn_avts / ( 1 + zrr*zrr*zrr ) * zmsks(ji,jj) * zmskf(ji,jj) … … 152 174 ! diffusive layering 153 175 zavdt = 1.3635e-6 * EXP( 4.6 * EXP( -0.54*(zinr-1.) ) ) * zmsks(ji,jj) * zmskd1(ji,jj) 154 zavds = zavdt * zmsks(ji,jj) * ( ( 1.85 * rrau(ji,jj,jk) - 0.85 ) * zmskd3(ji,jj) &155 & + 0.15 * rrau(ji,jj,jk) * zmskd2(ji,jj) )176 zavds = zavdt * zmsks(ji,jj) * ( ( 1.85 * zrau(ji,jj) - 0.85 ) * zmskd3(ji,jj) & 177 & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) 156 178 ! add to the eddy viscosity coef. previously computed 157 179 avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds … … 160 182 END DO 161 183 END DO 162 END DO 184 185 163 186 ! Increase avmu, avmv if necessary 164 187 ! -------------------------------- 165 188 !!gm to be changed following the definition of avm. 166 DO jj = 1, jpjm1 167 DO ji = 1, fs_jpim1 ! vector opt. 168 DO jk = miku(ji,jj)+1, jpkm1 ! Horizontal slab 189 DO jj = 1, jpjm1 190 DO ji = 1, fs_jpim1 ! vector opt. 169 191 avmu(ji,jj,jk) = MAX( avmu(ji,jj,jk), & 170 192 & avt(ji,jj,jk), avt(ji+1,jj,jk), & 171 193 & avs(ji,jj,jk), avs(ji+1,jj,jk) ) * umask(ji,jj,jk) 172 END DO173 DO jk = mikv(ji,jj)+1, jpkm1174 194 avmv(ji,jj,jk) = MAX( avmv(ji,jj,jk), & 175 195 & avt(ji,jj,jk), avt(ji,jj+1,jk), & … … 209 229 !! called by zdf_ddm at the first timestep (nit000) 210 230 !!---------------------------------------------------------------------- 231 INTEGER :: ios ! local integer 232 !! 211 233 NAMELIST/namzdf_ddm/ rn_avts, rn_hsbfr 212 INTEGER :: ios ! Local integer output status for namelist read213 234 !!---------------------------------------------------------------------- 214 235 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90
r3294 r4946 78 78 ! 79 79 DO jk = 1, jpkm1 80 #if defined key_vectopt_loop81 DO jj = 1, 1 ! big loop forced82 DO ji = jpi+2, jpij83 #else84 80 DO jj = 2, jpj ! no vector opt. 85 81 DO ji = 2, jpi 86 #endif87 82 #if defined key_zdfkpp 88 83 ! no evd mixing in the boundary layer with KPP … … 110 105 DO jk = 1, jpkm1 111 106 !!! WHERE( rn2(:,:,jk) <= -1.e-12 ) avt(:,:,jk) = tmask(:,:,jk) * avevd ! agissant sur T SEUL! 112 #if defined key_vectopt_loop113 DO jj = 1, 1 ! big loop forced114 DO ji = 1, jpij115 #else116 107 DO jj = 1, jpj ! loop over the whole domain (no lbc_lnk call) 117 108 DO ji = 1, jpi 118 #endif119 109 #if defined key_zdfkpp 120 110 ! no evd mixing in the boundary layer with KPP -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfkpp.F90
r4624 r4946 26 26 USE phycst ! physical constants 27 27 USE eosbn2 ! equation of state 28 USE zdfddm ! double diffusion mixing 28 USE zdfddm ! double diffusion mixing (avs array) 29 USE lib_mpp ! MPP library 30 USE trd_oce ! ocean trends definition 31 USE trdtra ! tracers trends 32 ! 29 33 USE in_out_manager ! I/O manager 30 USE lib_mpp ! MPP library31 USE wrk_nemo ! work arrays32 34 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 35 USE prtctl ! Print control 34 USE trdmod_oce ! ocean trends definition 35 USE trdtra ! tracers trends 36 USE wrk_nemo ! work arrays 36 37 USE timing ! Timing 37 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 39 39 40 IMPLICIT NONE … … 246 247 REAL(wp) :: zdelta, zdelta2, zdzup, zdzdn, zdzh, zvath, zgat1, zdat1, zkm1m, zkm1t 247 248 #if defined key_zdfddm 248 REAL(wp) :: zrrau, zds, zavdds, zavddt,zinr ! double diffusion mixing 249 REAL(wp), POINTER, DIMENSION(:,:) :: zdifs 249 REAL(wp) :: zrw, zkm1s ! local scalars 250 REAL(wp) :: zrrau, zdt, zds, zavdds, zavddt, zinr ! double diffusion mixing 251 REAL(wp), POINTER, DIMENSION(:,:) :: zdifs 250 252 REAL(wp), POINTER, DIMENSION(:) :: za2s, za3s, zkmps 251 REAL(wp) :: zkm1s252 253 REAL(wp), POINTER, DIMENSION(:,:) :: zblcs 253 254 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdiffus … … 274 275 #endif 275 276 276 zviscos(:,:,:) = 0. 277 zblcm (:,: ) = 0. 278 zdiffut(:,:,:) = 0. 279 zblct (:,: ) = 0. 277 zviscos(:,:,:) = 0._wp 278 zblcm (:,: ) = 0._wp 279 zdiffut(:,:,:) = 0._wp 280 zblct (:,: ) = 0._wp 280 281 #if defined key_zdfddm 281 zdiffus(:,:,:) = 0. 282 zblcs (:,: ) = 0. 283 #endif 284 ghats(:,:,:) = 0. 285 286 zBo (:,:) = 0. 287 zBosol(:,:) = 0. 288 zustar(:,:) = 0. 289 290 282 zdiffus(:,:,:) = 0._wp 283 zblcs (:,: ) = 0._wp 284 #endif 285 ghats (:,:,:) = 0._wp 286 zBo (:,: ) = 0._wp 287 zBosol (:,: ) = 0._wp 288 zustar (:,: ) = 0._wp 289 ! 291 290 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 292 291 ! I. Interior diffusivity and viscosity at w points ( T interfaces) … … 332 331 avt (ji,jj,jk) = avt (ji,jj,jk) + rn_difri * zfri 333 332 ENDIF 333 ! 334 334 #if defined key_zdfddm 335 avs (ji,jj,jk) = avt (ji,jj,jk)335 ! 336 336 ! Double diffusion mixing ; NOT IN ROUTINE ZDFDDM.F90 337 ! ------------------------------------------------------------------ 338 ! only retains positive value of rrau 339 zrrau = MAX( rrau(ji,jj,jk), epsln ) 340 zds = tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) 341 IF( zrrau > 1. .AND. zds > 0.) THEN 342 ! 343 ! Salt fingering case. 344 !--------------------- 345 ! Compute interior diffusivity for double diffusive mixing of 346 ! salinity. Upper bound "zrrau" by "Rrho0"; (Rrho0=1.9, difcoefnuf=0.001). 347 ! After that set interior diffusivity for double diffusive mixing 348 ! of temperature 337 ! ------------------------- 338 avs (ji,jj,jk) = avt (ji,jj,jk) 339 340 ! R=zrau = (alpha / beta) (dk[t] / dk[s]) 341 zrw = ( fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk) ) & 342 & / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 343 ! 344 zaw = ( rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem) * zrw ) * tmask(ji,jj,jk) 345 zbw = ( rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal) * zrw ) * tmask(ji,jj,jk) 346 ! 347 zdt = zaw * ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) 348 zds = zbw * ( tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) 349 IF( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 350 zrrau = MAX( epsln , zdt / zds ) ! only retains positive value of zrau 351 ! 352 IF( zrrau > 1. .AND. zds > 0.) THEN ! Salt fingering case. 353 ! !--------------------- 354 ! Compute interior diffusivity for double diffusive mixing of salinity. 355 ! Upper bound "zrrau" by "Rrho0"; (Rrho0=1.9, difcoefnuf=0.001). 356 ! After that set interior diffusivity for double diffusive mixing of temperature 349 357 zavdds = MIN( zrrau, Rrho0 ) 350 358 zavdds = ( zavdds - 1.0 ) / ( Rrho0 - 1.0 ) … … 353 361 zavdds = difssf * zavdds 354 362 zavddt = 0.7 * zavdds 355 ELSEIF( zrrau < 1. .AND. zrrau > 0. .AND. zds < 0.) THEN356 363 ! 357 ! Diffusive convection case. 358 !--------------------------- 359 ! Compute interior diffusivity for double diffusive mixing of 360 ! temperature (Marmorino and Caldwell, 1976); 364 ELSEIF( zrrau < 1. .AND. zrrau > 0. .AND. zds < 0.) THEN ! Diffusive convection case. 365 ! !--------------------------- 366 ! Compute interior diffusivity for double diffusive mixing of temperature (Marmorino and Caldwell, 1976); 361 367 ! Compute interior diffusivity for double diffusive mixing of salinity 362 368 zinr = 1. / zrrau 363 369 zavddt = 0.909 * EXP( 4.6 * EXP( -0.54* ( zinr - 1. ) ) ) 364 370 zavddt = difsdc * zavddt 365 IF( zrrau < 0.5) THEN 366 zavdds = zavddt * 0.15 * zrrau 367 ELSE 368 zavdds = zavddt * (1.85 * zrrau - 0.85 ) 371 IF( zrrau < 0.5) THEN ; zavdds = zavddt * 0.15 * zrrau 372 ELSE ; zavdds = zavddt * (1.85 * zrrau - 0.85 ) 369 373 ENDIF 370 374 ELSE … … 385 389 !--------------------------------------------------------------------- 386 390 DO jj = 2, jpjm1 387 DO ji = fs_2, fs_jpim1 388 IF( nn_eos < 1) THEN 389 zt = tsn(ji,jj,1,jp_tem) 390 zs = tsn(ji,jj,1,jp_sal) - 35.0 391 zh = fsdept(ji,jj,1) 392 ! potential volumic mass 393 zrhos = rhop(ji,jj,1) 394 zalbet = ( ( ( - 0.255019e-07 * zt + 0.298357e-05 ) * zt & ! ratio alpha/beta 395 & - 0.203814e-03 ) * zt & 396 & + 0.170907e-01 ) * zt & 397 & + 0.665157e-01 & 398 & + ( - 0.678662e-05 * zs & 399 & - 0.846960e-04 * zt + 0.378110e-02 ) * zs & 400 & + ( ( - 0.302285e-13 * zh & 401 & - 0.251520e-11 * zs & 402 & + 0.512857e-12 * zt * zt ) * zh & 403 & - 0.164759e-06 * zs & 404 & +( 0.791325e-08 * zt - 0.933746e-06 ) * zt & 405 & + 0.380374e-04 ) * zh 406 407 zbeta = ( ( -0.415613e-09 * zt + 0.555579e-07 ) * zt & ! beta 408 & - 0.301985e-05 ) * zt & 409 & + 0.785567e-03 & 410 & + ( 0.515032e-08 * zs & 411 & + 0.788212e-08 * zt - 0.356603e-06 ) * zs & 412 & +( ( 0.121551e-17 * zh & 413 & - 0.602281e-15 * zs & 414 & - 0.175379e-14 * zt + 0.176621e-12 ) * zh & 415 & + 0.408195e-10 * zs & 416 & + ( - 0.213127e-11 * zt + 0.192867e-09 ) * zt & 417 & - 0.121555e-07 ) * zh 418 419 zthermal = zbeta * zalbet / ( rcp * zrhos + epsln ) 420 zhalin = zbeta * tsn(ji,jj,1,jp_sal) * rcs 421 ELSE 422 zrhos = rhop(ji,jj,1) + rau0 * ( 1. - tmask(ji,jj,1) ) 423 zthermal = rn_alpha / ( rcp * zrhos + epsln ) 424 zhalin = rn_beta * tsn(ji,jj,1,jp_sal) * rcs 425 zbeta = rn_beta 426 ENDIF 391 DO ji = fs_2, fs_jpim1 392 zrhos = rau0 * ( 1._wp + rhd(ji,jj,1) ) * tmask(ji,jj,1) 393 zthermal = rab_n(ji,jj,1,jp_tem) / ( rcp * zrhos + epsln ) 394 zbeta = rab_n(ji,jj,1,jp_sal) 395 zhalin = zbeta * tsn(ji,jj,1,jp_sal) * rcs 396 ! 427 397 ! Radiative surface buoyancy force 428 398 zBosol(ji,jj) = grav * zthermal * qsr(ji,jj) … … 435 405 ws0(ji,jj) = - ( ( emp(ji,jj)-rnf(ji,jj) ) * tsn(ji,jj,1,jp_sal) & 436 406 & + sfx(ji,jj) ) * rcs * tmask(ji,jj,1) 437 END DO438 END DO407 END DO 408 END DO 439 409 440 410 zflageos = 0.5 + SIGN( 0.5, nn_eos - 1. ) … … 447 417 ! Friction velocity (zustar), at T-point : LMD94 eq. 2 448 418 zustar(ji,jj) = SQRT( taum(ji,jj) / ( zrhos + epsln ) ) 449 END DO450 END DO419 END DO 420 END DO 451 421 452 422 !CDIR NOVERRCHK … … 1270 1240 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 1271 1241 !!bug gm jpttdzdf ==> jpttkpp 1272 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_zdf, ztrdt )1273 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_zdf, ztrds )1242 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 1243 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 1274 1244 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 1275 1245 ENDIF … … 1340 1310 IF( l_trdtrc ) THEN ! save the non-local tracer flux trends for diagnostic 1341 1311 ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) 1342 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_zdf, ztrtrd(:,:,:) )1312 CALL trd_tra( kt, 'TRC', jn, jptra_zdf, ztrtrd(:,:,:) ) 1343 1313 ENDIF 1344 1314 ! … … 1375 1345 !!---------------------------------------------------------------------- 1376 1346 INTEGER :: ji, jj, jk ! dummy loop indices 1347 INTEGER :: ios ! local integer 1377 1348 #if ! defined key_kppcustom 1378 1349 INTEGER :: jm ! dummy loop indices … … 1382 1353 REAL(wp) :: zustar, zucube, zustvk, zeta, zehat ! tempory scalars 1383 1354 #endif 1384 INTEGER :: ios ! Local integer output status for namelist read1385 1355 REAL(wp) :: zhbf ! tempory scalars 1386 1356 LOGICAL :: ll_kppcustom ! 1st ocean level taken as surface layer -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r4812 r4946 6 6 !! History : 1.0 ! 2003-08 (G. Madec) original code 7 7 !! 3.2 ! 2009-07 (S. Masson, G. Madec) IOM + merge of DO-loop 8 !! 3.7 ! 2012-03 (G. Madec) make public the density criteria for trdmxl 9 !! - ! 2014-02 (F. Roquet) mixed layer depth calculated using N2 instead of rhop 8 10 !!---------------------------------------------------------------------- 9 11 !! zdf_mxl : Compute the turbocline and mixed layer depths. … … 14 16 USE in_out_manager ! I/O manager 15 17 USE prtctl ! Print control 18 USE phycst ! physical constants 16 19 USE iom ! I/O library 17 20 USE lib_mpp ! MPP library … … 25 28 PUBLIC zdf_mxl ! called by step.F90 26 29 27 REAL(wp), PUBLIC :: rho_c = 0.01_wp ! density criterion for mixed layer depth28 REAL(wp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth29 30 30 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by TOP) 31 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] 32 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] 33 33 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: mixed layer depth at t-points [m] 34 35 REAL(wp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth 36 REAL(wp) :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth 34 37 35 38 !! * Substitutions … … 70 73 !! eddy diffusivity coefficient (resulting from the vertical physics 71 74 !! alone, not the isopycnal part, see trazdf.F) fall below a given 72 !! value defined locally (avt_c here taken equal to 5 cm/s2 )75 !! value defined locally (avt_c here taken equal to 5 cm/s2 by default) 73 76 !! 74 77 !! ** Action : nmln, hmld, hmlp, hmlpt 75 78 !!---------------------------------------------------------------------- 76 79 INTEGER, INTENT(in) :: kt ! ocean time-step index 77 !! 78 INTEGER :: ji, jj, jk ! dummy loop indices 79 INTEGER :: iikn, iiki ! temporary integer within a do loop 80 INTEGER, POINTER, DIMENSION(:,:) :: imld ! temporary workspace 80 ! 81 INTEGER :: ji, jj, jk ! dummy loop indices 82 INTEGER :: iikn, iiki, ikt, imkt ! local integer 83 REAL(wp) :: zN2_c ! local scalar 84 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 81 85 !!---------------------------------------------------------------------- 82 86 ! … … 94 98 95 99 ! w-level of the mixing and mixed layers 96 nmln(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point 97 imld(:,:) = mbkt(:,:) + 1 98 DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 100 nmln(:,:) = nlb10 ! Initialization to the number of w ocean point 101 hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 102 zN2_c = grav * rho_c * r1_rau0 ! convert density criteria into N^2 criteria 103 DO jk = nlb10, jpkm1 104 DO jj = 1, jpj ! Mixed layer level: w-level 105 DO ji = 1, jpi 106 ikt = mbkt(ji,jj) 107 hmlp(ji,jj) = hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * fse3w(ji,jj,jk) 108 IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level 109 END DO 110 END DO 111 END DO 112 ! 113 ! w-level of the turbocline 114 imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point 115 DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 99 116 DO jj = 1, jpj 100 117 DO ji = 1, jpi 101 IF( rhop(ji,jj,jk) > rhop(ji,jj,MAX(mikt(ji,jj),nla10)) + rho_c ) nmln(ji,jj) = MAX(jk,mikt(ji,jj)) ! Mixed layer102 IF( avt (ji,jj,jk) < avt_c ) imld(ji,jj) = MAX(mikt(ji,jj),jk) ! Turbocline118 imkt = mikt(ji,jj) 119 IF( avt (ji,jj,jk) < avt_c ) imld(ji,jj) = MAX( imkt, jk ) ! Turbocline 103 120 END DO 104 121 END DO … … 109 126 iiki = imld(ji,jj) 110 127 iikn = nmln(ji,jj) 111 hmld (ji,jj) = ( fsdepw(ji,jj,iiki ) - fsdepw(ji,jj,mikt(ji,jj) ) ) * ssmask(ji,jj) ! Turbocline depth 112 hmlp (ji,jj) = ( fsdepw(ji,jj,iikn ) - fsdepw(ji,jj,MAX(mikt(ji,jj),nla10) ) ) * ssmask(ji,jj) ! Mixed layer depth 113 hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,mikt(ji,jj) ) ) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 128 imkt = mikt(ji,jj) 129 hmld (ji,jj) = ( fsdepw(ji,jj,iiki ) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! Turbocline depth 130 hmlp (ji,jj) = ( fsdepw(ji,jj,iikn ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj) ! Mixed layer depth 131 hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 114 132 END DO 115 133 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r4666 r4946 295 295 END DO 296 296 ! ! finite LC depth 297 # if defined key_vectopt_loop298 DO jj = 1, 1299 DO ji = 1, jpij ! vector opt. (forced unrolling)300 # else301 297 DO jj = 1, jpj 302 298 DO ji = 1, jpi 303 # endif304 299 zhlc(ji,jj) = fsdepw(ji,jj,imlc(ji,jj)) 305 300 END DO 306 301 END DO 307 302 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 308 !CDIR NOVERRCHK309 303 DO jk = 2, jpkm1 !* TKE Langmuir circulation source term added to en 310 !CDIR NOVERRCHK311 304 DO jj = 2, jpjm1 312 !CDIR NOVERRCHK313 305 DO ji = fs_2, fs_jpim1 ! vector opt. 314 306 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift … … 399 391 DO ji = fs_2, fs_jpim1 ! vector opt. 400 392 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 401 & 393 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,1) 402 394 END DO 403 395 END DO … … 408 400 jk = nmln(ji,jj) 409 401 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 410 & 402 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,1) 411 403 END DO 412 404 END DO … … 424 416 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 425 417 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 426 & 418 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * tmask(ji,jj,1) 427 419 END DO 428 420 END DO … … 734 726 ! 735 727 ! !* Check of some namelist values 736 IF( nn_mxl < 0 .OR. nn_mxl > 3 ) CALL ctl_stop( 'bad flag: nn_mxl is 0, 1 or 2 ' ) 737 IF( nn_pdl < 0 .OR. nn_pdl > 1 ) CALL ctl_stop( 'bad flag: nn_pdl is 0 or 1 ' ) 738 IF( nn_htau < 0 .OR. nn_htau > 1 ) CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 739 #if ! key_coupled 740 IF( nn_etau == 3 ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 741 #endif 728 IF( nn_mxl < 0 .OR. nn_mxl > 3 ) CALL ctl_stop( 'bad flag: nn_mxl is 0, 1 or 2 ' ) 729 IF( nn_pdl < 0 .OR. nn_pdl > 1 ) CALL ctl_stop( 'bad flag: nn_pdl is 0 or 1 ' ) 730 IF( nn_htau < 0 .OR. nn_htau > 1 ) CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 731 IF( nn_etau == 3 .AND. .NOT. lk_cpl ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 742 732 743 733 IF( ln_mxl0 ) THEN -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r4924 r4946 42 42 !!---------------------------------------------------------------------- 43 43 USE step_oce ! module used in the ocean time stepping module 44 USE sbc_oce ! surface boundary condition: ocean45 44 USE cla ! cross land advection (tra_cla routine) 46 45 USE domcfg ! domain configuration (dom_cfg routine) … … 51 50 #endif 52 51 USE tideini ! tidal components initialization (tide_ini routine) 53 USE bdyini ! open boundary cond. initialization(bdy_init routine)54 USE bdydta ! open boundary cond. initialization(bdy_dta_init routine)55 USE bdytides ! open boundary cond. initialization(bdytide_init routine)52 USE bdyini ! open boundary cond. setting (bdy_init routine) 53 USE bdydta ! open boundary cond. setting (bdy_dta_init routine) 54 USE bdytides ! open boundary cond. setting (bdytide_init routine) 56 55 USE istate ! initial state setting (istate_init routine) 57 56 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) … … 59 58 USE zdfini ! vertical physics setting (zdf_init routine) 60 59 USE phycst ! physical constant (par_cst routine) 61 USE trd mod ! momentum/tracers trends (trd_mod_init routine)60 USE trdini ! dyn/tra trends initialization (trd_init routine) 62 61 USE asminc ! assimilation increments 63 62 USE asmbkg ! writing out state trajectory … … 69 68 USE icbini ! handle bergs, initialisation 70 69 USE icbstp ! handle bergs, calving, themodynamics and transport 71 #if defined key_oasis372 70 USE cpl_oasis3 ! OASIS3 coupling 73 #elif defined key_oasis474 USE cpl_oasis4 ! OASIS4 coupling (not working)75 #endif76 71 USE c1d ! 1D configuration 77 72 USE step_c1d ! Time stepping loop for the 1D configuration … … 121 116 !!---------------------------------------------------------------------- 122 117 ! 123 124 118 #if defined key_agrif 125 119 CALL Agrif_Init_Grids() ! AGRIF: set the meshes … … 139 133 # endif 140 134 #endif 141 142 135 ! check that all process are still there... If some process have an error, 143 136 ! they will never enter in step and other processes will wait until the end of the cpu time! … … 166 159 167 160 DO WHILE ( istp <= nitend .AND. nstop == 0 ) 168 169 161 #if defined key_agrif 170 162 CALL Agrif_Step( stp ) ! AGRIF: time stepping … … 172 164 CALL stp( istp ) ! standard time stepping 173 165 #endif 174 175 166 istp = istp + 1 176 167 IF( lk_mpp ) CALL mpp_max( nstop ) … … 201 192 ! 202 193 CALL nemo_closefile 194 ! 203 195 #if defined key_iomput 204 196 CALL xios_finalize ! end mpp communications with xios 205 # if defined key_oasis3 || defined key_oasis4 206 CALL cpl_prism_finalize ! end coupling and mpp communications with OASIS 207 # endif 197 IF( lk_cpl ) CALL cpl_finalize ! end coupling and mpp communications with OASIS 208 198 #else 209 # if defined key_oasis3 || defined key_oasis4 210 CALL cpl_prism_finalize! end coupling and mpp communications with OASIS211 # else 212 IF( lk_mpp ) CALL mppstop! end mpp communications213 # endif 199 IF( lk_cpl ) THEN 200 CALL cpl_finalize ! end coupling and mpp communications with OASIS 201 ELSE 202 IF( lk_mpp ) CALL mppstop ! end mpp communications 203 ENDIF 214 204 #endif 215 205 ! … … 227 217 INTEGER :: ios 228 218 CHARACTER(len=80), DIMENSION(16) :: cltxt 229 ! !230 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &219 ! 220 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 231 221 & nn_isplt, nn_jsplt, nn_jctls, nn_jctle, & 232 222 & nn_bench, nn_timing … … 281 271 #if defined key_iomput 282 272 IF( Agrif_Root() ) THEN 283 # if defined key_oasis3 || defined key_oasis4 284 CALL cpl_prism_init( ilocal_comm )! nemo local communicator given by oasis285 CALL xios_initialize( "oceanx",local_comm=ilocal_comm )286 # else 287 CALL xios_initialize( "nemo",return_comm=ilocal_comm )288 # endif 273 IF( lk_cpl ) THEN 274 CALL cpl_init( ilocal_comm ) ! nemo local communicator given by oasis 275 CALL xios_initialize( "oceanx",local_comm=ilocal_comm ) ! send nemo communicator to xios 276 ELSE 277 CALL xios_initialize( "nemo",return_comm=ilocal_comm ) ! nemo local communicator given by xios 278 ENDIF 289 279 ENDIF 290 280 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection 291 281 #else 292 # if defined key_oasis3 || defined key_oasis4 293 IF( Agrif_Root() ) THEN294 CALL cpl_prism_init( ilocal_comm )! nemo local communicator given by oasis295 ENDIF296 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt)297 # else 298 ilocal_comm = 0299 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )! Nodes selection (control print return in cltxt)300 # endif 282 IF( lk_cpl ) THEN 283 IF( Agrif_Root() ) THEN 284 CALL cpl_init( ilocal_comm ) ! nemo local communicator given by oasis 285 ENDIF 286 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt) 287 ELSE 288 ilocal_comm = 0 289 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt) 290 ENDIF 301 291 #endif 302 292 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) … … 393 383 IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics 394 384 395 IF( lk_bdy ) CALL bdy_init! Open boundaries initialisation396 IF( lk_bdy ) CALL bdy_dta_init! Open boundaries initialisation of external data arrays385 IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation 386 IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays 397 387 IF( lk_bdy .AND. lk_tide ) & 398 & CALL bdytide_init! Open boundaries initialisation of tidal harmonic forcing388 & CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing 399 389 400 390 CALL dyn_nept_init ! simplified form of Neptune effect … … 406 396 CALL sbc_init ! Forcings : surface module 407 397 ! ! Vertical physics 408 409 398 CALL zdf_init ! namelist read 410 411 399 CALL zdf_bfr_init ! bottom friction 412 413 400 IF( lk_zdfric ) CALL zdf_ric_init ! Richardson number dependent Kz 414 401 IF( lk_zdftke ) CALL zdf_tke_init ! TKE closure scheme … … 449 436 CALL trc_init 450 437 #endif 451 ! 452 453 ! Diagnostics 438 ! ! Diagnostics 454 439 IF( lk_floats ) CALL flo_init ! drifting Floats 455 440 IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag … … 457 442 IF( lk_diadct ) CALL dia_dct_init ! Sections tranports 458 443 CALL dia_hsb_init ! heat content, salt content and volume budgets 459 CALL trd_mod_init ! Mixed-layer/Vorticity/Integral constraints trends444 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends 460 445 IF( lk_diaobs ) THEN ! Observation & model comparison 461 446 CALL dia_obs_init ! Initialize observational data 462 447 CALL dia_obs( nit000 - 1 ) ! Observation operator for restart 463 448 ENDIF 449 464 450 ! ! Assimilation increments 465 451 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments … … 659 645 !! ** Method : 660 646 !!---------------------------------------------------------------------- 661 INTEGER, INTENT(in) :: num_pes! The number of MPI processes we have647 INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 662 648 ! 663 649 INTEGER, PARAMETER :: nfactmax = 20 … … 668 654 INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 669 655 !!---------------------------------------------------------------------- 670 656 ! 671 657 ierr = 0 672 658 ! 673 659 CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 674 660 ! 675 661 IF( nfact <= 1 ) THEN 676 662 WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' … … 714 700 INTEGER, PARAMETER :: ntest = 14 715 701 INTEGER :: ilfax(ntest) 716 702 ! 717 703 ! lfax contains the set of allowed factors. 718 704 data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, & … … 765 751 766 752 #if defined key_mpp_mpi 753 767 754 SUBROUTINE nemo_northcomms 768 755 !!====================================================================== … … 839 826 END SUBROUTINE nemo_northcomms 840 827 #endif 828 841 829 !!====================================================================== 842 830 END MODULE nemogcm -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/oce.F90
r4924 r4946 20 20 !! dynamics and tracer fields ! before ! now ! after ! the after trends becomes the fields 21 21 !! -------------------------- ! fields ! fields ! trends ! only after tra_zdf and dyn_spg 22 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ub , un , ua !: i-horizontal velocity [m/s] 23 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vb , vn , va !: j-horizontal velocity [m/s] 24 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ua_sv, va_sv !: Saved trends (time spliting) [m/s2] 25 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn !: vertical velocity [m/s] 26 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rotb , rotn !: relative vorticity [s-1] 27 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivb, hdivn !: horizontal divergence [s-1] 28 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsb , tsn !: 4D T-S fields [Celcius,psu] 29 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] 30 ! 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsa !: 4D T-S trends fields & work array 22 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ub , un , ua !: i-horizontal velocity [m/s] 23 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vb , vn , va !: j-horizontal velocity [m/s] 24 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ua_sv, va_sv !: Saved trends (time spliting) [m/s2] 25 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn !: vertical velocity [m/s] 26 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rotb , rotn !: relative vorticity [s-1] 27 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivb, hdivn !: horizontal divergence [s-1] 28 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsb , tsn , tsa !: 4D T-S fields [Celcius,psu] 29 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celcius-1,psu-1] 30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] 32 31 ! 33 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhd !: in situ density anomalie rhd=(rho-rau0)/rau0 [no units] … … 70 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] 71 70 72 !! arrays related to penetration of solar fluxes to calculate the heat budget for sea ice73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: oatte, iatte !: attenuation coef of the input solar flux [unitless]71 !! Energy budget of the leads (open water embedded in sea ice) 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] 74 73 75 74 !!---------------------------------------------------------------------- … … 94 93 & hdivb(jpi,jpj,jpk) , hdivn(jpi,jpj,jpk) , & 95 94 & tsb (jpi,jpj,jpk,jpts) , tsn (jpi,jpj,jpk,jpts) , tsa(jpi,jpj,jpk,jpts) , & 95 & rab_b(jpi,jpj,jpk,jpts) , rab_n(jpi,jpj,jpk,jpts) , & 96 96 & rn2b (jpi,jpj,jpk) , rn2 (jpi,jpj,jpk) , STAT=ierr(1) ) 97 97 ! … … 117 117 ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) 118 118 ! 119 ALLOCATE( iatte(jpi,jpj) , oatte(jpi,jpj) , STAT=ierr(4) )119 ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(4) ) 120 120 ! 121 121 oce_alloc = MAXVAL( ierr ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/par_oce.F90
r4205 r4946 94 94 #endif 95 95 96 #if defined key_vectopt_loop97 LOGICAL, PUBLIC, PARAMETER :: lk_vopt_loop = .TRUE. !: vector optimization flag98 #else99 LOGICAL, PUBLIC, PARAMETER :: lk_vopt_loop = .FALSE. !: vector optimization flag100 #endif101 102 96 !!---------------------------------------------------------------------- 103 97 !! NEMO/OPA 3.3 , NEMO Consortium (2010) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/step.F90
r4924 r4946 24 24 !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA 25 25 !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal 26 !! ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs 26 !! ! 2012-07 (J. Simeon, G. Madec, C. Ethe) Online coarsening of outputs 27 !! 3.7 ! 2014-04 (F. Roquet, G. Madec) New equations of state 27 28 !!---------------------------------------------------------------------- 28 29 … … 40 41 !! * Substitutions 41 42 # include "domzgr_substitute.h90" 42 # include "zdfddm_substitute.h90"43 !!---------------------------------------------------------------------- 44 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)43 !!gm # include "zdfddm_substitute.h90" 44 !!---------------------------------------------------------------------- 45 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 45 46 !! $Id$ 46 47 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 107 108 ! Ocean physics update (ua, va, tsa used as workspace) 108 109 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 109 CALL bn2( tsb, rn2b ) ! before Brunt-Vaisala frequency 110 CALL bn2( tsn, rn2 ) ! now Brunt-Vaisala frequency 110 ! THERMODYNAMICS 111 CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points 112 CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points 113 CALL bn2 ( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 114 CALL bn2 ( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency 111 115 ! 112 116 ! VERTICAL PHYSICS … … 206 210 IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats 207 211 IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) 208 IF( lk_diafwb )CALL dia_fwb( kstp ) ! Fresh water budget diagnostics212 IF( .NOT. lk_cpl ) CALL dia_fwb( kstp ) ! Fresh water budget diagnostics 209 213 IF( ln_diaptr ) CALL dia_ptr( kstp ) ! Poleward TRansports diagnostics 210 214 IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports … … 222 226 CALL trc_stp( kstp ) ! time-stepping 223 227 #endif 228 224 229 225 230 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 322 327 323 328 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 324 ! Trends (ua, va, tsa used as workspace)325 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<326 IF( nstop == 0 ) THEN327 IF( lk_trddyn ) CALL trd_dwr( kstp ) ! trends: dynamics328 IF( lk_trdtra ) CALL trd_twr( kstp ) ! trends: active tracers329 IF( lk_trdmld ) CALL trd_mld( kstp ) ! trends: Mixed-layer330 IF( lk_trdvor ) CALL trd_vor( kstp ) ! trends: vorticity budget331 ENDIF332 333 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>334 329 ! Coupled mode 335 330 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r4328 r4946 25 25 USE sbcrnf ! surface boundary condition: runoff variables 26 26 USE sbccpl ! surface boundary condition: coupled formulation (call send at end of step) 27 USE cpl_oasis3, ONLY : lk_cpl27 USE sbc_oce ! surface boundary condition: ocean 28 28 USE sbctide ! Tide initialisation 29 29 … … 84 84 85 85 USE diawri ! Standard run outputs (dia_wri routine) 86 USE trdicp ! Ocean momentum/tracers trends (trd_wri routine)87 USE trdmld ! mixed-layer trends (trd_mld routine)88 USE trdmld_rst ! restart for mixed-layer trends89 USE trdmod_oce ! ocean momentum/tracers trends90 USE trdmod ! momentum/tracers trends91 USE trdvor ! vorticity budget (trd_vor routine)92 86 USE diaptr ! poleward transports (dia_ptr routine) 93 87 USE diadct ! sections transports (dia_dct routine) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/OPA_SRC/vectopt_loop_substitute.h90
r2528 r4946 2 2 !! *** vectopt_loop_substitute *** 3 3 !!---------------------------------------------------------------------- 4 !! ** purpose : substitute the inner loop start ing and inding indices5 !! to allow unrolling of do-loop using CPP macro.4 !! ** purpose : substitute the inner loop start/end indices with CPP macro 5 !! allow unrolling of do-loop (useful with vector processors) 6 6 !!---------------------------------------------------------------------- 7 7 !!---------------------------------------------------------------------- 8 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)8 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 9 9 !! $Id$ 10 10 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 11 11 !!---------------------------------------------------------------------- 12 12 #if defined key_vectopt_loop 13 # define fs_2114 # define fs_jpim1jpi13 # define fs_2 1 14 # define fs_jpim1 jpi 15 15 #else 16 # define fs_2217 # define fs_jpim1jpim116 # define fs_2 2 17 # define fs_jpim1 jpim1 18 18 #endif -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/SAS_SRC/sbcssm.F90
r4624 r4946 166 166 !! note that we need sbc_ssm called first in sbc 167 167 ! 168 IF( ln_cpl ) THEN169 IF( lwp ) WRITE(numout,*) 'Coupled mode not sensible with StandAlone Surface scheme'170 ln_cpl = .FALSE.171 ENDIF172 168 IF( ln_apr_dyn ) THEN 173 169 IF( lwp ) WRITE(numout,*) 'No atmospheric gradient needed with StandAlone Surface scheme' -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/C14b/trcsms_c14b.F90
r3680 r4946 18 18 USE par_trc ! TOP parameters 19 19 USE trc ! TOP variables 20 USE trd mod_oce21 USE trd mod_trc20 USE trd_oce 21 USE trdtrc 22 22 USE iom ! I/O library 23 23 … … 302 302 ENDIF 303 303 304 IF( l_trdtrc ) CALL trd_ mod_trc( tra(:,:,:,jpc14), jpc14, jptra_trd_sms, kt ) ! save trends304 IF( l_trdtrc ) CALL trd_trc( tra(:,:,:,jpc14), jpc14, jptra_sms, kt ) ! save trends 305 305 306 306 CALL wrk_dealloc( jpi, jpj, zatmbc14 ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/CFC/trcsms_cfc.F90
r3680 r4946 18 18 USE par_trc ! TOP parameters 19 19 USE trc ! TOP variables 20 USE trd mod_oce21 USE trd mod_trc20 USE trd_oce 21 USE trdtrc 22 22 USE iom ! I/O library 23 23 … … 201 201 IF( l_trdtrc ) THEN 202 202 DO jn = jp_cfc0, jp_cfc1 203 CALL trd_ mod_trc( tra(:,:,:,jn), jn, jptra_trd_sms, kt ) ! save trends203 CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends 204 204 END DO 205 205 END IF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcsms_my_trc.F90
r3680 r4946 16 16 USE oce_trc ! Ocean variables 17 17 USE trc ! TOP variables 18 USE trd mod_oce19 USE trd mod_trc18 USE trd_oce 19 USE trdtrc 20 20 21 21 IMPLICIT NONE … … 65 65 DO jn = jp_myt0, jp_myt1 66 66 ztrmyt(:,:,:) = tra(:,:,:,jn) 67 CALL trd_ mod_trc( ztrmyt, jn, jptra_trd_sms, kt ) ! save trends67 CALL trd_trc( ztrmyt, jn, jptra_sms, kt ) ! save trends 68 68 END DO 69 69 CALL wrk_dealloc( jpi, jpj, jpk, ztrmyt ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zbio.F90
r4624 r4946 21 21 USE lbclnk ! 22 22 USE prtctl_trc ! Print control for debbuging 23 USE trd mod_oce24 USE trd mod_trc23 USE trd_oce 24 USE trdtrc 25 25 USE iom 26 26 … … 457 457 IF( l_trdtrc ) THEN 458 458 DO jl = jp_pcs0_trd, jp_pcs1_trd 459 CALL trd_ mod_trc( trbio(:,:,:,jl), jl, kt ) ! handle the trend459 CALL trd_trc( trbio(:,:,:,jl), jl, kt ) ! handle the trend 460 460 END DO 461 461 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zexp.F90
r3446 r4946 22 22 USE lbclnk 23 23 USE prtctl_trc ! Print control for debbuging 24 USE trd mod_oce25 USE trd mod_trc24 USE trd_oce 25 USE trdtrc 26 26 USE iom 27 27 … … 164 164 ztrbio(:,:,:) = tra(:,:,:,jpno3) - ztrbio(:,:,:) 165 165 jl = jp_pcs0_trd + 16 166 CALL trd_ mod_trc( ztrbio, jl, kt ) ! handle the trend166 CALL trd_trc( ztrbio, jl, kt ) ! handle the trend 167 167 CALL wrk_dealloc( jpi, jpj, jpk, ztrbio ) ! temporary save of trends 168 168 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zopt.F90
r4624 r4946 128 128 IF( etot(ji,jj,jk) >= zpar100(ji,jj) ) neln(ji,jj) = jk + 1 129 129 ! ! nb. this is to ensure compatibility with 130 ! ! nmld_trc definition in trd_m ld_trc_zint130 ! ! nmld_trc definition in trd_mxl_trc_zint 131 131 END DO 132 132 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsed.F90
r4624 r4946 18 18 USE sms_pisces 19 19 USE lbclnk 20 USE trd mod_oce21 USE trd mod_trc20 USE trd_oce 21 USE trdtrc 22 22 USE iom 23 23 USE prtctl_trc ! Print control for debbuging … … 128 128 ztrbio(:,:,:) = tra(:,:,:,jpdet) - ztrbio(:,:,:) 129 129 jl = jp_pcs0_trd + 7 130 CALL trd_ mod_trc( ztrbio, jl, kt ) ! handle the trend130 CALL trd_trc( ztrbio, jl, kt ) ! handle the trend 131 131 CALL wrk_dealloc( jpi, jpj, jpk, ztrbio ) 132 132 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsms.F90
r4624 r4946 20 20 USE p2zsed 21 21 USE p2zexp 22 USE trd mod_oce23 USE trd mod_trc_oce24 USE trd mod_trc25 USE trdm ld_trc22 USE trd_oce 23 USE trdtrc_oce 24 USE trdtrc 25 USE trdmxl_trc 26 26 27 27 IMPLICIT NONE … … 61 61 IF( l_trdtrc ) THEN 62 62 DO jn = jp_pcs0, jp_pcs1 63 CALL trd_ mod_trc( tra(:,:,:,jn), jn, jptra_trd_sms, kt ) ! save trends63 CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends 64 64 END DO 65 65 END IF 66 66 67 IF( lk_trdm ld_trc ) CALL trd_mld_bio( kt ) ! trends: Mixed-layer67 IF( lk_trdmxl_trc ) CALL trd_mxl_bio( kt ) ! trends: Mixed-layer 68 68 ! 69 69 IF ( lwm .AND. kt == nittrc000 ) CALL FLUSH ( numonp ) ! flush output namelist PISCES -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r4624 r4946 205 205 IF( etot(ji,jj,jk) * tmask(ji,jj,jk) >= 0.0043 * qsr(ji,jj) ) THEN 206 206 neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer 207 ! ! nb: ensure the compatibility with nmld_trc definition in trd_m ld_trc_zint207 ! ! nb: ensure the compatibility with nmld_trc definition in trd_mxl_trc_zint 208 208 heup(ji,jj) = fsdepw(ji,jj,jk+1) ! Euphotic layer depth 209 209 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90
r4624 r4946 11 11 !! 'key_pisces' PISCES bio-model 12 12 !!---------------------------------------------------------------------- 13 !! p4zsms : Time loop of passive tracers sms13 !! p4zsms : Time loop of passive tracers sms 14 14 !!---------------------------------------------------------------------- 15 15 USE oce_trc ! shared variables between ocean and passive tracers … … 25 25 USE p4zint ! time interpolation 26 26 USE iom ! I/O manager 27 USE trd mod_oce! Ocean trends variables28 USE trd mod_trc! TOP trends variables27 USE trd_oce ! Ocean trends variables 28 USE trdtrc ! TOP trends variables 29 29 USE sedmodel ! Sediment model 30 30 USE prtctl_trc ! print control for debugging … … 33 33 PRIVATE 34 34 35 PUBLIC p4z_sms_init 36 PUBLIC p4z_sms ! called in p4zsms.F9035 PUBLIC p4z_sms_init ! called in p4zsms.F90 36 PUBLIC p4z_sms ! called in p4zsms.F90 37 37 38 38 REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget … … 146 146 jl = jn + jp_pcs0 - 1 147 147 ztrdpis(:,:,:,jn) = ztrdpis(:,:,:,jn) + tra(:,:,:,jl) 148 CALL trd_ mod_trc( ztrdpis(:,:,:,jn), jn, jptra_trd_sms, kt ) ! save trends148 CALL trd_trc( ztrdpis(:,:,:,jn), jn, jptra_sms, kt ) ! save trends 149 149 END DO 150 150 CALL wrk_dealloc( jpi, jpj, jpk, jp_pisces, ztrdpis ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/PISCES/trcnam_pisces.F90
r4624 r4946 19 19 USE trc ! TOP variables 20 20 USE sms_pisces ! sms trends 21 USE trd mod_trc_oce21 USE trdtrc_oce 22 22 USE iom ! I/O manager 23 23 … … 123 123 #if defined key_pisces_reduced 124 124 125 IF( ( .NOT.lk_iomput .AND. ln_diabio ) .OR. lk_trdm ld_trc ) THEN125 IF( ( .NOT.lk_iomput .AND. ln_diabio ) .OR. lk_trdmxl_trc ) THEN 126 126 ! 127 127 ! Namelist nampisdbi -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcbbl.F90
r4513 r4946 25 25 USE trabbl ! 26 26 USE prtctl_trc ! Print control for debbuging 27 USE trd mod_oce27 USE trd_oce 28 28 USE trdtra 29 29 … … 93 93 DO jn = 1, jptra 94 94 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) 95 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_bbl, ztrtrd(:,:,:,jn) )95 CALL trd_tra( kt, 'TRC', jn, jptra_bbl, ztrtrd(:,:,:,jn) ) 96 96 END DO 97 97 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) ! temporary save of trends -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r4359 r4946 23 23 USE prtctl_trc ! Print control for debbuging 24 24 USE trdtra 25 USE trd mod_oce25 USE trd_oce 26 26 27 27 IMPLICIT NONE … … 75 75 !! ** Action : - update the tracer trends tra with the newtonian 76 76 !! damping trends. 77 !! - save the trends ('key_trdm ld_trc')77 !! - save the trends ('key_trdmxl_trc') 78 78 !!---------------------------------------------------------------------- 79 79 !! … … 151 151 IF( l_trdtrc ) THEN 152 152 ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) 153 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_dmp, ztrtrd )153 CALL trd_tra( kt, 'TRC', jn, jptra_dmp, ztrtrd ) 154 154 END IF 155 155 ! ! =========== -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90
r4812 r4946 25 25 USE traldf_iso_grif ! lateral mixing (tra_ldf_iso_grif routine) 26 26 USE traldf_lap ! lateral mixing (tra_ldf_lap routine) 27 USE trd mod_oce27 USE trd_oce 28 28 USE trdtra 29 29 USE prtctl_trc ! Print control … … 105 105 DO jn = 1, jptra 106 106 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) 107 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_ldf, ztrtrd(:,:,:,jn) )107 CALL trd_tra( kt, 'TRC', jn, jptra_ldf, ztrtrd(:,:,:,jn) ) 108 108 END DO 109 109 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90
r4611 r4946 30 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 31 USE prtctl_trc ! Print control for debbuging 32 USE trd mod_oce32 USE trd_oce 33 33 USE trdtra 34 34 USE tranxt … … 148 148 zfact = 1.e0 / r2dt(jk) 149 149 ztrdt(:,:,jk,jn) = ( trb(:,:,jk,jn) - ztrdt(:,:,jk,jn) ) * zfact 150 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_atf, ztrdt )150 CALL trd_tra( kt, 'TRC', jn, jptra_atf, ztrdt ) 151 151 END DO 152 152 END DO -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcrad.F90
r3680 r4946 15 15 USE oce_trc ! ocean dynamics and tracers variables 16 16 USE trc ! ocean passive tracers variables 17 USE trd mod_oce17 USE trd_oce 18 18 USE trdtra 19 19 USE prtctl_trc ! Print control for debbuging … … 156 156 ztrtrdb(:,:,:) = ( ptrb(:,:,:,jn) - ztrtrdb(:,:,:) ) * zs2rdt 157 157 ztrtrdn(:,:,:) = ( ptrn(:,:,:,jn) - ztrtrdn(:,:,:) ) * zs2rdt 158 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_radb, ztrtrdb ) ! Asselin-like trend handling159 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_radn, ztrtrdn ) ! standard trend handling158 CALL trd_tra( kt, 'TRC', jn, jptra_radb, ztrtrdb ) ! Asselin-like trend handling 159 CALL trd_tra( kt, 'TRC', jn, jptra_radn, ztrtrdn ) ! standard trend handling 160 160 ! 161 161 ENDIF … … 187 187 ztrtrdb(:,:,:) = ( ptrb(:,:,:,jn) - ztrtrdb(:,:,:) ) * zs2rdt 188 188 ztrtrdn(:,:,:) = ( ptrn(:,:,:,jn) - ztrtrdn(:,:,:) ) * zs2rdt 189 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_radb, ztrtrdb ) ! Asselin-like trend handling190 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_radn, ztrtrdn ) ! standard trend handling189 CALL trd_tra( kt, 'TRC', jn, jptra_radb, ztrtrdb ) ! Asselin-like trend handling 190 CALL trd_tra( kt, 'TRC', jn, jptra_radn, ztrtrdn ) ! standard trend handling 191 191 ! 192 192 ENDIF -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r3719 r4946 19 19 USE trc ! ocean passive tracers variables 20 20 USE prtctl_trc ! Print control for debbuging 21 USE trd mod_oce21 USE trd_oce 22 22 USE trdtra 23 23 … … 104 104 IF( l_trdtrc ) THEN 105 105 ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) 106 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_nsr, ztrtrd )106 CALL trd_tra( kt, 'TRC', jn, jptra_nsr, ztrtrd ) 107 107 END IF 108 108 ! ! =========== -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/TRP/trczdf.F90
r3680 r4946 19 19 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 20 20 USE trazdf_imp ! vertical diffusion: implicit (tra_zdf_imp routine) 21 USE trd mod_oce21 USE trd_oce 22 22 USE trdtra 23 23 USE prtctl_trc ! Print control … … 106 106 ztrtrd(:,:,jk,jn) = ( ( tra(:,:,jk,jn) - trb(:,:,jk,jn) ) / r2dt(jk) ) - ztrtrd(:,:,jk,jn) 107 107 END DO 108 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_zdf, ztrtrd(:,:,:,jn) )108 CALL trd_tra( kt, 'TRC', jn, jptra_zdf, ztrtrd(:,:,:,jn) ) 109 109 END DO 110 110 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r4610 r4946 66 66 USE oce , ONLY : rhop => rhop !: potential volumic mass (kg m-3) 67 67 USE oce , ONLY : rhd => rhd !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 68 #if defined key_offline 69 USE oce , ONLY : rab_n => rab_n !: local thermal/haline expension ratio at T-points 70 #endif 68 71 USE oce , ONLY : hdivn => hdivn !: horizontal divergence (1/s) 69 72 USE oce , ONLY : rotn => rotn !: relative vorticity [s-1] -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r4812 r4946 191 191 USE trcnxt , ONLY: trc_nxt_alloc 192 192 USE trczdf , ONLY: trc_zdf_alloc 193 USE trd mod_trc_oce, ONLY: trd_mod_trc_oce_alloc194 #if defined key_trdm ld_trc195 USE trdm ld_trc , ONLY: trd_mld_trc_alloc193 USE trdtrc_oce , ONLY: trd_trc_oce_alloc 194 #if defined key_trdmxl_trc 195 USE trdmxl_trc , ONLY: trd_mxl_trc_alloc 196 196 #endif 197 197 ! … … 203 203 ierr = ierr + trc_nxt_alloc() 204 204 ierr = ierr + trc_zdf_alloc() 205 ierr = ierr + trd_ mod_trc_oce_alloc()206 #if defined key_trdm ld_trc207 ierr = ierr + trd_m ld_trc_alloc()205 ierr = ierr + trd_trc_oce_alloc() 206 #if defined key_trdmxl_trc 207 ierr = ierr + trd_mxl_trc_alloc() 208 208 #endif 209 209 ! -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/trcnam.F90
r4624 r4946 25 25 USE trcnam_c14b ! C14 SMS namelist 26 26 USE trcnam_my_trc ! MY_TRC SMS namelist 27 USE trd mod_oce28 USE trd mod_trc_oce27 USE trd_oce 28 USE trdtrc_oce 29 29 USE iom ! I/O manager 30 30 … … 119 119 120 120 121 #if defined key_trdm ld_trc || defined key_trdtrc121 #if defined key_trdmxl_trc || defined key_trdtrc 122 122 123 123 REWIND( numnat_ref ) ! Namelist namtrc_trd in reference namelist : Passive tracer trends … … 132 132 IF(lwp) THEN 133 133 WRITE(numout,*) 134 WRITE(numout,*) ' trd_m ld_trc_init : read namelist namtrc_trd '134 WRITE(numout,*) ' trd_mxl_trc_init : read namelist namtrc_trd ' 135 135 WRITE(numout,*) ' ~~~~~~~~~~~~~~~~ ' 136 136 WRITE(numout,*) ' * frequency of trends diagnostics nn_trd_trc = ', nn_trd_trc 137 137 WRITE(numout,*) ' * control surface type nn_ctls_trc = ', nn_ctls_trc 138 WRITE(numout,*) ' * restart for ML diagnostics ln_trdm ld_trc_restart = ', ln_trdmld_trc_restart138 WRITE(numout,*) ' * restart for ML diagnostics ln_trdmxl_trc_restart = ', ln_trdmxl_trc_restart 139 139 WRITE(numout,*) ' * flag to diagnose trends of ' 140 WRITE(numout,*) ' instantantaneous or mean ML T/S ln_trdm ld_trc_instant = ', ln_trdmld_trc_instant140 WRITE(numout,*) ' instantantaneous or mean ML T/S ln_trdmxl_trc_instant = ', ln_trdmxl_trc_instant 141 141 WRITE(numout,*) ' * unit conversion factor rn_ucf_trc = ', rn_ucf_trc 142 142 DO jn = 1, jptra … … 266 266 !!--------------------------------------------------------------------- 267 267 INTEGER :: ierr 268 #if defined key_trdm ld_trc || defined key_trdtrc268 #if defined key_trdmxl_trc || defined key_trdtrc 269 269 NAMELIST/namtrc_trd/ nn_trd_trc, nn_ctls_trc, rn_ucf_trc, & 270 & ln_trdm ld_trc_restart, ln_trdmld_trc_instant, &270 & ln_trdmxl_trc_restart, ln_trdmxl_trc_instant, & 271 271 & cn_trdrst_trc_in, cn_trdrst_trc_out, ln_trdtrc 272 272 #endif -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/trcrst.F90
r4152 r4946 137 137 CALL trc_rst_stat ! statistics 138 138 CALL iom_close( numrtw ) ! close the restart file (only at last time step) 139 #if ! defined key_trdm ld_trc139 #if ! defined key_trdmxl_trc 140 140 lrst_trc = .FALSE. 141 141 #endif -
branches/2014/dev_MERGE_2014/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r4624 r4946 19 19 USE trcwri 20 20 USE trcrst 21 USE trd mod_trc_oce22 USE trdm ld_trc21 USE trdtrc_oce 22 USE trdmxl_trc 23 23 USE iom 24 24 USE in_out_manager … … 59 59 IF( nn_timing == 1 ) CALL timing_start('trc_stp') 60 60 ! 61 IF( kt == nittrc000 .AND. lk_trdm ld_trc ) CALL trd_mld_trc_init ! trends: Mixed-layer61 IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer 62 62 ! 63 63 IF( lk_vvl ) THEN ! update ocean volume due to ssh temporal evolution … … 100 100 ENDIF 101 101 IF( lrst_trc ) CALL trc_rst_wri ( kt ) ! write tracer restart file 102 IF( lk_trdm ld_trc ) CALL trd_mld_trc ( kt ) ! trends: Mixed-layer102 IF( lk_trdmxl_trc ) CALL trd_mxl_trc ( kt ) ! trends: Mixed-layer 103 103 ! 104 104 IF( nn_dttrc /= 1 ) CALL trc_sub_reset( kt ) ! resetting physical variables when sub-stepping
Note: See TracChangeset
for help on using the changeset viewer.