Changeset 7806
- Timestamp:
- 2017-03-17T08:46:30+01:00 (7 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
- Files:
-
- 75 edited
- 2 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r7256 r7806 212 212 REAL(wp), PUBLIC :: rn_betas !: coef. for partitioning of snowfall between leads and sea ice 213 213 REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 214 REAL(wp), PUBLIC :: rn_cdsn !: thermal conductivity of the snow [W/m/K] 214 215 REAL(wp), PUBLIC :: nn_conv_dif !: maximal number of iterations for heat diffusion 215 216 REAL(wp), PUBLIC :: rn_terr_dif !: maximal tolerated error (C) for heat diffusion … … 320 321 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (days) 321 322 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (days) 323 322 324 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume 323 325 … … 406 408 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s] 407 409 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] 410 408 411 ! 409 412 !!---------------------------------------------------------------------- … … 463 466 & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i (jpi,jpj) , bvm_i(jpi,jpj) , & 464 467 & smt_i(jpi,jpj) , tm_su(jpi,jpj) , htm_i(jpi,jpj) , htm_s(jpi,jpj) , & 465 & om_i (jpi,jpj) 468 & om_i (jpi,jpj) , STAT=ierr(ii) ) 466 469 ii = ii + 1 467 470 ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limdyn.F90
r5602 r7806 244 244 INTEGER :: ios ! Local integer output status for namelist read 245 245 NAMELIST/namicedyn/ nn_icestr, ln_icestr_bvf, rn_pe_rdg, rn_pstar, rn_crhg, rn_cio, rn_creepl, rn_ecc, & 246 & nn_nevp, rn_relast, nn_ahi0, rn_ahi0_ref 247 INTEGER :: ji, jj 248 REAL(wp) :: za00, zd_max 246 & nn_nevp, rn_relast 249 247 !!------------------------------------------------------------------- 250 248 … … 272 270 WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp 273 271 WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast 274 WRITE(numout,*) ' horizontal diffusivity calculation nn_ahi0 = ', nn_ahi0275 WRITE(numout,*) ' horizontal diffusivity coeff. (orca2 grid) rn_ahi0_ref = ', rn_ahi0_ref276 272 ENDIF 277 273 ! … … 279 275 rhoco = rau0 * rn_cio 280 276 ! 281 ! Diffusion coefficients282 SELECT CASE( nn_ahi0 )283 284 CASE( 0 )285 ahiu(:,:) = rn_ahi0_ref286 ahiv(:,:) = rn_ahi0_ref287 288 IF(lwp) WRITE(numout,*) ''289 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim constant = rn_ahi0_ref'290 291 CASE( 1 )292 293 zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) )294 IF( lk_mpp ) CALL mpp_max( zd_max ) ! max over the global domain295 296 ahiu(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp ! 1.e05 = 100km = max grid space at 60° latitude in orca2297 ! (60° = min latitude for ice cover)298 ahiv(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp299 300 IF(lwp) WRITE(numout,*) ''301 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim proportional to max of e1 e2 over the domain (', zd_max, ')'302 IF(lwp) WRITE(numout,*) ' value for ahim = ', rn_ahi0_ref * zd_max * 1.e-05_wp303 304 CASE( 2 )305 306 zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) )307 IF( lk_mpp ) CALL mpp_max( zd_max ) ! max over the global domain308 309 za00 = rn_ahi0_ref * 1.e-05_wp ! 1.e05 = 100km = max grid space at 60° latitude in orca2310 ! (60° = min latitude for ice cover)311 DO jj = 1, jpj312 DO ji = 1, jpi313 ahiu(ji,jj) = za00 * MAX( e1t(ji,jj), e2t(ji,jj) ) * umask(ji,jj,1)314 ahiv(ji,jj) = za00 * MAX( e1f(ji,jj), e2f(ji,jj) ) * vmask(ji,jj,1)315 END DO316 END DO317 !318 IF(lwp) WRITE(numout,*) ''319 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim proportional to e1'320 IF(lwp) WRITE(numout,*) ' maximum grid-spacing = ', zd_max, ' maximum value for ahim = ', za00*zd_max321 322 END SELECT323 324 277 END SUBROUTINE lim_dyn_init 325 278 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90
r7256 r7806 202 202 ! ----------------------- 203 203 204 IF(ln_ctl) THEN205 DO jk = 1 , isize206 zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk)207 WRITE(charout,FMT="(' lim_hdf : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter208 CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout )209 END DO210 ENDIF204 ! IF(ln_ctl) THEN 205 ! DO jk = 1 , isize 206 ! zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 207 ! WRITE(charout,FMT="('lim_hdf : zconv =',D23.16, ' iter =',I4)") zconv, iter 208 ! CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 209 ! END DO 210 ! ENDIF 211 211 ! 212 212 CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) … … 233 233 !!------------------------------------------------------------------- 234 234 INTEGER :: ios ! Local integer output status for namelist read 235 NAMELIST/namicehdf/ nn_convfrq 236 !!------------------------------------------------------------------- 237 ! 238 IF(lwp) THEN 239 WRITE(numout,*) 240 WRITE(numout,*) 'lim_hdf : Ice horizontal diffusion' 241 WRITE(numout,*) '~~~~~~~' 242 ENDIF 235 NAMELIST/namicehdf/ nn_ahi0, rn_ahi0_ref, nn_convfrq 236 INTEGER :: ji, jj 237 REAL(wp) :: za00, zd_max 238 !!------------------------------------------------------------------- 243 239 ! 244 240 REWIND( numnam_ice_ref ) ! Namelist namicehdf in reference namelist : Ice horizontal diffusion … … 253 249 IF(lwp) THEN ! control print 254 250 WRITE(numout,*) 255 WRITE(numout,*)' Namelist of ice parameters for ice horizontal diffusion computation ' 256 WRITE(numout,*)' convergence check frequency of the Crant-Nicholson scheme nn_convfrq = ', nn_convfrq 251 WRITE(numout,*) 'lim_hdf_init : Ice horizontal diffusion' 252 WRITE(numout,*) '~~~~~~~~~~~' 253 WRITE(numout,*) ' horizontal diffusivity calculation nn_ahi0 = ', nn_ahi0 254 WRITE(numout,*) ' horizontal diffusivity coeff. (orca2 grid) rn_ahi0_ref = ', rn_ahi0_ref 255 WRITE(numout,*) ' convergence check frequency of the Crant-Nicholson scheme nn_convfrq = ', nn_convfrq 257 256 ENDIF 257 ! 258 ! Diffusion coefficients 259 SELECT CASE( nn_ahi0 ) 260 261 CASE( -1 ) 262 ahiu(:,:) = 0._wp 263 ahiv(:,:) = 0._wp 264 265 IF(lwp) WRITE(numout,*) '' 266 IF(lwp) WRITE(numout,*) ' No sea-ice diffusion applied' 267 268 CASE( 0 ) 269 ahiu(:,:) = rn_ahi0_ref 270 ahiv(:,:) = rn_ahi0_ref 271 272 IF(lwp) WRITE(numout,*) '' 273 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim constant = rn_ahi0_ref' 274 275 CASE( 1 ) 276 277 zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 278 IF( lk_mpp ) CALL mpp_max( zd_max ) ! max over the global domain 279 280 ahiu(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp ! 1.e05 = 100km = max grid space at 60deg latitude in orca2 281 ! (60deg = min latitude for ice cover) 282 ahiv(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp 283 284 IF(lwp) WRITE(numout,*) '' 285 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim proportional to max of e1 e2 over the domain (', zd_max, ')' 286 IF(lwp) WRITE(numout,*) ' value for ahim = ', rn_ahi0_ref * zd_max * 1.e-05_wp 287 288 CASE( 2 ) 289 290 zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 291 IF( lk_mpp ) CALL mpp_max( zd_max ) ! max over the global domain 292 293 za00 = rn_ahi0_ref * 1.e-05_wp ! 1.e05 = 100km = max grid space at 60deg latitude in orca2 294 ! (60deg = min latitude for ice cover) 295 DO jj = 1, jpj 296 DO ji = 1, jpi 297 ahiu(ji,jj) = za00 * MAX( e1t(ji,jj), e2t(ji,jj) ) * umask(ji,jj,1) 298 ahiv(ji,jj) = za00 * MAX( e1f(ji,jj), e2f(ji,jj) ) * vmask(ji,jj,1) 299 END DO 300 END DO 301 ! 302 IF(lwp) WRITE(numout,*) '' 303 IF(lwp) WRITE(numout,*) ' laplacian operator: ahim proportional to e1' 304 IF(lwp) WRITE(numout,*) ' maximum grid-spacing = ', zd_max, ' maximum value for ahim = ', za00*zd_max 305 306 END SELECT 258 307 ! 259 308 END SUBROUTINE lim_hdf_init -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limrst.F90
r5602 r7806 108 108 INTEGER :: iter 109 109 CHARACTER(len=15) :: znam 110 CHARACTER(len= 1) :: zchar, zchar1110 CHARACTER(len=2) :: zchar, zchar1 111 111 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 112 112 !!---------------------------------------------------------------------- … … 130 130 ! Prognostic variables 131 131 DO jl = 1, jpl 132 WRITE(zchar,'(I 1)') jl133 znam = 'v_i'//'_htc'// zchar132 WRITE(zchar,'(I2)') jl 133 znam = 'v_i'//'_htc'//TRIM(ADJUSTL(zchar)) 134 134 z2d(:,:) = v_i(:,:,jl) 135 135 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 136 znam = 'v_s'//'_htc'// zchar136 znam = 'v_s'//'_htc'//TRIM(ADJUSTL(zchar)) 137 137 z2d(:,:) = v_s(:,:,jl) 138 138 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 139 znam = 'smv_i'//'_htc'// zchar139 znam = 'smv_i'//'_htc'//TRIM(ADJUSTL(zchar)) 140 140 z2d(:,:) = smv_i(:,:,jl) 141 141 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 142 znam = 'oa_i'//'_htc'// zchar142 znam = 'oa_i'//'_htc'//TRIM(ADJUSTL(zchar)) 143 143 z2d(:,:) = oa_i(:,:,jl) 144 144 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 145 znam = 'a_i'//'_htc'// zchar145 znam = 'a_i'//'_htc'//TRIM(ADJUSTL(zchar)) 146 146 z2d(:,:) = a_i(:,:,jl) 147 147 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 148 znam = 't_su'//'_htc'// zchar148 znam = 't_su'//'_htc'//TRIM(ADJUSTL(zchar)) 149 149 z2d(:,:) = t_su(:,:,jl) 150 150 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 151 END DO 152 153 DO jl = 1, jpl 154 WRITE(zchar,'(I1)') jl 155 znam = 'tempt_sl1'//'_htc'//zchar 151 znam = 'tempt_sl1'//'_htc'//TRIM(ADJUSTL(zchar)) 156 152 z2d(:,:) = e_s(:,:,1,jl) 157 153 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 158 END DO159 160 DO jl = 1, jpl161 WRITE(zchar,'(I1)') jl162 154 DO jk = 1, nlay_i 163 WRITE(zchar1,'(I 1)') jk164 znam = 'tempt'//'_il'// zchar1//'_htc'//zchar155 WRITE(zchar1,'(I2)') jk 156 znam = 'tempt'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 165 157 z2d(:,:) = e_i(:,:,jk,jl) 166 158 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) … … 177 169 178 170 DO jl = 1, jpl 179 WRITE(zchar,'(I 1)') jl180 znam = 'sxice'//'_htc'// zchar171 WRITE(zchar,'(I2)') jl 172 znam = 'sxice'//'_htc'//TRIM(ADJUSTL(zchar)) 181 173 z2d(:,:) = sxice(:,:,jl) 182 174 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 183 znam = 'syice'//'_htc'// zchar175 znam = 'syice'//'_htc'//TRIM(ADJUSTL(zchar)) 184 176 z2d(:,:) = syice(:,:,jl) 185 177 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 186 znam = 'sxxice'//'_htc'// zchar178 znam = 'sxxice'//'_htc'//TRIM(ADJUSTL(zchar)) 187 179 z2d(:,:) = sxxice(:,:,jl) 188 180 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 189 znam = 'syyice'//'_htc'// zchar181 znam = 'syyice'//'_htc'//TRIM(ADJUSTL(zchar)) 190 182 z2d(:,:) = syyice(:,:,jl) 191 183 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 192 znam = 'sxyice'//'_htc'// zchar184 znam = 'sxyice'//'_htc'//TRIM(ADJUSTL(zchar)) 193 185 z2d(:,:) = sxyice(:,:,jl) 194 186 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 195 znam = 'sxsn'//'_htc'// zchar187 znam = 'sxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 196 188 z2d(:,:) = sxsn(:,:,jl) 197 189 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 198 znam = 'sysn'//'_htc'// zchar190 znam = 'sysn'//'_htc'//TRIM(ADJUSTL(zchar)) 199 191 z2d(:,:) = sysn(:,:,jl) 200 192 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 201 znam = 'sxxsn'//'_htc'// zchar193 znam = 'sxxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 202 194 z2d(:,:) = sxxsn(:,:,jl) 203 195 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 204 znam = 'syysn'//'_htc'// zchar196 znam = 'syysn'//'_htc'//TRIM(ADJUSTL(zchar)) 205 197 z2d(:,:) = syysn(:,:,jl) 206 198 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 207 znam = 'sxysn'//'_htc'// zchar199 znam = 'sxysn'//'_htc'//TRIM(ADJUSTL(zchar)) 208 200 z2d(:,:) = sxysn(:,:,jl) 209 201 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 210 znam = 'sxa'//'_htc'// zchar202 znam = 'sxa'//'_htc'//TRIM(ADJUSTL(zchar)) 211 203 z2d(:,:) = sxa(:,:,jl) 212 204 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 213 znam = 'sya'//'_htc'// zchar205 znam = 'sya'//'_htc'//TRIM(ADJUSTL(zchar)) 214 206 z2d(:,:) = sya(:,:,jl) 215 207 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 216 znam = 'sxxa'//'_htc'// zchar208 znam = 'sxxa'//'_htc'//TRIM(ADJUSTL(zchar)) 217 209 z2d(:,:) = sxxa(:,:,jl) 218 210 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 219 znam = 'syya'//'_htc'// zchar211 znam = 'syya'//'_htc'//TRIM(ADJUSTL(zchar)) 220 212 z2d(:,:) = syya(:,:,jl) 221 213 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 222 znam = 'sxya'//'_htc'// zchar214 znam = 'sxya'//'_htc'//TRIM(ADJUSTL(zchar)) 223 215 z2d(:,:) = sxya(:,:,jl) 224 216 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 225 znam = 'sxc0'//'_htc'// zchar217 znam = 'sxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 226 218 z2d(:,:) = sxc0(:,:,jl) 227 219 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 228 znam = 'syc0'//'_htc'// zchar220 znam = 'syc0'//'_htc'//TRIM(ADJUSTL(zchar)) 229 221 z2d(:,:) = syc0(:,:,jl) 230 222 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 231 znam = 'sxxc0'//'_htc'// zchar223 znam = 'sxxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 232 224 z2d(:,:) = sxxc0(:,:,jl) 233 225 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 234 znam = 'syyc0'//'_htc'// zchar226 znam = 'syyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 235 227 z2d(:,:) = syyc0(:,:,jl) 236 228 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 237 znam = 'sxyc0'//'_htc'// zchar229 znam = 'sxyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 238 230 z2d(:,:) = sxyc0(:,:,jl) 239 231 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 240 znam = 'sxsal'//'_htc'// zchar232 znam = 'sxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 241 233 z2d(:,:) = sxsal(:,:,jl) 242 234 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 243 znam = 'sysal'//'_htc'// zchar235 znam = 'sysal'//'_htc'//TRIM(ADJUSTL(zchar)) 244 236 z2d(:,:) = sysal(:,:,jl) 245 237 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 246 znam = 'sxxsal'//'_htc'// zchar238 znam = 'sxxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 247 239 z2d(:,:) = sxxsal(:,:,jl) 248 240 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 249 znam = 'syysal'//'_htc'// zchar241 znam = 'syysal'//'_htc'//TRIM(ADJUSTL(zchar)) 250 242 z2d(:,:) = syysal(:,:,jl) 251 243 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 252 znam = 'sxysal'//'_htc'// zchar244 znam = 'sxysal'//'_htc'//TRIM(ADJUSTL(zchar)) 253 245 z2d(:,:) = sxysal(:,:,jl) 254 246 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 255 znam = 'sxage'//'_htc'// zchar247 znam = 'sxage'//'_htc'//TRIM(ADJUSTL(zchar)) 256 248 z2d(:,:) = sxage(:,:,jl) 257 249 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 258 znam = 'syage'//'_htc'// zchar250 znam = 'syage'//'_htc'//TRIM(ADJUSTL(zchar)) 259 251 z2d(:,:) = syage(:,:,jl) 260 252 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 261 znam = 'sxxage'//'_htc'// zchar253 znam = 'sxxage'//'_htc'//TRIM(ADJUSTL(zchar)) 262 254 z2d(:,:) = sxxage(:,:,jl) 263 255 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 264 znam = 'syyage'//'_htc'// zchar256 znam = 'syyage'//'_htc'//TRIM(ADJUSTL(zchar)) 265 257 z2d(:,:) = syyage(:,:,jl) 266 258 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 267 znam = 'sxyage'//'_htc'// zchar259 znam = 'sxyage'//'_htc'//TRIM(ADJUSTL(zchar)) 268 260 z2d(:,:) = sxyage(:,:,jl) 269 261 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) … … 277 269 278 270 DO jl = 1, jpl 279 WRITE(zchar,'(I 1)') jl271 WRITE(zchar,'(I2)') jl 280 272 DO jk = 1, nlay_i 281 WRITE(zchar1,'(I 1)') jk282 znam = 'sxe'//'_il'// zchar1//'_htc'//zchar273 WRITE(zchar1,'(I2)') jk 274 znam = 'sxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 283 275 z2d(:,:) = sxe(:,:,jk,jl) 284 276 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 285 znam = 'sye'//'_il'// zchar1//'_htc'//zchar277 znam = 'sye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 286 278 z2d(:,:) = sye(:,:,jk,jl) 287 279 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 288 znam = 'sxxe'//'_il'// zchar1//'_htc'//zchar280 znam = 'sxxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 289 281 z2d(:,:) = sxxe(:,:,jk,jl) 290 282 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 291 znam = 'syye'//'_il'// zchar1//'_htc'//zchar283 znam = 'syye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 292 284 z2d(:,:) = syye(:,:,jk,jl) 293 285 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 294 znam = 'sxye'//'_il'// zchar1//'_htc'//zchar286 znam = 'sxye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 295 287 z2d(:,:) = sxye(:,:,jk,jl) 296 288 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) … … 318 310 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 319 311 CHARACTER(len=15) :: znam 320 CHARACTER(len= 1) :: zchar, zchar1312 CHARACTER(len=2) :: zchar, zchar1 321 313 INTEGER :: jlibalt = jprstlib 322 314 LOGICAL :: llok … … 357 349 358 350 DO jl = 1, jpl 359 WRITE(zchar,'(I 1)') jl360 znam = 'v_i'//'_htc'// zchar351 WRITE(zchar,'(I2)') jl 352 znam = 'v_i'//'_htc'//TRIM(ADJUSTL(zchar)) 361 353 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 362 354 v_i(:,:,jl) = z2d(:,:) 363 znam = 'v_s'//'_htc'// zchar355 znam = 'v_s'//'_htc'//TRIM(ADJUSTL(zchar)) 364 356 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 365 357 v_s(:,:,jl) = z2d(:,:) 366 znam = 'smv_i'//'_htc'// zchar358 znam = 'smv_i'//'_htc'//TRIM(ADJUSTL(zchar)) 367 359 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 368 360 smv_i(:,:,jl) = z2d(:,:) 369 znam = 'oa_i'//'_htc'// zchar361 znam = 'oa_i'//'_htc'//TRIM(ADJUSTL(zchar)) 370 362 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 371 363 oa_i(:,:,jl) = z2d(:,:) 372 znam = 'a_i'//'_htc'// zchar364 znam = 'a_i'//'_htc'//TRIM(ADJUSTL(zchar)) 373 365 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 374 366 a_i(:,:,jl) = z2d(:,:) 375 znam = 't_su'//'_htc'// zchar367 znam = 't_su'//'_htc'//TRIM(ADJUSTL(zchar)) 376 368 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 377 369 t_su(:,:,jl) = z2d(:,:) 378 END DO 379 380 DO jl = 1, jpl 381 WRITE(zchar,'(I1)') jl 382 znam = 'tempt_sl1'//'_htc'//zchar 370 znam = 'tempt_sl1'//'_htc'//TRIM(ADJUSTL(zchar)) 383 371 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 384 372 e_s(:,:,1,jl) = z2d(:,:) 385 END DO386 387 DO jl = 1, jpl388 WRITE(zchar,'(I1)') jl389 373 DO jk = 1, nlay_i 390 WRITE(zchar1,'(I 1)') jk391 znam = 'tempt'//'_il'// zchar1//'_htc'//zchar374 WRITE(zchar1,'(I2)') jk 375 znam = 'tempt'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 392 376 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 393 377 e_i(:,:,jk,jl) = z2d(:,:) … … 404 388 405 389 DO jl = 1, jpl 406 WRITE(zchar,'(I 1)') jl407 znam = 'sxice'//'_htc'// zchar390 WRITE(zchar,'(I2)') jl 391 znam = 'sxice'//'_htc'//TRIM(ADJUSTL(zchar)) 408 392 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 409 393 sxice(:,:,jl) = z2d(:,:) 410 znam = 'syice'//'_htc'// zchar394 znam = 'syice'//'_htc'//TRIM(ADJUSTL(zchar)) 411 395 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 412 396 syice(:,:,jl) = z2d(:,:) 413 znam = 'sxxice'//'_htc'// zchar397 znam = 'sxxice'//'_htc'//TRIM(ADJUSTL(zchar)) 414 398 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 415 399 sxxice(:,:,jl) = z2d(:,:) 416 znam = 'syyice'//'_htc'// zchar400 znam = 'syyice'//'_htc'//TRIM(ADJUSTL(zchar)) 417 401 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 418 402 syyice(:,:,jl) = z2d(:,:) 419 znam = 'sxyice'//'_htc'// zchar403 znam = 'sxyice'//'_htc'//TRIM(ADJUSTL(zchar)) 420 404 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 421 405 sxyice(:,:,jl) = z2d(:,:) 422 znam = 'sxsn'//'_htc'// zchar406 znam = 'sxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 423 407 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 424 408 sxsn(:,:,jl) = z2d(:,:) 425 znam = 'sysn'//'_htc'// zchar409 znam = 'sysn'//'_htc'//TRIM(ADJUSTL(zchar)) 426 410 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 427 411 sysn(:,:,jl) = z2d(:,:) 428 znam = 'sxxsn'//'_htc'// zchar412 znam = 'sxxsn'//'_htc'//TRIM(ADJUSTL(zchar)) 429 413 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 430 414 sxxsn(:,:,jl) = z2d(:,:) 431 znam = 'syysn'//'_htc'// zchar415 znam = 'syysn'//'_htc'//TRIM(ADJUSTL(zchar)) 432 416 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 433 417 syysn(:,:,jl) = z2d(:,:) 434 znam = 'sxysn'//'_htc'// zchar418 znam = 'sxysn'//'_htc'//TRIM(ADJUSTL(zchar)) 435 419 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 436 420 sxysn(:,:,jl) = z2d(:,:) 437 znam = 'sxa'//'_htc'// zchar421 znam = 'sxa'//'_htc'//TRIM(ADJUSTL(zchar)) 438 422 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 439 423 sxa(:,:,jl) = z2d(:,:) 440 znam = 'sya'//'_htc'// zchar424 znam = 'sya'//'_htc'//TRIM(ADJUSTL(zchar)) 441 425 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 442 426 sya(:,:,jl) = z2d(:,:) 443 znam = 'sxxa'//'_htc'// zchar427 znam = 'sxxa'//'_htc'//TRIM(ADJUSTL(zchar)) 444 428 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 445 429 sxxa(:,:,jl) = z2d(:,:) 446 znam = 'syya'//'_htc'// zchar430 znam = 'syya'//'_htc'//TRIM(ADJUSTL(zchar)) 447 431 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 448 432 syya(:,:,jl) = z2d(:,:) 449 znam = 'sxya'//'_htc'// zchar433 znam = 'sxya'//'_htc'//TRIM(ADJUSTL(zchar)) 450 434 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 451 435 sxya(:,:,jl) = z2d(:,:) 452 znam = 'sxc0'//'_htc'// zchar436 znam = 'sxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 453 437 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 454 438 sxc0(:,:,jl) = z2d(:,:) 455 znam = 'syc0'//'_htc'// zchar439 znam = 'syc0'//'_htc'//TRIM(ADJUSTL(zchar)) 456 440 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 457 441 syc0(:,:,jl) = z2d(:,:) 458 znam = 'sxxc0'//'_htc'// zchar442 znam = 'sxxc0'//'_htc'//TRIM(ADJUSTL(zchar)) 459 443 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 460 444 sxxc0(:,:,jl) = z2d(:,:) 461 znam = 'syyc0'//'_htc'// zchar445 znam = 'syyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 462 446 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 463 447 syyc0(:,:,jl) = z2d(:,:) 464 znam = 'sxyc0'//'_htc'// zchar448 znam = 'sxyc0'//'_htc'//TRIM(ADJUSTL(zchar)) 465 449 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 466 450 sxyc0(:,:,jl) = z2d(:,:) 467 znam = 'sxsal'//'_htc'// zchar451 znam = 'sxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 468 452 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 469 453 sxsal(:,:,jl) = z2d(:,:) 470 znam = 'sysal'//'_htc'// zchar454 znam = 'sysal'//'_htc'//TRIM(ADJUSTL(zchar)) 471 455 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 472 456 sysal(:,:,jl) = z2d(:,:) 473 znam = 'sxxsal'//'_htc'// zchar457 znam = 'sxxsal'//'_htc'//TRIM(ADJUSTL(zchar)) 474 458 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 475 459 sxxsal(:,:,jl) = z2d(:,:) 476 znam = 'syysal'//'_htc'// zchar460 znam = 'syysal'//'_htc'//TRIM(ADJUSTL(zchar)) 477 461 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 478 462 syysal(:,:,jl) = z2d(:,:) 479 znam = 'sxysal'//'_htc'// zchar463 znam = 'sxysal'//'_htc'//TRIM(ADJUSTL(zchar)) 480 464 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 481 465 sxysal(:,:,jl) = z2d(:,:) 482 znam = 'sxage'//'_htc'// zchar466 znam = 'sxage'//'_htc'//TRIM(ADJUSTL(zchar)) 483 467 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 484 468 sxage(:,:,jl) = z2d(:,:) 485 znam = 'syage'//'_htc'// zchar469 znam = 'syage'//'_htc'//TRIM(ADJUSTL(zchar)) 486 470 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 487 471 syage(:,:,jl) = z2d(:,:) 488 znam = 'sxxage'//'_htc'// zchar472 znam = 'sxxage'//'_htc'//TRIM(ADJUSTL(zchar)) 489 473 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 490 474 sxxage(:,:,jl) = z2d(:,:) 491 znam = 'syyage'//'_htc'// zchar475 znam = 'syyage'//'_htc'//TRIM(ADJUSTL(zchar)) 492 476 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 493 477 syyage(:,:,jl) = z2d(:,:) 494 znam = 'sxyage'//'_htc'// zchar478 znam = 'sxyage'//'_htc'//TRIM(ADJUSTL(zchar)) 495 479 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 496 480 sxyage(:,:,jl)= z2d(:,:) … … 504 488 505 489 DO jl = 1, jpl 506 WRITE(zchar,'(I 1)') jl490 WRITE(zchar,'(I2)') jl 507 491 DO jk = 1, nlay_i 508 WRITE(zchar1,'(I 1)') jk509 znam = 'sxe'//'_il'// zchar1//'_htc'//zchar492 WRITE(zchar1,'(I2)') jk 493 znam = 'sxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 510 494 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 511 495 sxe(:,:,jk,jl) = z2d(:,:) 512 znam = 'sye'//'_il'// zchar1//'_htc'//zchar496 znam = 'sye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 513 497 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 514 498 sye(:,:,jk,jl) = z2d(:,:) 515 znam = 'sxxe'//'_il'// zchar1//'_htc'//zchar499 znam = 'sxxe'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 516 500 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 517 501 sxxe(:,:,jk,jl) = z2d(:,:) 518 znam = 'syye'//'_il'// zchar1//'_htc'//zchar502 znam = 'syye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 519 503 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 520 504 syye(:,:,jk,jl) = z2d(:,:) 521 znam = 'sxye'//'_il'// zchar1//'_htc'//zchar505 znam = 'sxye'//'_il'//TRIM(ADJUSTL(zchar1))//'_htc'//TRIM(ADJUSTL(zchar)) 522 506 CALL iom_get( numrir, jpdom_autoglo, znam , z2d ) 523 507 sxye(:,:,jk,jl) = z2d(:,:) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r7256 r7806 613 613 CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 614 614 CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 615 !616 615 END SELECT 617 616 … … 633 632 INTEGER :: ios ! Local integer output status for namelist read 634 633 NAMELIST/namicethd/ rn_hnewice, ln_frazil, rn_maxfrazb, rn_vfrazb, rn_Cfrazb, & 635 & rn_himin, rn_betas, rn_kappa_i, nn_conv_dif, rn_terr_dif, nn_ice_thcon, &636 & nn_monocat, ln_it_qnsice634 & rn_himin, rn_betas, rn_kappa_i, nn_conv_dif, rn_terr_dif, nn_ice_thcon, & 635 & rn_cdsn, nn_monocat, ln_it_qnsice 637 636 !!------------------------------------------------------------------- 638 637 ! … … 673 672 WRITE(numout,*)' maximal err. on T for heat diffusion computation rn_terr_dif = ', rn_terr_dif 674 673 WRITE(numout,*)' switch for comp. of thermal conductivity in the ice nn_ice_thcon = ', nn_ice_thcon 674 WRITE(numout,*)' thermal conductivity of the snow rn_cdsn = ', rn_cdsn 675 675 WRITE(numout,*)' check heat conservation in the ice/snow con_i = ', con_i 676 676 WRITE(numout,*)' virtual ITD mono-category parameterizations (1) or not nn_monocat = ', nn_monocat -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90
r5602 r7806 376 376 377 377 ! Effective thickness he (zhe) 378 zfac = 1._wp / ( r cdsn + zkimean )379 zratio_s = r cdsn * zfac378 zfac = 1._wp / ( rn_cdsn + zkimean ) 379 zratio_s = rn_cdsn * zfac 380 380 zratio_i = zkimean * zfac 381 381 zhe = zratio_s * ht_i_1d(ji) + zratio_i * ht_s_1d(ji) … … 400 400 DO ji = kideb, kiut 401 401 zfac = 1. / MAX( epsi10 , zh_s(ji) ) 402 zkappa_s(ji,0) = zghe(ji) * r cdsn * zfac403 zkappa_s(ji,nlay_s) = zghe(ji) * r cdsn * zfac402 zkappa_s(ji,0) = zghe(ji) * rn_cdsn * zfac 403 zkappa_s(ji,nlay_s) = zghe(ji) * rn_cdsn * zfac 404 404 END DO 405 405 406 406 DO jk = 1, nlay_s-1 407 407 DO ji = kideb , kiut 408 zkappa_s(ji,jk) = zghe(ji) * 2.0 * r cdsn / MAX( epsi10, 2.0 * zh_s(ji) )408 zkappa_s(ji,jk) = zghe(ji) * 2.0 * rn_cdsn / MAX( epsi10, 2.0 * zh_s(ji) ) 409 409 END DO 410 410 END DO … … 422 422 zkappa_i(ji,0) = zghe(ji) * ztcond_i(ji,0) * zfac 423 423 zkappa_i(ji,nlay_i) = zghe(ji) * ztcond_i(ji,nlay_i) * zfac 424 zkappa_s(ji,nlay_s) = zghe(ji) * zghe(ji) * 2.0 * r cdsn * ztcond_i(ji,0) / &425 & MAX( epsi10, ( zghe(ji) * ztcond_i(ji,0) * zh_s(ji) + zghe(ji) * r cdsn * zh_i(ji) ) )424 zkappa_s(ji,nlay_s) = zghe(ji) * zghe(ji) * 2.0 * rn_cdsn * ztcond_i(ji,0) / & 425 & MAX( epsi10, ( zghe(ji) * ztcond_i(ji,0) * zh_s(ji) + zghe(ji) * rn_cdsn * zh_i(ji) ) ) 426 426 zkappa_i(ji,0) = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) ) 427 427 END DO … … 697 697 & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,numeqmin(ji)) 698 698 END DO 699 699 700 ! 700 701 !-------------------------------------------------------------------------- -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
r7256 r7806 531 531 DO jj=MAX(j1,2),j2 532 532 DO ji=MAX(i1,2),i2 533 u ice_agr(ji,jj) = tabres(ji,jj)533 u_ice_nst(ji,jj) = tabres(ji,jj) 534 534 END DO 535 535 END DO … … 582 582 DO jj=MAX(j1,2),j2 583 583 DO ji=MAX(i1,2),i2 584 v ice_agr(ji,jj) = tabres(ji,jj)584 v_ice_nst(ji,jj) = tabres(ji,jj) 585 585 END DO 586 586 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90
r7256 r7806 177 177 tabres = zrhox * tabres 178 178 ELSE 179 DO jj= j1,j2180 DO ji= i1,i2179 DO jj=MAX(j1,2),j2 180 DO ji=MAX(i1,2),i2 181 181 v_ice(ji,jj) = tabres(ji,jj) / (e1f(ji-1,jj-1)) 182 182 v_ice(ji,jj) = v_ice(ji,jj) * tmu(ji,jj) … … 202 202 IF( before ) THEN 203 203 zrhoy = Agrif_Rhoy() 204 DO jj= MAX(j1,2),j2205 DO ji= MAX(i1,2),i2204 DO jj=j1,j2 205 DO ji=i1,i2 206 206 tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 207 207 END DO … … 209 209 tabres = zrhoy * tabres 210 210 ELSE 211 DO jj= MAX(j1,2),j2212 DO ji= MAX(i1,2),i2211 DO jj=j1,j2 212 DO ji=i1,i2 213 213 u_ice(ji,jj) = tabres(ji,jj) / (e2u(ji,jj)) 214 214 u_ice(ji,jj) = u_ice(ji,jj) * tmu(ji,jj) … … 235 235 IF( before ) THEN 236 236 zrhox = Agrif_Rhox() 237 DO jj= MAX(j1,2),j2238 DO ji= MAX(i1,2),i2237 DO jj=j1,j2 238 DO ji=i1,i2 239 239 tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 240 240 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/domrea.F90
r7217 r7806 17 17 USE lib_mpp ! distributed memory computing library 18 18 19 USE iom 19 20 USE domstp ! domain: set the time-step 20 21 … … 73 74 74 75 CALL dom_nam ! read namelist ( namrun, namdom, namcla ) 76 CALL dom_msk ! Masks 77 CALL dom_hgr ! Horizontal grid 75 78 CALL dom_zgr ! Vertical mesh and bathymetry option 76 CALL dom_grd ! Create a domain file 77 78 ! 79 ! - ML - Used in dom_vvl_sf_nxt and lateral diffusion routines 80 ! but could be usefull in many other routines 79 ! 81 80 e12t (:,:) = e1t(:,:) * e2t(:,:) 82 81 e1e2t (:,:) = e1t(:,:) * e2t(:,:) … … 91 90 re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 92 91 ! 93 hu(:,:) = 0._wp ! Ocean depth at U- and V-points94 hv(:,:) = 0._wp95 DO jk = 1, jpk96 hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk)97 hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk)98 END DO99 ! ! Inverse of the local depth100 hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask(:,:,1) ) * umask(:,:,1)101 hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask(:,:,1) ) * vmask(:,:,1)102 103 92 CALL dom_stp ! Time step 104 CALL dom_msk ! Masks105 93 CALL dom_ctl ! Domain control 106 94 … … 178 166 nstocklist = nn_stocklist 179 167 nwrite = nn_write 180 181 182 168 ! ! control of output frequency 183 169 IF ( nstock == 0 .OR. nstock > nitend ) THEN … … 222 208 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 223 209 IF(lwm) WRITE ( numond, namdom ) 210 224 211 225 212 IF(lwp) THEN … … 321 308 END SUBROUTINE dom_nam 322 309 310 SUBROUTINE dom_msk 311 !!--------------------------------------------------------------------- 312 !! *** ROUTINE dom_msk *** 313 !! ** Purpose : Read the NetCDF file(s) which contain(s) all the 314 !! ocean mask informations and defines the interior domain T-mask. 315 !! 316 !! ** Method : Read in a file all the arrays generated in routines 317 !! dommsk: 'mask.nc' file 318 !! The interior ocean/land mask is computed from tmask 319 !! setting to zero the duplicated row and lines due to 320 !! MPP exchange halos, est-west cyclic and north fold 321 !! boundary conditions. 322 !! 323 !! ** Action : tmask_i : interiorland/ocean mask at t-point 324 !! tpol : ??? 325 !!---------------------------------------------------------------------- 326 ! 327 INTEGER :: inum ! local integers 328 INTEGER :: ji, jj, jk ! dummy loop indices 329 INTEGER :: iif, iil, ijf, ijl ! local integers 330 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 331 ! 332 !!--------------------------------------------------------------------- 333 334 335 336 IF(lwp) WRITE(numout,*) 337 IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)' 338 IF(lwp) WRITE(numout,*) '~~~~~~~' 339 340 CALL wrk_alloc( jpi, jpj, zmbk ) 341 zmbk(:,:) = 0._wp 342 343 IF(lwp) WRITE(numout,*) ' one file in "mesh_mask.nc" ' 344 CALL iom_open( 'mask', inum ) 345 346 ! ! masks (inum2) 347 CALL iom_get( inum, jpdom_data, 'tmask', tmask ) 348 CALL iom_get( inum, jpdom_data, 'umask', umask ) 349 CALL iom_get( inum, jpdom_data, 'vmask', vmask ) 350 CALL iom_get( inum, jpdom_data, 'fmask', fmask ) 351 352 CALL lbc_lnk( tmask, 'T', 1._wp ) ! Lateral boundary conditions 353 CALL lbc_lnk( umask, 'U', 1._wp ) 354 CALL lbc_lnk( vmask, 'V', 1._wp ) 355 CALL lbc_lnk( fmask, 'F', 1._wp ) 356 357 #if defined key_c1d 358 ! set umask and vmask equal tmask in 1D configuration 359 IF(lwp) WRITE(numout,*) 360 IF(lwp) WRITE(numout,*) '********** 1D configuration : set umask and vmask equal tmask ********' 361 IF(lwp) WRITE(numout,*) '********** ********' 362 363 umask(:,:,:) = tmask(:,:,:) 364 vmask(:,:,:) = tmask(:,:,:) 365 #endif 366 367 #if defined key_degrad 368 CALL iom_get( inum, jpdom_data, 'facvolt', facvol ) 369 #endif 370 371 CALL iom_get( inum, jpdom_data, 'mbathy', zmbk ) ! number of ocean t-points 372 mbathy (:,:) = INT( zmbk(:,:) ) 373 misfdep(:,:) = 1 ! ice shelf case not yet done 374 375 CALL zgr_bot_level ! mbk. arrays (deepest ocean t-, u- & v-points 376 377 ! ! ============================ 378 ! ! close the files 379 ! ! ============================ 380 381 ! 382 ! Interior domain mask (used for global sum) 383 ! -------------------- 384 ssmask(:,:) = tmask(:,:,1) 385 tmask_i(:,:) = tmask(:,:,1) 386 iif = jpreci ! thickness of exchange halos in i-axis 387 iil = nlci - jpreci + 1 388 ijf = jprecj ! thickness of exchange halos in j-axis 389 ijl = nlcj - jprecj + 1 390 ! 391 tmask_i( 1 :iif, : ) = 0._wp ! first columns 392 tmask_i(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 393 tmask_i( : , 1 :ijf) = 0._wp ! first rows 394 tmask_i( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 395 ! 396 ! ! north fold mask 397 tpol(1:jpiglo) = 1._wp 398 ! 399 IF( jperio == 3 .OR. jperio == 4 ) tpol(jpiglo/2+1:jpiglo) = 0._wp ! T-point pivot 400 IF( jperio == 5 .OR. jperio == 6 ) tpol( 1 :jpiglo) = 0._wp ! F-point pivot 401 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot: only half of the nlcj-1 row 402 IF( mjg(ijl-1) == jpjglo-1 ) THEN 403 DO ji = iif+1, iil-1 404 tmask_i(ji,ijl-1) = tmask_i(ji,ijl-1) * tpol(mig(ji)) 405 END DO 406 ENDIF 407 ENDIF 408 ! 409 ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 410 ! least 1 wet u point 411 DO jj = 1, jpjm1 412 DO ji = 1, fs_jpim1 ! vector loop 413 umask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:))) 414 vmask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:))) 415 END DO 416 DO ji = 1, jpim1 ! NO vector opt. 417 fmask_i(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) & 418 & * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 419 END DO 420 END DO 421 CALL lbc_lnk( umask_i, 'U', 1._wp ) ! Lateral boundary conditions 422 CALL lbc_lnk( vmask_i, 'V', 1._wp ) 423 CALL lbc_lnk( fmask_i, 'F', 1._wp ) 424 425 ! 3. Ocean/land mask at wu-, wv- and w points 426 !---------------------------------------------- 427 wmask (:,:,1) = tmask(:,:,1) ! ???????? 428 wumask(:,:,1) = umask(:,:,1) ! ???????? 429 wvmask(:,:,1) = vmask(:,:,1) ! ???????? 430 DO jk = 2, jpk 431 wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 432 wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 433 wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 434 END DO 435 ! 436 CALL wrk_dealloc( jpi, jpj, zmbk ) 437 ! 438 CALL iom_close( inum ) 439 ! 440 END SUBROUTINE dom_msk 441 442 SUBROUTINE zgr_bot_level 443 !!---------------------------------------------------------------------- 444 !! *** ROUTINE zgr_bot_level *** 445 !! 446 !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) 447 !! 448 !! ** Method : computes from mbathy with a minimum value of 1 over land 449 !! 450 !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest 451 !! ocean level at t-, u- & v-points 452 !! (min value = 1 over land) 453 !!---------------------------------------------------------------------- 454 ! 455 INTEGER :: ji, jj ! dummy loop indices 456 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 457 !!---------------------------------------------------------------------- 458 459 ! 460 IF(lwp) WRITE(numout,*) 461 IF(lwp) WRITE(numout,*) ' zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 462 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 463 ! 464 CALL wrk_alloc( jpi, jpj, zmbk ) 465 ! 466 mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 467 mikt(:,:) = 1 ; miku(:,:) = 1; mikv(:,:) = 1; ! top k-index of T-level (=1 over open ocean; >1 beneath ice shelf) 468 ! ! bottom k-index of W-level = mbkt+1 469 DO jj = 1, jpjm1 ! bottom k-index of u- (v-) level 470 DO ji = 1, jpim1 471 mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) 472 mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) 473 END DO 474 END DO 475 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 476 zmbk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 477 zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 478 ! 479 CALL wrk_dealloc( jpi, jpj, zmbk ) 480 ! 481 END SUBROUTINE zgr_bot_level 482 483 SUBROUTINE dom_hgr 484 !!---------------------------------------------------------------------- 485 !! *** ROUTINE dom_hgr *** 486 !! 487 !! ** Purpose : Read the NetCDF file(s) which contain(s) all the 488 !! ocean horizontal mesh informations 489 !! 490 !! ** Method : Read in a file all the arrays generated in routines 491 !! domhgr: 'mesh_hgr.nc' file 492 !!---------------------------------------------------------------------- 493 !! 494 INTEGER :: ji, jj ! dummy loop indices 495 INTEGER :: inum ! local integers 496 !!---------------------------------------------------------------------- 497 498 IF(lwp) WRITE(numout,*) 499 IF(lwp) WRITE(numout,*) 'dom_grd_hgr : read NetCDF mesh and mask information file(s)' 500 IF(lwp) WRITE(numout,*) '~~~~~~~' 501 502 IF(lwp) WRITE(numout,*) ' one file in "mesh_mask.nc" ' 503 CALL iom_open( 'mesh_hgr', inum ) 504 505 ! ! horizontal mesh (inum3) 506 CALL iom_get( inum, jpdom_data, 'glamt', glamt ) 507 CALL iom_get( inum, jpdom_data, 'glamu', glamu ) 508 CALL iom_get( inum, jpdom_data, 'glamv', glamv ) 509 CALL iom_get( inum, jpdom_data, 'glamf', glamf ) 510 511 CALL iom_get( inum, jpdom_data, 'gphit', gphit ) 512 CALL iom_get( inum, jpdom_data, 'gphiu', gphiu ) 513 CALL iom_get( inum, jpdom_data, 'gphiv', gphiv ) 514 CALL iom_get( inum, jpdom_data, 'gphif', gphif ) 515 516 CALL iom_get( inum, jpdom_data, 'e1t', e1t ) 517 CALL iom_get( inum, jpdom_data, 'e1u', e1u ) 518 CALL iom_get( inum, jpdom_data, 'e1v', e1v ) 519 520 CALL iom_get( inum, jpdom_data, 'e2t', e2t ) 521 CALL iom_get( inum, jpdom_data, 'e2u', e2u ) 522 CALL iom_get( inum, jpdom_data, 'e2v', e2v ) 523 524 CALL iom_get( inum, jpdom_data, 'ff', ff ) 525 526 527 ! Control printing : Grid informations (if not restart) 528 ! ---------------- 529 530 IF(lwp .AND. .NOT.ln_rstart ) THEN 531 WRITE(numout,*) 532 WRITE(numout,*) ' longitude and e1 scale factors' 533 WRITE(numout,*) ' ------------------------------' 534 WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1), & 535 glamv(ji,1), glamf(ji,1), & 536 e1t(ji,1), e1u(ji,1), & 537 e1v(ji,1), ji = 1, jpi,10) 538 539 WRITE(numout,*) 540 WRITE(numout,*) ' latitude and e2 scale factors' 541 WRITE(numout,*) ' -----------------------------' 542 WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj), & 543 & gphiv(1,jj), gphif(1,jj), & 544 & e2t (1,jj), e2u (1,jj), & 545 & e2v (1,jj), jj = 1, jpj, 10 ) 546 ENDIF 547 548 ! ! ============================ 549 ! ! close the files 550 ! ! ============================ 551 CALL iom_close( inum ) 552 ! 553 9300 FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x, & 554 f19.10, 1x, f19.10, 1x, f19.10 ) 555 END SUBROUTINE dom_hgr 556 557 323 558 SUBROUTINE dom_zgr 324 559 !!---------------------------------------------------------------------- 325 560 !! *** ROUTINE dom_zgr *** 326 561 !! 327 !! ** Purpose : set the depth of model levels and the resulting 328 !! vertical scale factors. 562 !! ** Purpose : Read the NetCDF file(s) which contain(s) all the 563 !! ocean horizontal mesh informations and/or set the depth of model levels 564 !! and the resulting vertical scale factors. 329 565 !! 330 566 !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) … … 338 574 !! ** Action : define gdep., e3., mbathy and bathy 339 575 !!---------------------------------------------------------------------- 340 INTEGER :: ioptio = 0 ! temporary integer 341 INTEGER :: ios 576 INTEGER :: ioptio = 0 ! temporary integer 577 INTEGER :: inum, ios 578 INTEGER :: ji, jj, jk, ik 579 REAL(wp) :: zrefdep 342 580 !! 343 581 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 582 REAL(wp), POINTER, DIMENSION(:,:) :: zprt, zprw 344 583 !!---------------------------------------------------------------------- 345 584 … … 372 611 IF ( ioptio == 33 ) CALL ctl_stop( ' isf cavity with off line module not yet done ' ) 373 612 374 END SUBROUTINE dom_zgr 375 376 SUBROUTINE dom_ctl 377 !!---------------------------------------------------------------------- 378 !! *** ROUTINE dom_ctl *** 379 !! 380 !! ** Purpose : Domain control. 381 !! 382 !! ** Method : compute and print extrema of masked scale factors 383 !! 384 !! History : 385 !! 8.5 ! 02-08 (G. Madec) Original code 386 !!---------------------------------------------------------------------- 387 !! * Local declarations 388 INTEGER :: iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 389 INTEGER, DIMENSION(2) :: iloc ! 390 REAL(wp) :: ze1min, ze1max, ze2min, ze2max 391 !!---------------------------------------------------------------------- 392 393 ! Extrema of the scale factors 394 395 IF(lwp)WRITE(numout,*) 396 IF(lwp)WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 397 IF(lwp)WRITE(numout,*) '~~~~~~~' 398 399 IF (lk_mpp) THEN 400 CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 401 CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 402 CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 403 CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 613 IF(lwp) WRITE(numout,*) ' one file in "mesh_mask.nc" ' 614 CALL iom_open( 'mesh_zgr', inum ) 615 616 CALL iom_get( inum, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 617 CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 618 IF( ln_zco .OR. ln_zps ) THEN 619 CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , e3t_1d ) ! reference scale factors 620 CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , e3w_1d ) 621 ENDIF 622 623 !!gm BUG in s-coordinate this does not work! 624 ! deepest/shallowest W level Above/Below ~10m 625 zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) ) ! ref. depth with tolerance (10% of minimum layer thickness) 626 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 627 nla10 = nlb10 - 1 ! deepest W level Above ~10m 628 !!gm end bug 629 630 IF(lwp) THEN 631 WRITE(numout,*) 632 WRITE(numout,*) ' Reference z-coordinate depth and scale factors:' 633 WRITE(numout, "(9x,' level gdept gdepw e3t e3w ')" ) 634 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 635 ENDIF 636 637 DO jk = 1, jpk 638 IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 639 IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 640 END DO 641 642 IF( lk_vvl ) THEN 643 CALL iom_get( inum, jpdom_data, 'e3t_0', e3t_0(:,:,:) ) 644 CALL iom_get( inum, jpdom_data, 'e3u_0', e3u_0(:,:,:) ) 645 CALL iom_get( inum, jpdom_data, 'e3v_0', e3v_0(:,:,:) ) 646 CALL iom_get( inum, jpdom_data, 'e3w_0', e3w_0(:,:,:) ) 647 CALL iom_get( inum, jpdom_data, 'gdept_0', gdept_0(:,:,:) ) 648 CALL iom_get( inum, jpdom_data, 'gdepw_0', gdepw_0(:,:,:) ) 649 ht_0(:,:) = 0.0_wp ! Reference ocean depth at T-points 650 DO jk = 1, jpk 651 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 652 END DO 404 653 ELSE 405 ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )406 ze2min = MINVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )407 ze1max = MAXVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )408 ze2max = MAXVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )409 410 iloc = MINLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )411 iimi1 = iloc(1) + nimpp - 1412 ijmi1 = iloc(2) + njmpp - 1413 iloc = MINLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )414 iimi2 = iloc(1) + nimpp - 1415 ijmi2 = iloc(2) + njmpp - 1416 iloc = MAXLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )417 iima1 = iloc(1) + nimpp - 1418 ijma1 = iloc(2) + njmpp - 1419 iloc = MAXLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 )420 iima2 = iloc(1) + nimpp - 1421 ijma2 = iloc(2) + njmpp - 1422 ENDIF423 424 IF(lwp) THEN425 WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1426 WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1427 WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2428 WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2429 ENDIF430 431 END SUBROUTINE dom_ctl432 433 SUBROUTINE dom_grd434 !!----------------------------------------------------------------------435 !! *** ROUTINE dom_grd ***436 !!437 !! ** Purpose : Read the NetCDF file(s) which contain(s) all the438 !! ocean domain informations (mesh and mask arrays). This (these)439 !! file(s) is (are) used for visualisation (SAXO software) and440 !! diagnostic computation.441 !!442 !! ** Method : Read in a file all the arrays generated in routines443 !! domhgr, domzgr, and dommsk. Note: the file contain depends on444 !! the vertical coord. used (z-coord, partial steps, s-coord)445 !! nmsh = 1 : 'mesh_mask.nc' file446 !! = 2 : 'mesh.nc' and mask.nc' files447 !! = 3 : 'mesh_hgr.nc', 'mesh_zgr.nc' and448 !! 'mask.nc' files449 !! For huge size domain, use option 2 or 3 depending on your450 !! vertical coordinate.451 !!452 !! ** input file :453 !! meshmask.nc : domain size, horizontal grid-point position,454 !! masks, depth and vertical scale factors455 !!----------------------------------------------------------------------456 USE iom457 !!458 INTEGER :: ji, jj, jk ! dummy loop indices459 INTEGER :: ik, inum0 , inum1 , inum2 , inum3 , inum4 ! local integers460 REAL(wp) :: zrefdep ! local real461 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk, zprt, zprw462 !!----------------------------------------------------------------------463 464 IF(lwp) WRITE(numout,*)465 IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)'466 IF(lwp) WRITE(numout,*) '~~~~~~~'467 468 CALL wrk_alloc( jpi, jpj, zmbk, zprt, zprw )469 470 zmbk(:,:) = 0._wp471 472 SELECT CASE (nmsh)473 ! ! ============================474 CASE ( 1 ) ! create 'mesh_mask.nc' file475 ! ! ============================476 477 IF(lwp) WRITE(numout,*) ' one file in "mesh_mask.nc" '478 CALL iom_open( 'mesh_mask', inum0 )479 480 inum2 = inum0 ! put all the informations481 inum3 = inum0 ! in unit inum0482 inum4 = inum0483 484 ! ! ============================485 CASE ( 2 ) ! create 'mesh.nc' and486 ! ! 'mask.nc' files487 ! ! ============================488 489 IF(lwp) WRITE(numout,*) ' two files in "mesh.nc" and "mask.nc" '490 CALL iom_open( 'mesh', inum1 )491 CALL iom_open( 'mask', inum2 )492 493 inum3 = inum1 ! put mesh informations494 inum4 = inum1 ! in unit inum1495 496 ! ! ============================497 CASE ( 3 ) ! create 'mesh_hgr.nc'498 ! ! 'mesh_zgr.nc' and499 ! ! 'mask.nc' files500 ! ! ============================501 502 IF(lwp) WRITE(numout,*) ' three files in "mesh_hgr.nc" , "mesh_zgr.nc" and "mask.nc" '503 CALL iom_open( 'mesh_hgr', inum3 ) ! create 'mesh_hgr.nc'504 CALL iom_open( 'mesh_zgr', inum4 ) ! create 'mesh_zgr.nc'505 CALL iom_open( 'mask' , inum2 ) ! create 'mask.nc'506 507 ! ! ===========================508 CASE DEFAULT ! return error509 ! ! mesh has to be provided510 ! ! ===========================511 CALL ctl_stop( ' OFFLINE mode requires the input mesh mask(s). ', &512 & ' Invalid nn_msh value in the namelist (0 is not allowed)' )513 514 END SELECT515 516 ! ! masks (inum2)517 CALL iom_get( inum2, jpdom_data, 'tmask', tmask )518 CALL iom_get( inum2, jpdom_data, 'umask', umask )519 CALL iom_get( inum2, jpdom_data, 'vmask', vmask )520 CALL iom_get( inum2, jpdom_data, 'fmask', fmask )521 522 CALL lbc_lnk( tmask, 'T', 1._wp ) ! Lateral boundary conditions523 CALL lbc_lnk( umask, 'U', 1._wp )524 CALL lbc_lnk( vmask, 'V', 1._wp )525 CALL lbc_lnk( fmask, 'F', 1._wp )526 527 #if defined key_c1d528 ! set umask and vmask equal tmask in 1D configuration529 IF(lwp) WRITE(numout,*)530 IF(lwp) WRITE(numout,*) '********** 1D configuration : set umask and vmask equal tmask ********'531 IF(lwp) WRITE(numout,*) '********** ********'532 533 umask(:,:,:) = tmask(:,:,:)534 vmask(:,:,:) = tmask(:,:,:)535 #endif536 537 #if defined key_degrad538 CALL iom_get( inum2, jpdom_data, 'facvolt', facvol )539 #endif540 541 ! ! horizontal mesh (inum3)542 CALL iom_get( inum3, jpdom_data, 'glamt', glamt )543 CALL iom_get( inum3, jpdom_data, 'glamu', glamu )544 CALL iom_get( inum3, jpdom_data, 'glamv', glamv )545 CALL iom_get( inum3, jpdom_data, 'glamf', glamf )546 547 CALL iom_get( inum3, jpdom_data, 'gphit', gphit )548 CALL iom_get( inum3, jpdom_data, 'gphiu', gphiu )549 CALL iom_get( inum3, jpdom_data, 'gphiv', gphiv )550 CALL iom_get( inum3, jpdom_data, 'gphif', gphif )551 552 CALL iom_get( inum3, jpdom_data, 'e1t', e1t )553 CALL iom_get( inum3, jpdom_data, 'e1u', e1u )554 CALL iom_get( inum3, jpdom_data, 'e1v', e1v )555 556 CALL iom_get( inum3, jpdom_data, 'e2t', e2t )557 CALL iom_get( inum3, jpdom_data, 'e2u', e2u )558 CALL iom_get( inum3, jpdom_data, 'e2v', e2v )559 560 CALL iom_get( inum3, jpdom_data, 'ff', ff )561 562 CALL iom_get( inum4, jpdom_data, 'mbathy', zmbk ) ! number of ocean t-points563 mbathy (:,:) = INT( zmbk(:,:) )564 misfdep(:,:) = 1 ! ice shelf case not yet done565 566 CALL zgr_bot_level ! mbk. arrays (deepest ocean t-, u- & v-points567 !568 654 IF( ln_sco ) THEN ! s-coordinate 569 CALL iom_get( inum 4, jpdom_data, 'hbatt', hbatt )570 CALL iom_get( inum 4, jpdom_data, 'hbatu', hbatu )571 CALL iom_get( inum 4, jpdom_data, 'hbatv', hbatv )572 CALL iom_get( inum 4, jpdom_data, 'hbatf', hbatf )655 CALL iom_get( inum, jpdom_data, 'hbatt', hbatt ) 656 CALL iom_get( inum, jpdom_data, 'hbatu', hbatu ) 657 CALL iom_get( inum, jpdom_data, 'hbatv', hbatv ) 658 CALL iom_get( inum, jpdom_data, 'hbatf', hbatf ) 573 659 574 CALL iom_get( inum4, jpdom_unknown, 'gsigt', gsigt ) ! scaling coef. 575 CALL iom_get( inum4, jpdom_unknown, 'gsigw', gsigw ) 576 CALL iom_get( inum4, jpdom_unknown, 'gsi3w', gsi3w ) 577 CALL iom_get( inum4, jpdom_unknown, 'esigt', esigt ) 578 CALL iom_get( inum4, jpdom_unknown, 'esigw', esigw ) 579 580 CALL iom_get( inum4, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) ! scale factors 581 CALL iom_get( inum4, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 582 CALL iom_get( inum4, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 583 CALL iom_get( inum4, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 584 585 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 586 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 660 CALL iom_get( inum, jpdom_unknown, 'gsigt', gsigt ) ! scaling coef. 661 CALL iom_get( inum, jpdom_unknown, 'gsigw', gsigw ) 662 CALL iom_get( inum, jpdom_unknown, 'gsi3w', gsi3w ) 663 CALL iom_get( inum, jpdom_unknown, 'esigt', esigt ) 664 CALL iom_get( inum, jpdom_unknown, 'esigw', esigw ) 665 666 CALL iom_get( inum, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) ! scale factors 667 CALL iom_get( inum, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 668 CALL iom_get( inum, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 669 CALL iom_get( inum, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 587 670 ENDIF 588 671 589 672 590 673 IF( ln_zps ) THEN ! z-coordinate - partial steps 591 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! reference depth592 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d )593 CALL iom_get( inum4, jpdom_unknown, 'e3t_1d' , e3t_1d ) ! reference scale factors594 CALL iom_get( inum4, jpdom_unknown, 'e3w_1d' , e3w_1d )595 674 ! 596 IF( nmsh <= 6 ) THEN ! 3D vertical scale factors597 CALL iom_get( inum 4, jpdom_data, 'e3t_0', fse3t_n(:,:,:) )598 CALL iom_get( inum 4, jpdom_data, 'e3u_0', fse3u_n(:,:,:) )599 CALL iom_get( inum 4, jpdom_data, 'e3v_0', fse3v_n(:,:,:) )600 CALL iom_get( inum 4, jpdom_data, 'e3w_0', fse3w_n(:,:,:) )675 IF( iom_varid( inum, 'e3t_0', ldstop = .FALSE. ) > 0 ) THEN 676 CALL iom_get( inum, jpdom_data, 'e3t_0', fse3t_n(:,:,:) ) 677 CALL iom_get( inum, jpdom_data, 'e3u_0', fse3u_n(:,:,:) ) 678 CALL iom_get( inum, jpdom_data, 'e3v_0', fse3v_n(:,:,:) ) 679 CALL iom_get( inum, jpdom_data, 'e3w_0', fse3w_n(:,:,:) ) 601 680 ELSE ! 2D bottom scale factors 602 CALL iom_get( inum 4, jpdom_data, 'e3t_ps', e3tp )603 CALL iom_get( inum 4, jpdom_data, 'e3w_ps', e3wp )681 CALL iom_get( inum, jpdom_data, 'e3t_ps', e3tp ) 682 CALL iom_get( inum, jpdom_data, 'e3w_ps', e3wp ) 604 683 ! ! deduces the 3D scale factors 605 684 DO jk = 1, jpk … … 633 712 END IF 634 713 635 IF( iom_varid( inum 4, 'gdept_0', ldstop = .FALSE. ) > 0 ) THEN ! 3D depth of t- and w-level636 CALL iom_get( inum 4, jpdom_data, 'gdept_0', fsdept_n(:,:,:) )637 CALL iom_get( inum 4, jpdom_data, 'gdepw_0', fsdepw_n(:,:,:) )714 IF( iom_varid( inum, 'gdept_0', ldstop = .FALSE. ) > 0 ) THEN ! 3D depth of t- and w-level 715 CALL iom_get( inum, jpdom_data, 'gdept_0', fsdept_n(:,:,:) ) 716 CALL iom_get( inum, jpdom_data, 'gdepw_0', fsdepw_n(:,:,:) ) 638 717 ELSE ! 2D bottom depth 639 CALL iom_get( inum4, jpdom_data, 'hdept', zprt ) 640 CALL iom_get( inum4, jpdom_data, 'hdepw', zprw ) 718 CALL wrk_alloc( jpi, jpj, zprt, zprw ) 719 ! 720 CALL iom_get( inum, jpdom_data, 'hdept', zprt ) 721 CALL iom_get( inum, jpdom_data, 'hdepw', zprw ) 641 722 ! 642 723 DO jk = 1, jpk ! deduces the 3D depth … … 654 735 END DO 655 736 END DO 737 CALL wrk_dealloc( jpi, jpj, zprt, zprw ) 656 738 ENDIF 657 739 ! … … 659 741 660 742 IF( ln_zco ) THEN ! Vertical coordinates and scales factors 661 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth662 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d )663 CALL iom_get( inum4, jpdom_unknown, 'e3t_1d' , e3t_1d )664 CALL iom_get( inum4, jpdom_unknown, 'e3w_1d' , e3w_1d )665 743 DO jk = 1, jpk 666 744 fse3t_n(:,:,jk) = e3t_1d(jk) ! set to the ref. factors … … 672 750 END DO 673 751 ENDIF 674 675 !!gm BUG in s-coordinate this does not work! 676 ! deepest/shallowest W level Above/Below ~10m 677 zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) ) ! ref. depth with tolerance (10% of minimum layer thickness) 678 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 679 nla10 = nlb10 - 1 ! deepest W level Above ~10m 680 !!gm end bug 681 682 ! Control printing : Grid informations (if not restart) 683 ! ---------------- 684 685 IF(lwp .AND. .NOT.ln_rstart ) THEN 686 WRITE(numout,*) 687 WRITE(numout,*) ' longitude and e1 scale factors' 688 WRITE(numout,*) ' ------------------------------' 689 WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1), & 690 glamv(ji,1), glamf(ji,1), & 691 e1t(ji,1), e1u(ji,1), & 692 e1v(ji,1), ji = 1, jpi,10) 693 9300 FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x, & 694 f19.10, 1x, f19.10, 1x, f19.10 ) 695 696 WRITE(numout,*) 697 WRITE(numout,*) ' latitude and e2 scale factors' 698 WRITE(numout,*) ' -----------------------------' 699 WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj), & 700 & gphiv(1,jj), gphif(1,jj), & 701 & e2t (1,jj), e2u (1,jj), & 702 & e2v (1,jj), jj = 1, jpj, 10 ) 703 ENDIF 704 705 706 IF( nprint == 1 .AND. lwp ) THEN 707 WRITE(numout,*) ' e1u e2u ' 708 CALL prihre( e1u,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 709 CALL prihre( e2u,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 710 WRITE(numout,*) ' e1v e2v ' 711 CALL prihre( e1v,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 712 CALL prihre( e2v,jpi,jpj,jpi-5,jpi,1,jpj-5,jpj,1,0.,numout ) 713 ENDIF 714 715 IF(lwp) THEN 716 WRITE(numout,*) 717 WRITE(numout,*) ' Reference z-coordinate depth and scale factors:' 718 WRITE(numout, "(9x,' level gdept gdepw e3t e3w ')" ) 719 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 720 ENDIF 721 722 DO jk = 1, jpk 723 IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 724 IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 725 END DO 752 ! 753 ENDIF 726 754 ! ! ============================ 727 755 ! ! close the files 728 756 ! ! ============================ 729 SELECT CASE ( nmsh ) 730 CASE ( 1 ) 731 CALL iom_close( inum0 ) 732 CASE ( 2 ) 733 CALL iom_close( inum1 ) 734 CALL iom_close( inum2 ) 735 CASE ( 3 ) 736 CALL iom_close( inum2 ) 737 CALL iom_close( inum3 ) 738 CALL iom_close( inum4 ) 739 END SELECT 740 ! 741 CALL wrk_dealloc( jpi, jpj, zmbk, zprt, zprw ) 742 ! 743 END SUBROUTINE dom_grd 744 745 746 SUBROUTINE zgr_bot_level 747 !!---------------------------------------------------------------------- 748 !! *** ROUTINE zgr_bot_level *** 749 !! 750 !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) 751 !! 752 !! ** Method : computes from mbathy with a minimum value of 1 over land 753 !! 754 !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest 755 !! ocean level at t-, u- & v-points 756 !! (min value = 1 over land) 757 !!---------------------------------------------------------------------- 758 ! 759 INTEGER :: ji, jj ! dummy loop indices 760 REAL(wp), POINTER, DIMENSION(:,:) :: zmbk 761 !!---------------------------------------------------------------------- 762 763 ! 764 IF(lwp) WRITE(numout,*) 765 IF(lwp) WRITE(numout,*) ' zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 766 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 767 ! 768 CALL wrk_alloc( jpi, jpj, zmbk ) 769 ! 770 mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 771 mikt(:,:) = 1 ; miku(:,:) = 1; mikv(:,:) = 1; ! top k-index of T-level (=1 over open ocean; >1 beneath ice shelf) 772 ! ! bottom k-index of W-level = mbkt+1 773 DO jj = 1, jpjm1 ! bottom k-index of u- (v-) level 774 DO ji = 1, jpim1 775 mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) 776 mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) 777 END DO 778 END DO 779 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 780 zmbk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 781 zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 782 ! 783 CALL wrk_dealloc( jpi, jpj, zmbk ) 784 ! 785 END SUBROUTINE zgr_bot_level 786 787 SUBROUTINE dom_msk 788 !!--------------------------------------------------------------------- 789 !! *** ROUTINE dom_msk *** 790 !! 791 !! ** Purpose : Off-line case: defines the interior domain T-mask. 792 !! 793 !! ** Method : The interior ocean/land mask is computed from tmask 794 !! setting to zero the duplicated row and lines due to 795 !! MPP exchange halos, est-west cyclic and north fold 796 !! boundary conditions. 797 !! 798 !! ** Action : tmask_i : interiorland/ocean mask at t-point 799 !! tpol : ??? 800 !!---------------------------------------------------------------------- 801 ! 802 INTEGER :: ji, jj, jk ! dummy loop indices 803 INTEGER :: iif, iil, ijf, ijl ! local integers 804 INTEGER, POINTER, DIMENSION(:,:) :: imsk 805 ! 806 !!--------------------------------------------------------------------- 807 808 CALL wrk_alloc( jpi, jpj, imsk ) 809 ! 810 ! Interior domain mask (used for global sum) 811 ! -------------------- 812 ssmask(:,:) = tmask(:,:,1) 813 tmask_i(:,:) = tmask(:,:,1) 814 iif = jpreci ! thickness of exchange halos in i-axis 815 iil = nlci - jpreci + 1 816 ijf = jprecj ! thickness of exchange halos in j-axis 817 ijl = nlcj - jprecj + 1 818 ! 819 tmask_i( 1 :iif, : ) = 0._wp ! first columns 820 tmask_i(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 821 tmask_i( : , 1 :ijf) = 0._wp ! first rows 822 tmask_i( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 823 ! 824 ! ! north fold mask 825 tpol(1:jpiglo) = 1._wp 826 ! 827 IF( jperio == 3 .OR. jperio == 4 ) tpol(jpiglo/2+1:jpiglo) = 0._wp ! T-point pivot 828 IF( jperio == 5 .OR. jperio == 6 ) tpol( 1 :jpiglo) = 0._wp ! F-point pivot 829 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot: only half of the nlcj-1 row 830 IF( mjg(ijl-1) == jpjglo-1 ) THEN 831 DO ji = iif+1, iil-1 832 tmask_i(ji,ijl-1) = tmask_i(ji,ijl-1) * tpol(mig(ji)) 833 END DO 834 ENDIF 835 ENDIF 836 ! 837 ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 838 ! least 1 wet u point 839 DO jj = 1, jpjm1 840 DO ji = 1, fs_jpim1 ! vector loop 841 umask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:))) 842 vmask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:))) 843 END DO 844 DO ji = 1, jpim1 ! NO vector opt. 845 fmask_i(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) & 846 & * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 847 END DO 848 END DO 849 CALL lbc_lnk( umask_i, 'U', 1._wp ) ! Lateral boundary conditions 850 CALL lbc_lnk( vmask_i, 'V', 1._wp ) 851 CALL lbc_lnk( fmask_i, 'F', 1._wp ) 852 853 ! 3. Ocean/land mask at wu-, wv- and w points 854 !---------------------------------------------- 855 wmask (:,:,1) = tmask(:,:,1) ! ???????? 856 wumask(:,:,1) = umask(:,:,1) ! ???????? 857 wvmask(:,:,1) = vmask(:,:,1) ! ???????? 858 DO jk=2,jpk 859 wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 860 wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1) 861 wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 862 END DO 863 ! 864 IF( nprint == 1 .AND. lwp ) THEN ! Control print 865 imsk(:,:) = INT( tmask_i(:,:) ) 866 WRITE(numout,*) ' tmask_i : ' 867 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 868 WRITE (numout,*) 869 WRITE (numout,*) ' dommsk: tmask for each level' 870 WRITE (numout,*) ' ----------------------------' 871 DO jk = 1, jpk 872 imsk(:,:) = INT( tmask(:,:,jk) ) 873 WRITE(numout,*) 874 WRITE(numout,*) ' level = ',jk 875 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, 1, jpj, 1, 1, numout) 876 END DO 877 ENDIF 878 ! 879 CALL wrk_dealloc( jpi, jpj, imsk ) 880 ! 881 END SUBROUTINE dom_msk 757 CALL iom_close( inum ) 758 ! 759 ! 760 END SUBROUTINE dom_zgr 761 762 SUBROUTINE dom_ctl 763 !!---------------------------------------------------------------------- 764 !! *** ROUTINE dom_ctl *** 765 !! 766 !! ** Purpose : Domain control. 767 !! 768 !! ** Method : compute and print extrema of masked scale factors 769 !! 770 !! History : 771 !! 8.5 ! 02-08 (G. Madec) Original code 772 !!---------------------------------------------------------------------- 773 !! * Local declarations 774 INTEGER :: iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 775 INTEGER, DIMENSION(2) :: iloc ! 776 REAL(wp) :: ze1min, ze1max, ze2min, ze2max 777 !!---------------------------------------------------------------------- 778 779 ! Extrema of the scale factors 780 781 IF(lwp)WRITE(numout,*) 782 IF(lwp)WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 783 IF(lwp)WRITE(numout,*) '~~~~~~~' 784 785 IF (lk_mpp) THEN 786 CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 787 CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 788 CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 789 CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 790 ELSE 791 ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 792 ze2min = MINVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 793 ze1max = MAXVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 794 ze2max = MAXVAL( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 795 796 iloc = MINLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 797 iimi1 = iloc(1) + nimpp - 1 798 ijmi1 = iloc(2) + njmpp - 1 799 iloc = MINLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 800 iimi2 = iloc(1) + nimpp - 1 801 ijmi2 = iloc(2) + njmpp - 1 802 iloc = MAXLOC( e1t(:,:), mask = tmask(:,:,1) == 1.e0 ) 803 iima1 = iloc(1) + nimpp - 1 804 ijma1 = iloc(2) + njmpp - 1 805 iloc = MAXLOC( e2t(:,:), mask = tmask(:,:,1) == 1.e0 ) 806 iima2 = iloc(1) + nimpp - 1 807 ijma2 = iloc(2) + njmpp - 1 808 ENDIF 809 810 IF(lwp) THEN 811 WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1 812 WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 813 WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 814 WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 815 ENDIF 816 817 END SUBROUTINE dom_ctl 882 818 883 819 !!====================================================================== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90
r7256 r7806 22 22 USE c1d ! 1D configuration: lk_c1d 23 23 USE dom_oce ! ocean domain: variables 24 USE domvvl ! variable volume 24 25 USE zdf_oce ! ocean vertical physics: variables 25 26 USE sbc_oce ! surface module: variables … … 28 29 USE trabbl ! active tracer: bottom boundary layer 29 30 USE ldfslp ! lateral diffusion: iso-neutral slopes 31 USE sbcrnf ! river runoffs 30 32 USE ldfeiv ! eddy induced velocity coef. 31 33 USE ldftra_oce ! ocean tracer lateral physics … … 39 41 USE prtctl ! print control 40 42 USE fldread ! read input fields 43 USE wrk_nemo ! Memory allocation 41 44 USE timing ! Timing 45 USE trc, ONLY : ln_rsttr, numrtr, numrtw, lrst_trc 42 46 43 47 IMPLICIT NONE … … 46 50 PUBLIC dta_dyn_init ! called by opa.F90 47 51 PUBLIC dta_dyn ! called by step.F90 48 49 CHARACTER(len=100) :: cn_dir !: Root directory for location of ssr files 50 LOGICAL :: ln_dynwzv !: vertical velocity read in a file (T) or computed from u/v (F) 51 LOGICAL :: ln_dynbbl !: bbl coef read in a file (T) or computed (F) 52 LOGICAL :: ln_degrad !: degradation option enabled or not 53 LOGICAL :: ln_dynrnf !: read runoff data in file (T) or set to zero (F) 54 55 INTEGER , PARAMETER :: jpfld = 21 ! maximum number of fields to read 52 PUBLIC dta_dyn_swp ! called by step.F90 53 54 CHARACTER(len=100) :: cn_dir !: Root directory for location of ssr files 55 LOGICAL :: ln_ssh_ini !: initial ssh from dyn file (T) or not (F) - ssh is then read from passive tracer restart 56 LOGICAL :: ln_dynrnf !: read runoff data in file (T) or set to zero (F) 57 LOGICAL :: ln_dynrnf_depth !: read runoff data in file (T) or set to zero (F) 58 REAL(wp) :: fwbcorr 59 60 61 INTEGER , PARAMETER :: jpfld = 20 ! maximum number of fields to read 56 62 INTEGER , SAVE :: jf_tem ! index of temperature 57 63 INTEGER , SAVE :: jf_sal ! index of salinity 58 INTEGER , SAVE :: jf_uwd ! index of u- wind59 INTEGER , SAVE :: jf_vwd ! index of v- wind60 INTEGER , SAVE :: jf_wwd ! index of w-wind64 INTEGER , SAVE :: jf_uwd ! index of u-transport 65 INTEGER , SAVE :: jf_vwd ! index of v-transport 66 INTEGER , SAVE :: jf_wwd ! index of v-transport 61 67 INTEGER , SAVE :: jf_avt ! index of Kz 62 68 INTEGER , SAVE :: jf_mld ! index of mixed layer deptht 63 69 INTEGER , SAVE :: jf_emp ! index of water flux 70 INTEGER , SAVE :: jf_empb ! index of water flux 64 71 INTEGER , SAVE :: jf_qsr ! index of solar radiation 65 72 INTEGER , SAVE :: jf_wnd ! index of wind speed 66 73 INTEGER , SAVE :: jf_ice ! index of sea ice cover 67 74 INTEGER , SAVE :: jf_rnf ! index of river runoff 75 INTEGER , SAVE :: jf_fmf ! index of downward salt flux 68 76 INTEGER , SAVE :: jf_ubl ! index of u-bbl coef 69 77 INTEGER , SAVE :: jf_vbl ! index of v-bbl coef 70 INTEGER , SAVE :: jf_ahu ! index of u-diffusivity coef 71 INTEGER , SAVE :: jf_ahv ! index of v-diffusivity coef 72 INTEGER , SAVE :: jf_ahw ! index of w-diffusivity coef 73 INTEGER , SAVE :: jf_eiu ! index of u-eiv 74 INTEGER , SAVE :: jf_eiv ! index of v-eiv 75 INTEGER , SAVE :: jf_eiw ! index of w-eiv 76 INTEGER , SAVE :: jf_fmf ! index of downward salt flux 77 78 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_dyn ! structure of input fields (file informations, fields read) 78 INTEGER , SAVE :: jf_div ! index of e3t 79 80 81 TYPE(FLD), ALLOCATABLE, SAVE, DIMENSION(:) :: sf_dyn ! structure of input fields (file informations, fields read) 79 82 ! ! 80 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wdta ! vertical velocity at 2 time step81 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,: ) :: wnow ! vertical velocity at 2 time step82 83 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uslpdta ! zonal isopycnal slopes 83 84 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: vslpdta ! meridional isopycnal slopes 84 85 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpidta ! zonal diapycnal slopes 85 86 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpjdta ! meridional diapycnal slopes 86 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslpnow ! zonal isopycnal slopes 87 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslpnow ! meridional isopycnal slopes 88 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslpinow ! zonal diapycnal slopes 89 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslpjnow ! meridional diapycnal slopes 90 91 INTEGER :: nrecprev_tem , nrecprev_uwd 87 88 INTEGER, SAVE :: nprevrec, nsecdyn 92 89 93 90 !! * Substitutions … … 113 110 !!---------------------------------------------------------------------- 114 111 ! 115 USE oce, ONLY: zts => tsa 116 USE oce, ONLY: zuslp => ua , zvslp => va 117 USE oce, ONLY: zwslpi => rotb , zwslpj => rotn 118 USE oce, ONLY: zu => ub , zv => vb, zw => hdivb 119 ! 112 USE oce, ONLY: zhdivtr => ua 120 113 INTEGER, INTENT(in) :: kt ! ocean time-step index 121 ! 122 INTEGER :: ji, jj ! dummy loop indices 123 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 124 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 125 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 126 INTEGER :: iswap_tem, iswap_uwd ! 114 INTEGER :: ji, jj, jk 115 REAL(wp), POINTER, DIMENSION(:,:) :: zemp 116 ! 127 117 !!---------------------------------------------------------------------- 128 118 … … 130 120 IF( nn_timing == 1 ) CALL timing_start( 'dta_dyn') 131 121 ! 132 isecsbc = nsec_year + nsec1jan000 133 ! 134 IF( kt == nit000 ) THEN 135 nrecprev_tem = 0 136 nrecprev_uwd = 0 137 ! 138 CALL fld_read( kt, 1, sf_dyn ) !== read data at kt time step ==! 139 ! 140 IF( lk_ldfslp .AND. .NOT.lk_c1d .AND. sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace) 141 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:) ! temperature 142 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:) ! salinity 143 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:) ! vertical diffusive coef. 144 CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 145 uslpdta (:,:,:,1) = zuslp (:,:,:) 146 vslpdta (:,:,:,1) = zvslp (:,:,:) 147 wslpidta(:,:,:,1) = zwslpi(:,:,:) 148 wslpjdta(:,:,:,1) = zwslpj(:,:,:) 149 ENDIF 150 IF( ln_dynwzv .AND. sf_dyn(jf_uwd)%ln_tint ) THEN ! compute vertical velocity from u/v 151 zu(:,:,:) = sf_dyn(jf_uwd)%fdta(:,:,:,1) 152 zv(:,:,:) = sf_dyn(jf_vwd)%fdta(:,:,:,1) 153 CALL dta_dyn_wzv( zu, zv, zw ) 154 wdta(:,:,:,1) = zw(:,:,:) * tmask(:,:,:) 155 ENDIF 156 ELSE 157 nrecprev_tem = sf_dyn(jf_tem)%nrec_a(2) 158 nrecprev_uwd = sf_dyn(jf_uwd)%nrec_a(2) 159 ! 160 CALL fld_read( kt, 1, sf_dyn ) !== read data at kt time step ==! 161 ! 162 ENDIF 163 ! 164 IF( lk_ldfslp .AND. .NOT.lk_c1d ) THEN ! Computes slopes (here avt is used as workspace) 165 iswap_tem = 0 166 IF( kt /= nit000 .AND. ( sf_dyn(jf_tem)%nrec_a(2) - nrecprev_tem ) /= 0 ) iswap_tem = 1 167 IF( ( isecsbc > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap_tem == 1 ) .OR. kt == nit000 ) THEN ! read/update the after data 168 IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 169 IF( sf_dyn(jf_tem)%ln_tint ) THEN ! time interpolation of data 170 IF( kt /= nit000 ) THEN 171 uslpdta (:,:,:,1) = uslpdta (:,:,:,2) ! swap the data 172 vslpdta (:,:,:,1) = vslpdta (:,:,:,2) 173 wslpidta(:,:,:,1) = wslpidta(:,:,:,2) 174 wslpjdta(:,:,:,1) = wslpjdta(:,:,:,2) 175 ENDIF 176 ! 177 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature 178 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity 179 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef. 180 CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 181 ! 182 uslpdta (:,:,:,2) = zuslp (:,:,:) 183 vslpdta (:,:,:,2) = zvslp (:,:,:) 184 wslpidta(:,:,:,2) = zwslpi(:,:,:) 185 wslpjdta(:,:,:,2) = zwslpj(:,:,:) 186 ELSE 187 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) 188 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) 189 avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) 190 CALL dta_dyn_slp( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 191 uslpnow (:,:,:) = zuslp (:,:,:) 192 vslpnow (:,:,:) = zvslp (:,:,:) 193 wslpinow(:,:,:) = zwslpi(:,:,:) 194 wslpjnow(:,:,:) = zwslpj(:,:,:) 195 ENDIF 196 ENDIF 197 IF( sf_dyn(jf_tem)%ln_tint ) THEN 198 ztinta = REAL( isecsbc - sf_dyn(jf_tem)%nrec_b(2), wp ) & 199 & / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp ) 200 ztintb = 1. - ztinta 201 uslp (:,:,:) = ztintb * uslpdta (:,:,:,1) + ztinta * uslpdta (:,:,:,2) 202 vslp (:,:,:) = ztintb * vslpdta (:,:,:,1) + ztinta * vslpdta (:,:,:,2) 203 wslpi(:,:,:) = ztintb * wslpidta(:,:,:,1) + ztinta * wslpidta(:,:,:,2) 204 wslpj(:,:,:) = ztintb * wslpjdta(:,:,:,1) + ztinta * wslpjdta(:,:,:,2) 205 ELSE 206 uslp (:,:,:) = uslpnow (:,:,:) 207 vslp (:,:,:) = vslpnow (:,:,:) 208 wslpi(:,:,:) = wslpinow(:,:,:) 209 wslpj(:,:,:) = wslpjnow(:,:,:) 210 ENDIF 211 ENDIF 212 ! 213 IF( ln_dynwzv ) THEN ! compute vertical velocity from u/v 214 iswap_uwd = 0 215 IF( kt /= nit000 .AND. ( sf_dyn(jf_uwd)%nrec_a(2) - nrecprev_uwd ) /= 0 ) iswap_uwd = 1 216 IF( ( isecsbc > sf_dyn(jf_uwd)%nrec_b(2) .AND. iswap_uwd == 1 ) .OR. kt == nit000 ) THEN ! read/update the after data 217 IF(lwp) WRITE(numout,*) ' Compute new vertical velocity at kt = ', kt 218 IF(lwp) WRITE(numout,*) 219 IF( sf_dyn(jf_uwd)%ln_tint ) THEN ! time interpolation of data 220 IF( kt /= nit000 ) THEN 221 wdta(:,:,:,1) = wdta(:,:,:,2) ! swap the data for initialisation 222 ENDIF 223 zu(:,:,:) = sf_dyn(jf_uwd)%fdta(:,:,:,2) 224 zv(:,:,:) = sf_dyn(jf_vwd)%fdta(:,:,:,2) 225 CALL dta_dyn_wzv( zu, zv, zw ) 226 wdta(:,:,:,2) = zw(:,:,:) * tmask(:,:,:) 227 ELSE 228 zu(:,:,:) = sf_dyn(jf_uwd)%fnow(:,:,:) 229 zv(:,:,:) = sf_dyn(jf_vwd)%fnow(:,:,:) 230 CALL dta_dyn_wzv( zu, zv, zw ) 231 wnow(:,:,:) = zw(:,:,:) * tmask(:,:,:) 232 ENDIF 233 ENDIF 234 IF( sf_dyn(jf_uwd)%ln_tint ) THEN 235 ztinta = REAL( isecsbc - sf_dyn(jf_uwd)%nrec_b(2), wp ) & 236 & / REAL( sf_dyn(jf_uwd)%nrec_a(2) - sf_dyn(jf_uwd)%nrec_b(2), wp ) 237 ztintb = 1. - ztinta 238 wn(:,:,:) = ztintb * wdta(:,:,:,1) + ztinta * wdta(:,:,:,2) 239 ELSE 240 wn(:,:,:) = wnow(:,:,:) 241 ENDIF 242 ENDIF 122 ! 123 nsecdyn = nsec_year + nsec1jan000 ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 124 ! 125 IF( kt == nit000 ) THEN ; nprevrec = 0 126 ELSE ; nprevrec = sf_dyn(jf_tem)%nrec_a(2) 127 ENDIF 128 ! 129 CALL fld_read( kt, 1, sf_dyn ) != read data at kt time step ==! 130 ! 131 IF( lk_ldfslp .AND. .NOT.lk_c1d ) CALL dta_dyn_slp( kt ) ! Computation of slopes 243 132 ! 244 133 tsn(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature 245 134 tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity 246 ! 135 wndm(:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1) ! wind speed - needed for gas exchange 136 fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1) ! downward salt flux (v3.5+) 137 fr_i(:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1) ! Sea-ice fraction 138 qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1) ! solar radiation 139 emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1) ! E-P 140 IF( ln_dynrnf ) THEN 141 rnf (:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! E-P 142 IF( ln_dynrnf_depth .AND. lk_vvl ) CALL dta_dyn_hrnf 143 ENDIF 144 ! 145 un(:,:,:) = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:) ! effective u-transport 146 vn(:,:,:) = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:) ! effective v-transport 147 wn(:,:,:) = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:) ! effective v-transport 148 ! 149 IF( lk_vvl ) THEN 150 CALL wrk_alloc(jpi, jpj, zemp ) 151 zhdivtr(:,:,:) = sf_dyn(jf_div)%fnow(:,:,:) * tmask(:,:,:) ! effective u-transport 152 emp_b (:,:) = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1) ! E-P 153 zemp(:,:) = 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr * tmask(:,:,1) 154 CALL dta_dyn_ssh( kt, zhdivtr, sshb, zemp, ssha, fse3t_a(:,:,:) ) != ssh, vertical scale factor & vertical transport 155 CALL wrk_dealloc(jpi, jpj, zemp ) 156 ! Write in the tracer restart file 157 ! ******************************* 158 IF( lrst_trc ) THEN 159 IF(lwp) WRITE(numout,*) 160 IF(lwp) WRITE(numout,*) 'dta_dyn_ssh : ssh field written in tracer restart file ', & 161 & 'at it= ', kt,' date= ', ndastp 162 IF(lwp) WRITE(numout,*) '~~~~' 163 CALL iom_rstput( kt, nitrst, numrtw, 'sshn', ssha ) 164 CALL iom_rstput( kt, nitrst, numrtw, 'sshb', sshn ) 165 ENDIF 166 ENDIF 247 167 ! 248 168 CALL eos ( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop … … 251 171 252 172 rn2b(:,:,:) = rn2(:,:,:) ! need for zdfmxl 253 CALL zdf_mxl( kt ) ! In any case, we need mxl 254 ! 255 avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coefficient 256 un (:,:,:) = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:) ! u-velocity 257 vn (:,:,:) = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:) ! v-velocity 258 IF( .NOT.ln_dynwzv ) & ! w-velocity read in file 259 wn (:,:,:) = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:) 260 hmld(:,:) = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1) ! mixed layer depht 261 wndm(:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1) ! wind speed - needed for gas exchange 262 emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1) ! E-P 263 fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1) ! downward salt flux (v3.5+) 264 fr_i(:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1) ! Sea-ice fraction 265 qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1) ! solar radiation 266 IF( ln_dynrnf ) & 267 rnf (:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! river runoffs 268 269 ! ! bbl diffusive coef 173 CALL zdf_mxl( kt ) ! In any case, we need mxl 174 ! 175 hmld(:,:) = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1) ! mixed layer depht 176 avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coefficient 177 ! 270 178 #if defined key_trabbl && ! defined key_c1d 271 IF( ln_dynbbl ) THEN ! read in a file 272 ahu_bbl(:,:) = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1) 273 ahv_bbl(:,:) = sf_dyn(jf_vbl)%fnow(:,:,1) * vmask(:,:,1) 274 ELSE ! Compute bbl coefficients if needed 275 tsb(:,:,:,:) = tsn(:,:,:,:) 276 CALL bbl( kt, nit000, 'TRC') 277 END IF 179 ahu_bbl(:,:) = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1) ! bbl diffusive coef 180 ahv_bbl(:,:) = sf_dyn(jf_vbl)%fnow(:,:,1) * vmask(:,:,1) 278 181 #endif 279 #if ( ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv ) && ! defined key_c1d 280 aeiw(:,:) = sf_dyn(jf_eiw)%fnow(:,:,1) * tmask(:,:,1) ! w-eiv 281 ! ! Computes the horizontal values from the vertical value 282 DO jj = 2, jpjm1 283 DO ji = fs_2, fs_jpim1 ! vector opt. 284 aeiu(ji,jj) = .5 * ( aeiw(ji,jj) + aeiw(ji+1,jj ) ) ! Average the diffusive coefficient at u- v- points 285 aeiv(ji,jj) = .5 * ( aeiw(ji,jj) + aeiw(ji ,jj+1) ) ! at u- v- points 286 END DO 287 END DO 288 CALL lbc_lnk( aeiu, 'U', 1. ) ; CALL lbc_lnk( aeiv, 'V', 1. ) ! lateral boundary condition 289 #endif 290 291 #if defined key_degrad && ! defined key_c1d 292 ! ! degrad option : diffusive and eiv coef are 3D 293 ahtu(:,:,:) = sf_dyn(jf_ahu)%fnow(:,:,:) * umask(:,:,:) 294 ahtv(:,:,:) = sf_dyn(jf_ahv)%fnow(:,:,:) * vmask(:,:,:) 295 ahtw(:,:,:) = sf_dyn(jf_ahw)%fnow(:,:,:) * tmask(:,:,:) 296 # if defined key_traldf_eiv 297 aeiu(:,:,:) = sf_dyn(jf_eiu)%fnow(:,:,:) * umask(:,:,:) 298 aeiv(:,:,:) = sf_dyn(jf_eiv)%fnow(:,:,:) * vmask(:,:,:) 299 aeiw(:,:,:) = sf_dyn(jf_eiw)%fnow(:,:,:) * tmask(:,:,:) 300 # endif 301 #endif 182 ! 183 ! 184 CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop 302 185 ! 303 186 IF(ln_ctl) THEN ! print control … … 308 191 CALL prt_ctl(tab3d_1=wn , clinfo1=' wn - : ', mask1=tmask, ovlap=1, kdim=jpk ) 309 192 CALL prt_ctl(tab3d_1=avt , clinfo1=' kz - : ', mask1=tmask, ovlap=1, kdim=jpk ) 310 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask, ovlap=1 )311 CALL prt_ctl(tab2d_1=hmld , clinfo1=' hmld - : ', mask1=tmask, ovlap=1 )312 CALL prt_ctl(tab2d_1=fmmflx , clinfo1=' fmmflx - : ', mask1=tmask, ovlap=1 )313 CALL prt_ctl(tab2d_1=emp , clinfo1=' emp - : ', mask1=tmask, ovlap=1 )314 CALL prt_ctl(tab2d_1=wndm , clinfo1=' wspd - : ', mask1=tmask, ovlap=1 )315 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask, ovlap=1 )193 ! CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask, ovlap=1 ) 194 ! CALL prt_ctl(tab2d_1=hmld , clinfo1=' hmld - : ', mask1=tmask, ovlap=1 ) 195 ! CALL prt_ctl(tab2d_1=fmmflx , clinfo1=' fmmflx - : ', mask1=tmask, ovlap=1 ) 196 ! CALL prt_ctl(tab2d_1=emp , clinfo1=' emp - : ', mask1=tmask, ovlap=1 ) 197 ! CALL prt_ctl(tab2d_1=wndm , clinfo1=' wspd - : ', mask1=tmask, ovlap=1 ) 198 ! CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask, ovlap=1 ) 316 199 ENDIF 317 200 ! … … 335 218 INTEGER :: inum, idv, idimv ! local integer 336 219 INTEGER :: ios ! Local integer output status for namelist read 337 !! 338 CHARACTER(len=100) :: cn_dir ! Root directory for location of core files 339 TYPE(FLD_N), DIMENSION(jpfld) :: slf_d ! array of namelist informations on the fields to read 340 TYPE(FLD_N) :: sn_tem, sn_sal, sn_mld, sn_emp, sn_ice, sn_qsr, sn_wnd, sn_rnf ! informations about the fields to be read 341 TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_avt, sn_ubl, sn_vbl ! " " 342 TYPE(FLD_N) :: sn_ahu, sn_ahv, sn_ahw, sn_eiu, sn_eiv, sn_eiw, sn_fmf ! " " 343 !!---------------------------------------------------------------------- 344 ! 345 NAMELIST/namdta_dyn/cn_dir, ln_dynwzv, ln_dynbbl, ln_degrad, ln_dynrnf, & 346 & sn_tem, sn_sal, sn_mld, sn_emp, sn_ice, sn_qsr, sn_wnd, sn_rnf, & 347 & sn_uwd, sn_vwd, sn_wwd, sn_avt, sn_ubl, sn_vbl, & 348 & sn_ahu, sn_ahv, sn_ahw, sn_eiu, sn_eiv, sn_eiw, sn_fmf 220 INTEGER :: ji, jj, jk 221 REAL(wp) :: zcoef 222 INTEGER :: nkrnf_max 223 REAL(wp) :: hrnf_max 224 !! 225 CHARACTER(len=100) :: cn_dir ! Root directory for location of core files 226 TYPE(FLD_N), DIMENSION(jpfld) :: slf_d ! array of namelist informations on the fields to read 227 TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_empb, sn_emp ! informations about the fields to be read 228 TYPE(FLD_N) :: sn_tem , sn_sal , sn_avt ! " " 229 TYPE(FLD_N) :: sn_mld, sn_qsr, sn_wnd , sn_ice , sn_fmf ! " " 230 TYPE(FLD_N) :: sn_ubl, sn_vbl, sn_rnf ! " " 231 TYPE(FLD_N) :: sn_div ! informations about the fields to be read 232 !!---------------------------------------------------------------------- 233 234 NAMELIST/namdta_dyn/cn_dir, ln_dynrnf, ln_dynrnf_depth, ln_ssh_ini, fwbcorr, & 235 & sn_uwd, sn_vwd, sn_wwd, sn_emp, & 236 & sn_avt, sn_tem, sn_sal, sn_mld , sn_qsr , & 237 & sn_wnd, sn_ice, sn_fmf, & 238 & sn_ubl, sn_vbl, sn_rnf, & 239 & sn_empb, sn_div 349 240 ! 350 241 REWIND( numnam_ref ) ! Namelist namdta_dyn in reference namelist : Offline: init. of dynamical data … … 363 254 WRITE(numout,*) '~~~~~~~ ' 364 255 WRITE(numout,*) ' Namelist namdta_dyn' 365 WRITE(numout,*) ' vertical velocity read from file (T) or computed (F) ln_dynwzv = ', ln_dynwzv366 WRITE(numout,*) ' bbl coef read from file (T) or computed (F) ln_dynbbl = ', ln_dynbbl367 WRITE(numout,*) ' degradation option enabled (T) or not (F) ln_degrad = ', ln_degrad368 WRITE(numout,*) ' river runoff option enabled (T) or not (F) ln_dynrnf = ', ln_dynrnf256 WRITE(numout,*) ' ssh initialised from dyn file (T) or not (F) ln_ssh_ini = ', ln_ssh_ini 257 WRITE(numout,*) ' runoffs option enabled (T) or not (F) ln_dynrnf = ', ln_dynrnf 258 WRITE(numout,*) ' runoffs is spread in vertical ln_dynrnf_depth = ', ln_dynrnf_depth 259 WRITE(numout,*) ' annual global mean of empmr for ssh correction fwbcorr = ', fwbcorr 369 260 WRITE(numout,*) 370 261 ENDIF 371 262 ! 372 IF( ln_degrad .AND. .NOT.lk_degrad ) THEN 373 CALL ctl_warn( 'dta_dyn_init: degradation option requires key_degrad activated ; force ln_degrad to false' ) 374 ln_degrad = .FALSE. 375 ENDIF 376 IF( ln_dynbbl .AND. ( .NOT.lk_trabbl .OR. lk_c1d ) ) THEN 377 CALL ctl_warn( 'dta_dyn_init: bbl option requires key_trabbl activated ; force ln_dynbbl to false' ) 378 ln_dynbbl = .FALSE. 379 ENDIF 380 381 jf_tem = 1 ; jf_sal = 2 ; jf_mld = 3 ; jf_emp = 4 ; jf_fmf = 5 ; jf_ice = 6 ; jf_qsr = 7 382 jf_wnd = 8 ; jf_uwd = 9 ; jf_vwd = 10 ; jf_wwd = 11 ; jf_avt = 12 ; jfld = jf_avt 383 ! 384 slf_d(jf_tem) = sn_tem ; slf_d(jf_sal) = sn_sal ; slf_d(jf_mld) = sn_mld 385 slf_d(jf_emp) = sn_emp ; slf_d(jf_fmf ) = sn_fmf ; slf_d(jf_ice) = sn_ice 386 slf_d(jf_qsr) = sn_qsr ; slf_d(jf_wnd) = sn_wnd ; slf_d(jf_avt) = sn_avt 387 slf_d(jf_uwd) = sn_uwd ; slf_d(jf_vwd) = sn_vwd ; slf_d(jf_wwd) = sn_wwd 388 263 264 jf_uwd = 1 ; jf_vwd = 2 ; jf_wwd = 3 ; jf_emp = 4 ; jf_avt = 5 265 jf_tem = 6 ; jf_sal = 7 ; jf_mld = 8 ; jf_qsr = 9 266 jf_wnd = 10 ; jf_ice = 11 ; jf_fmf = 12 ; jfld = jf_fmf 267 268 ! 269 slf_d(jf_uwd) = sn_uwd ; slf_d(jf_vwd) = sn_vwd ; slf_d(jf_wwd) = sn_wwd 270 slf_d(jf_emp) = sn_emp ; slf_d(jf_avt) = sn_avt 271 slf_d(jf_tem) = sn_tem ; slf_d(jf_sal) = sn_sal ; slf_d(jf_mld) = sn_mld 272 slf_d(jf_qsr) = sn_qsr ; slf_d(jf_wnd) = sn_wnd ; slf_d(jf_ice) = sn_ice 273 slf_d(jf_fmf) = sn_fmf 274 275 276 ! 277 IF( lk_vvl ) THEN 278 jf_div = jfld + 1 ; jf_empb = jfld + 2 ; jfld = jf_empb 279 slf_d(jf_div) = sn_div ; slf_d(jf_empb) = sn_empb 280 ENDIF 281 ! 282 IF( lk_trabbl ) THEN 283 jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; jfld = jf_vbl 284 slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl 285 ENDIF 389 286 ! 390 287 IF( ln_dynrnf ) THEN 391 jf_rnf = jfld + 1 ;jfld = jf_rnf392 slf_d(jf_rnf) = sn_rnf288 jf_rnf = jfld + 1 ; jfld = jf_rnf 289 slf_d(jf_rnf) = sn_rnf 393 290 ELSE 394 rnf (:,:) = 0._wp 395 ENDIF 396 397 ! 398 IF( .NOT.ln_degrad ) THEN ! no degrad option 399 IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN ! eiv & bbl 400 jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; jf_eiw = jfld + 3 ; jfld = jf_eiw 401 slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl ; slf_d(jf_eiw) = sn_eiw 402 ENDIF 403 IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN ! no eiv & bbl 404 jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; jfld = jf_vbl 405 slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl 406 ENDIF 407 IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN ! eiv & no bbl 408 jf_eiw = jfld + 1 ; jfld = jf_eiw ; slf_d(jf_eiw) = sn_eiw 409 ENDIF 410 ELSE 411 jf_ahu = jfld + 1 ; jf_ahv = jfld + 2 ; jf_ahw = jfld + 3 ; jfld = jf_ahw 412 slf_d(jf_ahu) = sn_ahu ; slf_d(jf_ahv) = sn_ahv ; slf_d(jf_ahw) = sn_ahw 413 IF( lk_traldf_eiv .AND. ln_dynbbl ) THEN ! eiv & bbl 414 jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; 415 slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl 416 jf_eiu = jfld + 3 ; jf_eiv = jfld + 4 ; jf_eiw = jfld + 5 ; jfld = jf_eiw 417 slf_d(jf_eiu) = sn_eiu ; slf_d(jf_eiv) = sn_eiv ; slf_d(jf_eiw) = sn_eiw 418 ENDIF 419 IF( .NOT.lk_traldf_eiv .AND. ln_dynbbl ) THEN ! no eiv & bbl 420 jf_ubl = jfld + 1 ; jf_vbl = jfld + 2 ; jfld = jf_vbl 421 slf_d(jf_ubl) = sn_ubl ; slf_d(jf_vbl) = sn_vbl 422 ENDIF 423 IF( lk_traldf_eiv .AND. .NOT.ln_dynbbl ) THEN ! eiv & no bbl 424 jf_eiu = jfld + 1 ; jf_eiv = jfld + 2 ; jf_eiw = jfld + 3 ; jfld = jf_eiw 425 slf_d(jf_eiu) = sn_eiu ; slf_d(jf_eiv) = sn_eiv ; slf_d(jf_eiw) = sn_eiw 426 ENDIF 427 ENDIF 291 rnf(:,:) = 0._wp 292 ENDIF 293 428 294 429 295 ALLOCATE( sf_dyn(jfld), STAT=ierr ) ! set sf structure 430 IF( ierr > 0 ) THEN296 IF( ierr > 0 ) THEN 431 297 CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' ) ; RETURN 432 298 ENDIF 433 299 ! ! fill sf with slf_i and control print 434 300 CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 301 ! 435 302 ! Open file for each variable to get his number of dimension 436 303 DO ifpr = 1, jfld … … 456 323 ALLOCATE( uslpdta (jpi,jpj,jpk,2), vslpdta (jpi,jpj,jpk,2), & 457 324 & wslpidta(jpi,jpj,jpk,2), wslpjdta(jpi,jpj,jpk,2), STAT=ierr2 ) 458 ELSE 459 ALLOCATE( uslpnow (jpi,jpj,jpk) , vslpnow (jpi,jpj,jpk) , & 460 & wslpinow(jpi,jpj,jpk) , wslpjnow(jpi,jpj,jpk) , STAT=ierr2 ) 461 ENDIF 462 IF( ierr2 > 0 ) THEN 463 CALL ctl_stop( 'dta_dyn_init : unable to allocate slope arrays' ) ; RETURN 325 ! 326 IF( ierr2 > 0 ) THEN 327 CALL ctl_stop( 'dta_dyn_init : unable to allocate slope arrays' ) ; RETURN 328 ENDIF 464 329 ENDIF 465 330 ENDIF 466 IF( ln_dynwzv ) THEN ! slopes 467 IF( sf_dyn(jf_uwd)%ln_tint ) THEN ! time interpolation 468 ALLOCATE( wdta(jpi,jpj,jpk,2), STAT=ierr3 ) 469 ELSE 470 ALLOCATE( wnow(jpi,jpj,jpk) , STAT=ierr3 ) 471 ENDIF 472 IF( ierr3 > 0 ) THEN 473 CALL ctl_stop( 'dta_dyn_init : unable to allocate wdta arrays' ) ; RETURN 474 ENDIF 475 ENDIF 476 ! 477 CALL dta_dyn( nit000 ) 478 ! 479 END SUBROUTINE dta_dyn_init 480 481 SUBROUTINE dta_dyn_wzv( pu, pv, pw ) 482 !!---------------------------------------------------------------------- 483 !! *** ROUTINE wzv *** 484 !! 485 !! ** Purpose : Compute the now vertical velocity after the array swap 486 !! 487 !! ** Method : - compute the now divergence given by : 488 !! * z-coordinate ONLY !!!! 489 !! hdiv = 1/(e1t*e2t) [ di(e2u u) + dj(e1v v) ] 490 !! - Using the incompressibility hypothesis, the vertical 491 !! velocity is computed by integrating the horizontal divergence 492 !! from the bottom to the surface. 493 !! The boundary conditions are w=0 at the bottom (no flux). 494 !!---------------------------------------------------------------------- 495 USE oce, ONLY: zhdiv => hdivn 496 ! 497 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv !: horizontal velocities 498 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: pw !: vertical velocity 499 !! 500 INTEGER :: ji, jj, jk 501 REAL(wp) :: zu, zu1, zv, zv1, zet 502 !!---------------------------------------------------------------------- 503 ! 504 ! Computation of vertical velocity using horizontal divergence 505 zhdiv(:,:,:) = 0._wp 506 DO jk = 1, jpkm1 507 DO jj = 2, jpjm1 508 DO ji = fs_2, fs_jpim1 ! vector opt. 509 zu = pu(ji ,jj ,jk) * umask(ji ,jj ,jk) * e2u(ji ,jj ) * fse3u(ji ,jj ,jk) 510 zu1 = pu(ji-1,jj ,jk) * umask(ji-1,jj ,jk) * e2u(ji-1,jj ) * fse3u(ji-1,jj ,jk) 511 zv = pv(ji ,jj ,jk) * vmask(ji ,jj ,jk) * e1v(ji ,jj ) * fse3v(ji ,jj ,jk) 512 zv1 = pv(ji ,jj-1,jk) * vmask(ji ,jj-1,jk) * e1v(ji ,jj-1) * fse3v(ji ,jj-1,jk) 513 zet = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 514 zhdiv(ji,jj,jk) = ( zu - zu1 + zv - zv1 ) * zet 331 ! 332 IF( lk_vvl ) THEN 333 IF( ln_ssh_ini ) THEN ! Restart: read in restart file 334 IF(lwp) WRITE(numout,*) ' sshn forcing fields read in the dynamics restart file for initialisation' 335 CALL iom_open( 'restart', inum ) 336 CALL iom_get( inum, jpdom_autoglo, 'sshn', sshn(:,:) ) 337 CALL iom_get( inum, jpdom_autoglo, 'sshb', sshb(:,:) ) 338 CALL iom_close( inum ) ! close file 339 ELSE 340 IF(lwp) WRITE(numout,*) ' sshn forcing fields read in passive tracers restart file for initialisation' 341 CALL iom_get( numrtr, jpdom_autoglo, 'sshn', sshn(:,:) ) 342 CALL iom_get( numrtr, jpdom_autoglo, 'sshb', sshb(:,:) ) 343 ENDIF 344 ! 345 DO jk = 1, jpkm1 346 fse3t_n(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + sshn(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 347 ENDDO 348 fse3t_a(:,:,jpk) = e3t_0(:,:,jpk) 349 350 ! Horizontal scale factor interpolations 351 ! -------------------------------------- 352 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 353 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 354 355 ! Vertical scale factor interpolations 356 ! ------------------------------------ 357 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n(:,:,:), 'W' ) 358 359 fse3t_b(:,:,:) = fse3t_n(:,:,:) 360 fse3u_b(:,:,:) = fse3u_n(:,:,:) 361 fse3v_b(:,:,:) = fse3v_n(:,:,:) 362 363 ! t- and w- points depth 364 ! ---------------------- 365 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 366 fsdepw_n(:,:,1) = 0.0_wp 367 368 DO jk = 2, jpk 369 DO jj = 1,jpj 370 DO ji = 1,jpi 371 ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere 372 ! tmask = wmask, ie everywhere expect at jk = mikt 373 ! 1 for jk = 374 ! mikt 375 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 376 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 377 fsdept_n(ji,jj,jk) = zcoef * ( fsdepw_n(ji,jj,jk ) + 0.5 * fse3w_n(ji,jj,jk)) & 378 & + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 379 END DO 380 END DO 381 END DO 382 383 fsdept_b(:,:,:) = fsdept_n(:,:,:) 384 fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 385 ! 386 ENDIF 387 ! 388 IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed 389 IF(lwp) WRITE(numout,*) 390 IF(lwp) WRITE(numout,*) ' read in the file depht over which runoffs are distributed' 391 CALL iom_open ( "runoffs", inum ) ! open file 392 CALL iom_get ( inum, jpdom_data, 'rodepth', h_rnf ) ! read the river mouth array 393 CALL iom_close( inum ) ! close file 394 ! 395 nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied 396 DO jj = 1, jpj 397 DO ji = 1, jpi 398 IF( h_rnf(ji,jj) > 0._wp ) THEN 399 jk = 2 400 DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 401 END DO 402 nk_rnf(ji,jj) = jk 403 ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 404 ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) 405 ELSE 406 CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) 407 WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 408 ENDIF 515 409 END DO 516 410 END DO 411 DO jj = 1, jpj ! set the associated depth 412 DO ji = 1, jpi 413 h_rnf(ji,jj) = 0._wp 414 DO jk = 1, nk_rnf(ji,jj) 415 h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 416 END DO 417 END DO 418 END DO 419 ELSE ! runoffs applied at the surface 420 nk_rnf(:,:) = 1 421 h_rnf (:,:) = fse3t(:,:,1) 422 ENDIF 423 nkrnf_max = MAXVAL( nk_rnf(:,:) ) 424 hrnf_max = MAXVAL( h_rnf(:,:) ) 425 IF( lk_mpp ) THEN 426 CALL mpp_max( nkrnf_max ) ! max over the global domain 427 CALL mpp_max( hrnf_max ) ! max over the global domain 428 ENDIF 429 IF(lwp) WRITE(numout,*) ' ' 430 IF(lwp) WRITE(numout,*) ' max depht of runoff : ', hrnf_max,' max level : ', nkrnf_max 431 IF(lwp) WRITE(numout,*) ' ' 432 ! 433 CALL dta_dyn( nit000 ) 434 ! 435 END SUBROUTINE dta_dyn_init 436 437 SUBROUTINE dta_dyn_swp( kt ) 438 !!--------------------------------------------------------------------- 439 !! *** ROUTINE dta_dyn_swp *** 440 !! 441 !! ** Purpose : Swap and the data and compute the vertical scale factor at U/V/W point 442 !! and the depht 443 !! 444 !!--------------------------------------------------------------------- 445 INTEGER, INTENT(in) :: kt ! time step 446 INTEGER :: ji, jj, jk 447 REAL(wp) :: zcoef 448 ! 449 !!--------------------------------------------------------------------- 450 451 IF( kt == nit000 ) THEN 452 IF(lwp) WRITE(numout,*) 453 IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' 454 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 455 ENDIF 456 457 sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:)) ! before <-- now filtered 458 sshn(:,:) = ssha(:,:) 459 460 fse3t_n(:,:,:) = fse3t_a(:,:,:) 461 462 ! Reconstruction of all vertical scale factors at now and before time steps 463 ! ============================================================================= 464 465 ! Horizontal scale factor interpolations 466 ! -------------------------------------- 467 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 468 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 469 470 ! Vertical scale factor interpolations 471 ! ------------------------------------ 472 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 473 474 fse3t_b(:,:,:) = fse3t_n(:,:,:) 475 fse3u_b(:,:,:) = fse3u_n(:,:,:) 476 fse3v_b(:,:,:) = fse3v_n(:,:,:) 477 478 ! t- and w- points depth 479 ! ---------------------- 480 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 481 fsdepw_n(:,:,1) = 0.0_wp 482 483 DO jk = 2, jpk 484 DO jj = 1,jpj 485 DO ji = 1,jpi 486 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 487 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 488 fsdept_n(ji,jj,jk) = zcoef * ( fsdepw_n(ji,jj,jk ) + 0.5 * fse3w_n(ji,jj,jk)) & 489 & + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 490 END DO 491 END DO 492 END DO 493 494 fsdept_b(:,:,:) = fsdept_n(:,:,:) 495 fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 496 497 ! 498 END SUBROUTINE dta_dyn_swp 499 500 SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb, pemp, pssha, pe3ta ) 501 !!---------------------------------------------------------------------- 502 !! *** ROUTINE dta_dyn_wzv *** 503 !! 504 !! ** Purpose : compute the after ssh (ssha) and the now vertical velocity 505 !! 506 !! ** Method : Using the incompressibility hypothesis, 507 !! - the ssh increment is computed by integrating the horizontal divergence 508 !! and multiply by the time step. 509 !! 510 !! - compute the after scale factor : repartition of ssh INCREMENT proportionnaly 511 !! to the level thickness ( z-star case ) 512 !! 513 !! - the vertical velocity is computed by integrating the horizontal divergence 514 !! from the bottom to the surface minus the scale factor evolution. 515 !! The boundary conditions are w=0 at the bottom (no flux) 516 !! 517 !! ** action : ssha / e3t_a / wn 518 !! 519 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 520 !!---------------------------------------------------------------------- 521 !! * Arguments 522 INTEGER, INTENT(in ) :: kt ! time-step 523 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: phdivtr ! horizontal divergence transport 524 REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(in ) :: psshb ! now ssh 525 REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(in ) :: pemp ! evaporation minus precipitation 526 REAL(wp), DIMENSION(jpi,jpj) , OPTIONAL, INTENT(inout) :: pssha ! after ssh 527 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(out) :: pe3ta ! after vertical scale factor 528 !! * Local declarations 529 INTEGER :: jk 530 REAL(wp), DIMENSION(jpi,jpj) :: zhdiv 531 REAL(wp) :: z2dt 532 !!---------------------------------------------------------------------- 533 534 ! 535 z2dt = 2._wp * rdt 536 ! 537 zhdiv(:,:) = 0._wp 538 DO jk = 1, jpkm1 539 zhdiv(:,:) = zhdiv(:,:) + phdivtr(:,:,jk) * tmask(:,:,jk) 517 540 END DO 518 CALL lbc_lnk( zhdiv, 'T', 1. ) ! Lateral boundary conditions on zhdiv519 !520 ! computation of vertical velocity from the bottom521 pw(:,:,jpk) = 0._wp522 DO jk = jpkm1, 1, -1523 pw(:,:,jk) = pw(:,:,jk+1) - fse3t(:,:,jk) * zhdiv(:,:,jk)541 ! ! Sea surface elevation time-stepping 542 pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rau0 * pemp(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) 543 ! ! 544 ! ! After acale factors at t-points ( z_star coordinate ) 545 DO jk = 1, jpkm1 546 pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 524 547 END DO 525 548 ! 526 END SUBROUTINE dta_dyn_wzv 527 528 SUBROUTINE dta_dyn_slp( kt, pts, puslp, pvslp, pwslpi, pwslpj ) 549 END SUBROUTINE dta_dyn_ssh 550 551 552 SUBROUTINE dta_dyn_hrnf 553 !!---------------------------------------------------------------------- 554 !! *** ROUTINE sbc_rnf *** 555 !! 556 !! ** Purpose : update the horizontal divergence with the runoff inflow 557 !! 558 !! ** Method : 559 !! CAUTION : rnf is positive (inflow) decreasing the 560 !! divergence and expressed in m/s 561 !! 562 !! ** Action : phdivn decreased by the runoff inflow 563 !!---------------------------------------------------------------------- 564 !! 565 INTEGER :: ji, jj, jk ! dummy loop indices 566 !!---------------------------------------------------------------------- 567 ! 568 DO jj = 1, jpj ! update the depth over which runoffs are distributed 569 DO ji = 1, jpi 570 h_rnf(ji,jj) = 0._wp 571 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres 572 h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) ! to the bottom of the relevant grid box 573 END DO 574 END DO 575 END DO 576 ! 577 END SUBROUTINE dta_dyn_hrnf 578 579 580 581 SUBROUTINE dta_dyn_slp( kt ) 582 !!--------------------------------------------------------------------- 583 !! *** ROUTINE dta_dyn_slp *** 584 !! 585 !! ** Purpose : Computation of slope 586 !! 587 !!--------------------------------------------------------------------- 588 USE oce, ONLY: zts => tsa 589 ! 590 INTEGER, INTENT(in) :: kt ! time step 591 ! 592 INTEGER :: ji, jj ! dummy loop indices 593 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 594 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 595 INTEGER :: iswap 596 REAL(wp), POINTER, DIMENSION(:,:,:) :: zuslp, zvslp, zwslpi, zwslpj 597 !!--------------------------------------------------------------------- 598 ! 599 CALL wrk_alloc(jpi, jpj, jpk, zuslp, zvslp, zwslpi, zwslpj ) 600 ! 601 IF( sf_dyn(jf_tem)%ln_tint ) THEN ! Computes slopes (here avt is used as workspace) 602 IF( kt == nit000 ) THEN 603 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,1) * tmask(:,:,:) ! temperature 604 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,1) * tmask(:,:,:) ! salinity 605 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,1) * tmask(:,:,:) ! vertical diffusive coef. 606 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 607 uslpdta (:,:,:,1) = zuslp (:,:,:) 608 vslpdta (:,:,:,1) = zvslp (:,:,:) 609 wslpidta(:,:,:,1) = zwslpi(:,:,:) 610 wslpjdta(:,:,:,1) = zwslpj(:,:,:) 611 ! 612 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature 613 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity 614 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef. 615 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 616 uslpdta (:,:,:,2) = zuslp (:,:,:) 617 vslpdta (:,:,:,2) = zvslp (:,:,:) 618 wslpidta(:,:,:,2) = zwslpi(:,:,:) 619 wslpjdta(:,:,:,2) = zwslpj(:,:,:) 620 ELSE 621 ! 622 iswap = 0 623 IF( sf_dyn(jf_tem)%nrec_a(2) - nprevrec /= 0 ) iswap = 1 624 IF( nsecdyn > sf_dyn(jf_tem)%nrec_b(2) .AND. iswap == 1 ) THEN ! read/update the after data 625 IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt 626 uslpdta (:,:,:,1) = uslpdta (:,:,:,2) ! swap the data 627 vslpdta (:,:,:,1) = vslpdta (:,:,:,2) 628 wslpidta(:,:,:,1) = wslpidta(:,:,:,2) 629 wslpjdta(:,:,:,1) = wslpjdta(:,:,:,2) 630 ! 631 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,2) * tmask(:,:,:) ! temperature 632 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,2) * tmask(:,:,:) ! salinity 633 avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,2) * tmask(:,:,:) ! vertical diffusive coef. 634 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 635 ! 636 uslpdta (:,:,:,2) = zuslp (:,:,:) 637 vslpdta (:,:,:,2) = zvslp (:,:,:) 638 wslpidta(:,:,:,2) = zwslpi(:,:,:) 639 wslpjdta(:,:,:,2) = zwslpj(:,:,:) 640 ENDIF 641 ENDIF 642 ENDIF 643 ! 644 IF( sf_dyn(jf_tem)%ln_tint ) THEN 645 ztinta = REAL( nsecdyn - sf_dyn(jf_tem)%nrec_b(2), wp ) & 646 & / REAL( sf_dyn(jf_tem)%nrec_a(2) - sf_dyn(jf_tem)%nrec_b(2), wp ) 647 ztintb = 1. - ztinta 648 #if defined key_ldfslp && ! defined key_c1d 649 uslp (:,:,:) = ztintb * uslpdta (:,:,:,1) + ztinta * uslpdta (:,:,:,2) 650 vslp (:,:,:) = ztintb * vslpdta (:,:,:,1) + ztinta * vslpdta (:,:,:,2) 651 wslpi(:,:,:) = ztintb * wslpidta(:,:,:,1) + ztinta * wslpidta(:,:,:,2) 652 wslpj(:,:,:) = ztintb * wslpjdta(:,:,:,1) + ztinta * wslpjdta(:,:,:,2) 653 #endif 654 ELSE 655 zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature 656 zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity 657 avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coef. 658 CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj ) 659 ! 660 #if defined key_ldfslp && ! defined key_c1d 661 uslp (:,:,:) = zuslp (:,:,:) 662 vslp (:,:,:) = zvslp (:,:,:) 663 wslpi(:,:,:) = zwslpi(:,:,:) 664 wslpj(:,:,:) = zwslpj(:,:,:) 665 #endif 666 ENDIF 667 ! 668 CALL wrk_dealloc(jpi, jpj, jpk, zuslp, zvslp, zwslpi, zwslpj ) 669 ! 670 END SUBROUTINE dta_dyn_slp 671 672 SUBROUTINE compute_slopes( kt, pts, puslp, pvslp, pwslpi, pwslpj ) 529 673 !!--------------------------------------------------------------------- 530 674 !! *** ROUTINE dta_dyn_slp *** … … 568 712 #endif 569 713 ! 570 END SUBROUTINE dta_dyn_slp 714 END SUBROUTINE compute_slopes 715 571 716 !!====================================================================== 572 717 END MODULE dtadyn -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90
r5602 r7806 34 34 USE trcstp ! passive tracer time-stepping (trc_stp routine) 35 35 USE dtadyn ! Lecture and interpolation of the dynamical fields 36 ! ! I/O & MPP36 ! ! I/O & MPP 37 37 USE iom ! I/O library 38 38 USE in_out_manager ! I/O manager … … 50 50 USE trcnam 51 51 USE trcrst 52 USE diaptr ! Need to initialise this as some variables are used in if statements later53 52 54 53 IMPLICIT NONE … … 94 93 istp = nit000 95 94 ! 96 CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)97 !98 95 DO WHILE ( istp <= nitend .AND. nstop == 0 ) ! time stepping 99 96 ! 100 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) 101 CALL iom_setkt( istp - nit000 + 1, "nemo" ) ! say to iom that we are at time step kstp 102 CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields 103 CALL trc_stp ( istp ) ! time-stepping 104 CALL stp_ctl ( istp, indic ) ! Time loop: control and print 97 IF( istp == nit000 ) CALL iom_init( cxios_context ) ! iom_put initialization 98 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) 99 CALL iom_setkt ( istp - nit000 + 1, cxios_context ) ! say to iom that we are at time step kstp 100 CALL trc_rst_opn( istp ) ! Open tracer ! restart file 101 CALL dta_dyn ( istp ) ! Interpolation of the dynamical fields 102 CALL trc_stp ( istp ) ! time-stepping 103 IF( lk_vvl ) CALL dta_dyn_swp( istp ) ! swap of sea surface height and vertical scale factors 104 CALL stp_ctl ( istp, indic ) ! Time loop: control and print 105 105 istp = istp + 1 106 106 IF( lk_mpp ) CALL mpp_max( nstop ) … … 265 265 IF( nn_timing == 1 ) CALL timing_start( 'nemo_init') 266 266 ! 267 CALL phy_cst ! Physical constants 268 CALL eos_init ! Equation of state 269 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 270 CALL dom_cfg ! Domain configuration 267 CALL phy_cst ! Physical constants 268 CALL eos_init ! Equation of state 269 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 270 CALL dom_cfg ! Domain configuration 271 ! 271 272 ! 272 273 INQUIRE( FILE='coordinates.nc', EXIST = llexist ) ! Check if coordinate file exist 273 274 ! 274 IF( llexist ) THEN 275 ELSE 275 IF( llexist ) THEN ; CALL dom_init ! compute the grid from coordinates and bathymetry 276 ELSE ; CALL dom_rea ! read grid from the meskmask 276 277 ENDIF 277 278 CALL istate_init ! ocean initial state (Dynamics and tracers) 278 279 279 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined)280 281 IF( ln_ctl ) CALLprt_ctl_init ! Print control280 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 281 282 IF( ln_ctl ) CALL prt_ctl_init ! Print control 282 283 283 284 CALL sbc_init ! Forcings : surface module … … 289 290 290 291 CALL tra_qsr_init ! penetrative solar radiation qsr 291 IF( lk_trabbl )CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme292 IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 292 293 293 294 CALL trc_nam_run ! Needed to get restart parameters for passive tracers 294 295 CALL trc_rst_cal( nit000, 'READ' ) ! calendar 295 296 CALL dta_dyn_init ! Initialization for the dynamics 296 297 297 CALL trc_init ! Passive tracers initialization 298 CALL dia_ptr_init ! Initialise diaptr as some variables are used299 298 ! ! in various advection and diffusion routines 300 299 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r7256 r7806 24 24 USE phycst ! physical constant 25 25 USE in_out_manager ! I/O manager 26 USE zdfddm 27 USE zdf_oce 26 28 27 29 IMPLICIT NONE … … 42 44 !! * Substitutions 43 45 # include "domzgr_substitute.h90" 46 # include "zdfddm_substitute.h90" 44 47 !!---------------------------------------------------------------------- 45 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 75 78 INTEGER :: ji, jj, jk ! dummy loop arguments 76 79 REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass 80 REAL(wp) :: zaw, zbw, zrw 77 81 ! 78 82 REAL(wp), POINTER, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace 83 REAL(wp), POINTER, DIMENSION(:,:) :: pe ! 2D workspace 79 84 REAL(wp), POINTER, DIMENSION(:,:,:) :: zrhd , zrhop ! 3D workspace 80 85 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace 81 86 !!-------------------------------------------------------------------- 82 87 IF( nn_timing == 1 ) CALL timing_start('dia_ar5') 88 89 !Call to init moved to here so that we can call iom_use in the 90 !initialisation 91 IF( kt == nit000 ) CALL dia_ar5_init 83 92 84 CALL wrk_alloc( jpi , jpj , zarea_ssh , zbotpres )93 CALL wrk_alloc( jpi , jpj , zarea_ssh , zbotpres, pe ) 85 94 CALL wrk_alloc( jpi , jpj , jpk , zrhd , zrhop ) 86 95 CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn ) … … 95 104 CALL iom_put( 'voltot', zvol ) 96 105 CALL iom_put( 'sshtot', zvolssh / area_tot ) 106 CALL iom_put( 'sshdyn', sshn(:,:) - (zvolssh / area_tot) ) 97 107 98 108 ! 99 ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) ! thermosteric ssh 100 ztsn(:,:,:,jp_sal) = sn0(:,:,:) 101 CALL eos( ztsn, zrhd, fsdept_n(:,:,:) ) ! now in situ density using initial salinity 102 ! 103 zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice 104 DO jk = 1, jpkm1 105 zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 106 END DO 107 IF( .NOT.lk_vvl ) THEN 108 IF ( ln_isfcav ) THEN 109 DO ji=1,jpi 110 DO jj=1,jpj 111 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 109 IF( iom_use('sshthster')) THEN 110 ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) ! thermosteric ssh 111 ztsn(:,:,:,jp_sal) = sn0(:,:,:) 112 CALL eos( ztsn, zrhd, fsdept_n(:,:,:) ) ! now in situ density using initial salinity 113 ! 114 zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice 115 DO jk = 1, jpkm1 116 zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 117 END DO 118 IF( .NOT.lk_vvl ) THEN 119 IF ( ln_isfcav ) THEN 120 DO ji=1,jpi 121 DO jj=1,jpj 122 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 123 END DO 112 124 END DO 113 E ND DO114 ELSE115 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1)125 ELSE 126 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 127 END IF 116 128 END IF 117 END IF118 129 ! 119 zarho = SUM( area(:,:) * zbotpres(:,:) )120 IF( lk_mpp ) CALL mpp_sum( zarho )121 zssh_steric = - zarho / area_tot122 CALL iom_put( 'sshthster', zssh_steric )123 130 zarho = SUM( area(:,:) * zbotpres(:,:) ) 131 IF( lk_mpp ) CALL mpp_sum( zarho ) 132 zssh_steric = - zarho / area_tot 133 CALL iom_put( 'sshthster', zssh_steric ) 134 ENDIF 124 135 ! ! steric sea surface height 125 136 CALL eos( tsn, zrhd, zrhop, fsdept_n(:,:,:) ) ! now in situ and potential density … … 190 201 CALL iom_put( 'temptot', ztemp ) 191 202 CALL iom_put( 'saltot' , zsal ) 192 ! 193 CALL wrk_dealloc( jpi , jpj , zarea_ssh , zbotpres ) 203 204 IF( iom_use( 'tnpeo' )) THEN 205 ! Work done against stratification by vertical mixing 206 ! Exclude points where rn2 is negative as convection kicks in here and 207 ! work is not being done against stratification 208 pe(:,:) = 0._wp 209 IF( lk_zdfddm ) THEN 210 DO ji=1,jpi 211 DO jj=1,jpj 212 DO jk=1,jpk 213 zrw = ( fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk) ) & 214 & / ( fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk) ) 215 ! 216 zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw 217 zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw 218 ! 219 pe(ji, jj) = pe(ji, jj) - MIN(0._wp, rn2(ji,jj,jk)) * & 220 & grav * (avt(ji,jj,jk) * zaw * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) & 221 & - fsavs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) ) 222 223 ENDDO 224 ENDDO 225 ENDDO 226 ELSE 227 DO ji=1,jpi 228 DO jj=1,jpj 229 DO jk=1,jpk 230 pe(ji,jj) = pe(ji,jj) + avt(ji, jj, jk) * MIN(0._wp,rn2(ji, jj, jk)) * rau0 * fse3w(ji, jj, jk) 231 ENDDO 232 ENDDO 233 ENDDO 234 ENDIF 235 CALL lbc_lnk(pe, 'T', 1._wp) 236 CALL iom_put( 'tnpeo', pe ) 237 ENDIF 238 ! 239 CALL wrk_dealloc( jpi , jpj , zarea_ssh , zbotpres, pe ) 194 240 CALL wrk_dealloc( jpi , jpj , jpk , zrhd , zrhop ) 195 241 CALL wrk_dealloc( jpi , jpj , jpk , jpts , ztsn ) … … 232 278 IF( lk_mpp ) CALL mpp_sum( vol0 ) 233 279 234 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 235 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) 236 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 237 CALL iom_close( inum ) 238 239 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 240 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 241 IF( ln_zps ) THEN ! z-coord. partial steps 242 DO jj = 1, jpj ! interpolation of salinity at the last ocean level (i.e. the partial step) 243 DO ji = 1, jpi 244 ik = mbkt(ji,jj) 245 IF( ik > 1 ) THEN 246 zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 247 sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 248 ENDIF 280 IF( iom_use('sshthster')) THEN 281 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 282 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) 283 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 284 CALL iom_close( inum ) 285 286 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 287 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 288 IF( ln_zps ) THEN ! z-coord. partial steps 289 DO jj = 1, jpj ! interpolation of salinity at the last ocean level (i.e. the partial step) 290 DO ji = 1, jpi 291 ik = mbkt(ji,jj) 292 IF( ik > 1 ) THEN 293 zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 294 sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 295 ENDIF 296 END DO 249 297 END DO 250 END DO298 ENDIF 251 299 ENDIF 252 300 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r5602 r7806 9 9 !! 3.3 ! 2010-10 (G. Madec) dynamical allocation 10 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 11 !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 11 12 !!---------------------------------------------------------------------- 12 13 … … 21 22 USE dom_oce ! ocean space and time domain 22 23 USE phycst ! physical constants 24 USE ldftra_oce 23 25 ! 24 26 USE iom ! IOM library … … 38 40 PUBLIC dia_ptr_init ! call in step module 39 41 PUBLIC dia_ptr ! call in step module 42 PUBLIC dia_ptr_ohst_components ! called from tra_ldf/tra_adv routines 40 43 41 44 ! !!** namelist namptr ** 42 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf !: Heat TRansports (adv, diff, overturn.) 43 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf !: Salt TRansports (adv, diff, overturn.) 44 45 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv, htr_vt !: Heat TRansports (adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv, str_vs !: Salt TRansports (adv, diff, Bolus.) 47 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.) 48 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic ) 45 49 46 50 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 47 51 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 48 INTEGER 52 INTEGER, PUBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 49 53 50 54 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 65 69 !!---------------------------------------------------------------------- 66 70 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 67 !! $Id$ 71 !! $Id$ 68 72 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 69 73 !!---------------------------------------------------------------------- … … 77 81 ! 78 82 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 REAL(wp) :: z v, zsfc ! local scalar83 REAL(wp) :: zsfc,zvfc ! local scalar 80 84 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 81 85 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 82 86 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 83 87 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 84 CHARACTER( len = 10 ) :: cl1 88 REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace 89 REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace 90 91 ! 92 !overturning calculation 93 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 94 REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function 95 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace 96 97 98 CHARACTER( len = 12 ) :: cl1 85 99 !!---------------------------------------------------------------------- 86 100 ! … … 111 125 END DO 112 126 ENDIF 127 IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 128 ! define fields multiplied by scalar 129 zmask(:,:,:) = 0._wp 130 zts(:,:,:,:) = 0._wp 131 zvn(:,:,:) = 0._wp 132 DO jk = 1, jpkm1 133 DO jj = 1, jpjm1 134 DO ji = 1, jpi 135 zvfc = e1v(ji,jj) * fse3v(ji,jj,jk) 136 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 137 zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid 138 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 139 zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc 140 ENDDO 141 ENDDO 142 ENDDO 143 ENDIF 144 IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 145 sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 146 r1_sjk(:,:,1) = 0._wp 147 WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 148 149 ! i-mean T and S, j-Stream-Function, global 150 tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 151 sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 152 v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 153 154 htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 155 str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 156 157 z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW) 158 DO ji = 1, jpi 159 z2d(ji,:) = z2d(1,:) 160 ENDDO 161 cl1 = 'sophtove' 162 CALL iom_put( TRIM(cl1), z2d ) 163 z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg) 164 DO ji = 1, jpi 165 z2d(ji,:) = z2d(1,:) 166 ENDDO 167 cl1 = 'sopstove' 168 CALL iom_put( TRIM(cl1), z2d ) 169 IF( ln_subbas ) THEN 170 DO jn = 2, nptr 171 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 172 r1_sjk(:,:,jn) = 0._wp 173 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 174 175 ! i-mean T and S, j-Stream-Function, basin 176 tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 177 sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 178 v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 179 htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 180 str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 181 182 z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW) 183 DO ji = 1, jpi 184 z2d(ji,:) = z2d(1,:) 185 ENDDO 186 cl1 = TRIM('sophtove_'//clsubb(jn)) 187 CALL iom_put( cl1, z2d ) 188 z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg) 189 DO ji = 1, jpi 190 z2d(ji,:) = z2d(1,:) 191 ENDDO 192 cl1 = TRIM('sopstove_'//clsubb(jn)) 193 CALL iom_put( cl1, z2d ) 194 END DO 195 ENDIF 196 ENDIF 197 IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 198 ! Calculate barotropic heat and salt transport here 199 sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 200 r1_sjk(:,1,1) = 0._wp 201 WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 202 203 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 204 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 205 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 206 htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 207 str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 208 z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW) 209 DO ji = 2, jpi 210 z2d(ji,:) = z2d(1,:) 211 ENDDO 212 cl1 = 'sophtbtr' 213 CALL iom_put( TRIM(cl1), z2d ) 214 z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg) 215 DO ji = 2, jpi 216 z2d(ji,:) = z2d(1,:) 217 ENDDO 218 cl1 = 'sopstbtr' 219 CALL iom_put( TRIM(cl1), z2d ) 220 IF( ln_subbas ) THEN 221 DO jn = 2, nptr 222 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 223 r1_sjk(:,1,jn) = 0._wp 224 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 225 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 226 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 227 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 228 htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 229 str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 230 z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW) 231 DO ji = 1, jpi 232 z2d(ji,:) = z2d(1,:) 233 ENDDO 234 cl1 = TRIM('sophtbtr_'//clsubb(jn)) 235 CALL iom_put( cl1, z2d ) 236 z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg) 237 DO ji = 1, jpi 238 z2d(ji,:) = z2d(1,:) 239 ENDDO 240 cl1 = TRIM('sopstbtr_'//clsubb(jn)) 241 CALL iom_put( cl1, z2d ) 242 ENDDO 243 ENDIF !ln_subbas 244 ENDIF !iom_use("sopstbtr....) 113 245 ! 114 246 ELSE … … 150 282 ! ! Advective and diffusive heat and salt transport 151 283 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 152 z2d(1,:) = htr_adv(: ) * rc_pwatt ! (conversion in PW)284 z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW) 153 285 DO ji = 1, jpi 154 286 z2d(ji,:) = z2d(1,:) … … 156 288 cl1 = 'sophtadv' 157 289 CALL iom_put( TRIM(cl1), z2d ) 158 z2d(1,:) = str_adv(: ) * rc_ggram ! (conversion in Gg)290 z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg) 159 291 DO ji = 1, jpi 160 292 z2d(ji,:) = z2d(1,:) … … 162 294 cl1 = 'sopstadv' 163 295 CALL iom_put( TRIM(cl1), z2d ) 296 IF( ln_subbas ) THEN 297 DO jn=2,nptr 298 z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW) 299 DO ji = 1, jpi 300 z2d(ji,:) = z2d(1,:) 301 ENDDO 302 cl1 = TRIM('sophtadv_'//clsubb(jn)) 303 CALL iom_put( cl1, z2d ) 304 z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg) 305 DO ji = 1, jpi 306 z2d(ji,:) = z2d(1,:) 307 ENDDO 308 cl1 = TRIM('sopstadv_'//clsubb(jn)) 309 CALL iom_put( cl1, z2d ) 310 ENDDO 311 ENDIF 164 312 ENDIF 165 313 ! 166 314 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 167 z2d(1,:) = htr_ldf(: ) * rc_pwatt ! (conversion in PW)315 z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW) 168 316 DO ji = 1, jpi 169 317 z2d(ji,:) = z2d(1,:) … … 171 319 cl1 = 'sophtldf' 172 320 CALL iom_put( TRIM(cl1), z2d ) 173 z2d(1,:) = str_ldf(: ) * rc_ggram ! (conversion in Gg)321 z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg) 174 322 DO ji = 1, jpi 175 323 z2d(ji,:) = z2d(1,:) … … 177 325 cl1 = 'sopstldf' 178 326 CALL iom_put( TRIM(cl1), z2d ) 179 ENDIF 327 IF( ln_subbas ) THEN 328 DO jn=2,nptr 329 z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW) 330 DO ji = 1, jpi 331 z2d(ji,:) = z2d(1,:) 332 ENDDO 333 cl1 = TRIM('sophtldf_'//clsubb(jn)) 334 CALL iom_put( cl1, z2d ) 335 z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg) 336 DO ji = 1, jpi 337 z2d(ji,:) = z2d(1,:) 338 ENDDO 339 cl1 = TRIM('sopstldf_'//clsubb(jn)) 340 CALL iom_put( cl1, z2d ) 341 ENDDO 342 ENDIF 343 ENDIF 344 345 IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN 346 z2d(1,:) = htr_vt(:,1) * rc_pwatt ! (conversion in PW) 347 DO ji = 1, jpi 348 z2d(ji,:) = z2d(1,:) 349 ENDDO 350 cl1 = 'sopht_vt' 351 CALL iom_put( TRIM(cl1), z2d ) 352 z2d(1,:) = str_vs(:,1) * rc_ggram ! (conversion in Gg) 353 DO ji = 1, jpi 354 z2d(ji,:) = z2d(1,:) 355 ENDDO 356 cl1 = 'sopst_vs' 357 CALL iom_put( TRIM(cl1), z2d ) 358 IF( ln_subbas ) THEN 359 DO jn=2,nptr 360 z2d(1,:) = htr_vt(:,jn) * rc_pwatt ! (conversion in PW) 361 DO ji = 1, jpi 362 z2d(ji,:) = z2d(1,:) 363 ENDDO 364 cl1 = TRIM('sopht_vt_'//clsubb(jn)) 365 CALL iom_put( cl1, z2d ) 366 z2d(1,:) = str_vs(:,jn) * rc_ggram ! (conversion in Gg) 367 DO ji = 1, jpi 368 z2d(ji,:) = z2d(1,:) 369 ENDDO 370 cl1 = TRIM('sopst_vs_'//clsubb(jn)) 371 CALL iom_put( cl1, z2d ) 372 ENDDO 373 ENDIF 374 ENDIF 375 376 #ifdef key_diaeiv 377 IF(lk_traldf_eiv) THEN 378 IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN 379 z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW) 380 DO ji = 1, jpi 381 z2d(ji,:) = z2d(1,:) 382 ENDDO 383 cl1 = 'sophteiv' 384 CALL iom_put( TRIM(cl1), z2d ) 385 z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg) 386 DO ji = 1, jpi 387 z2d(ji,:) = z2d(1,:) 388 ENDDO 389 cl1 = 'sopsteiv' 390 CALL iom_put( TRIM(cl1), z2d ) 391 IF( ln_subbas ) THEN 392 DO jn=2,nptr 393 z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW) 394 DO ji = 1, jpi 395 z2d(ji,:) = z2d(1,:) 396 ENDDO 397 cl1 = TRIM('sophteiv_'//clsubb(jn)) 398 CALL iom_put( cl1, z2d ) 399 z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg) 400 DO ji = 1, jpi 401 z2d(ji,:) = z2d(1,:) 402 ENDDO 403 cl1 = TRIM('sopsteiv_'//clsubb(jn)) 404 CALL iom_put( cl1, z2d ) 405 ENDDO 406 ENDIF 407 ENDIF 408 ENDIF 409 #endif 180 410 ! 181 411 ENDIF … … 256 486 ! Initialise arrays to zero because diatpr is called before they are first calculated 257 487 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 258 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp 259 htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 488 htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp 489 htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp 490 htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp 491 htr_vt(:,:) = 0._wp ; str_vs(:,:) = 0._wp 492 htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp 493 htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp 260 494 ! 261 495 ENDIF … … 263 497 END SUBROUTINE dia_ptr_init 264 498 499 SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva ) 500 !!---------------------------------------------------------------------- 501 !! *** ROUTINE dia_ptr_ohst_components *** 502 !!---------------------------------------------------------------------- 503 !! Wrapper for heat and salt transport calculations to calculate them for each basin 504 !! Called from all advection and/or diffusion routines 505 !!---------------------------------------------------------------------- 506 INTEGER , INTENT(in ) :: ktra ! tracer index 507 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 508 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion 509 INTEGER :: jn ! 510 511 IF( cptr == 'adv' ) THEN 512 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 513 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) ) 514 ENDIF 515 IF( cptr == 'ldf' ) THEN 516 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 517 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 518 ENDIF 519 IF( cptr == 'eiv' ) THEN 520 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 521 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 522 ENDIF 523 IF( cptr == 'vts' ) THEN 524 IF( ktra == jp_tem ) htr_vt(:,1) = ptr_sj( pva(:,:,:) ) 525 IF( ktra == jp_sal ) str_vs(:,1) = ptr_sj( pva(:,:,:) ) 526 ENDIF 527 ! 528 IF( ln_subbas ) THEN 529 ! 530 IF( cptr == 'adv' ) THEN 531 IF( ktra == jp_tem ) THEN 532 DO jn = 2, nptr 533 htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 534 END DO 535 ENDIF 536 IF( ktra == jp_sal ) THEN 537 DO jn = 2, nptr 538 str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 539 END DO 540 ENDIF 541 ENDIF 542 IF( cptr == 'ldf' ) THEN 543 IF( ktra == jp_tem ) THEN 544 DO jn = 2, nptr 545 htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 546 END DO 547 ENDIF 548 IF( ktra == jp_sal ) THEN 549 DO jn = 2, nptr 550 str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 551 END DO 552 ENDIF 553 ENDIF 554 IF( cptr == 'eiv' ) THEN 555 IF( ktra == jp_tem ) THEN 556 DO jn = 2, nptr 557 htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 558 END DO 559 ENDIF 560 IF( ktra == jp_sal ) THEN 561 DO jn = 2, nptr 562 str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 563 END DO 564 ENDIF 565 ENDIF 566 IF( cptr == 'vts' ) THEN 567 IF( ktra == jp_tem ) THEN 568 DO jn = 2, nptr 569 htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 570 END DO 571 ENDIF 572 IF( ktra == jp_sal ) THEN 573 DO jn = 2, nptr 574 str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 575 END DO 576 ENDIF 577 ENDIF 578 ! 579 ENDIF 580 END SUBROUTINE dia_ptr_ohst_components 581 265 582 266 583 FUNCTION dia_ptr_alloc() … … 273 590 ierr(:) = 0 274 591 ! 275 ALLOCATE( btmsk(jpi,jpj,nptr) , & 276 & htr_adv(jpj) , str_adv(jpj) , & 277 & htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1) ) 592 ALLOCATE( btmsk(jpi,jpj,nptr) , & 593 & htr_adv(jpj,nptr) , str_adv(jpj,nptr) , & 594 & htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 595 & htr_vt(jpj,nptr) , str_vs(jpj,nptr) , & 596 & htr_ove(jpj,nptr) , str_ove(jpj,nptr) , & 597 & htr_btr(jpj,nptr) , str_btr(jpj,nptr) , & 598 & htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) ) 278 599 ! 279 600 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) … … 402 723 #endif 403 724 !!-------------------------------------------------------------------- 404 725 ! 405 726 p_fval => p_fval2d 406 727 … … 434 755 #endif 435 756 ! 757 436 758 END FUNCTION ptr_sjk 437 759 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r7256 r7806 156 156 IF( iom_use("e3tdef") ) & 157 157 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 158 CALL iom_put("tpt_dep", fsdept_n(:,:,:) ) 159 158 160 159 161 … … 318 320 CALL iom_put( "hdiv", hdivn ) ! Horizontal divergence 319 321 ! 320 IF( iom_use("u_masstr") .OR. iom_use("u_ heattr") .OR. iom_use("u_salttr") ) THEN322 IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 321 323 z3d(:,:,jpk) = 0.e0 324 z2d(:,:) = 0.e0 322 325 DO jk = 1, jpkm1 323 326 z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 327 z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 324 328 END DO 325 329 CALL iom_put( "u_masstr", z3d ) ! mass transport in i-direction 330 CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum 326 331 ENDIF 327 332 … … 386 391 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 387 392 ENDIF 393 394 ! Vertical integral of temperature 395 IF( iom_use("tosmint") ) THEN 396 z2d(:,:)=0._wp 397 DO jk = 1, jpkm1 398 DO jj = 2, jpjm1 399 DO ji = fs_2, fs_jpim1 ! vector opt. 400 z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) 401 END DO 402 END DO 403 END DO 404 CALL lbc_lnk( z2d, 'T', -1. ) 405 CALL iom_put( "tosmint", z2d ) 406 ENDIF 407 408 ! Vertical integral of salinity 409 IF( iom_use("somint") ) THEN 410 z2d(:,:)=0._wp 411 DO jk = 1, jpkm1 412 DO jj = 2, jpjm1 413 DO ji = fs_2, fs_jpim1 ! vector opt. 414 z2d(ji,jj) = z2d(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 415 END DO 416 END DO 417 END DO 418 CALL lbc_lnk( z2d, 'T', -1. ) 419 CALL iom_put( "somint", z2d ) 420 ENDIF 421 422 CALL iom_put( "bn2", rn2 ) !Brunt-Vaisala buoyancy frequency (N^2) 388 423 ! 389 424 CALL wrk_dealloc( jpi , jpj , z2d ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r7217 r7806 23 23 USE dom_oce ! domain: ocean 24 24 USE sbc_oce ! surface boundary condition: ocean 25 USE trc_oce ! shared ocean-passive tracers variables 25 26 USE phycst ! physical constants 26 27 USE closea ! closed seas … … 97 98 END DO 98 99 ! 99 IF( lk_vvl ) CALL dom_vvl_init ! Vertical variable mesh 100 ! 101 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point 102 ! 103 ! 104 hu(:,:) = 0._wp ! Ocean depth at U-points 105 hv(:,:) = 0._wp ! Ocean depth at V-points 106 ht(:,:) = 0._wp ! Ocean depth at T-points 107 DO jk = 1, jpkm1 108 hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 109 hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 110 ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 111 END DO 112 ! ! Inverse of the local depth 113 hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:) 114 hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:) 100 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point 101 ! 102 IF( .NOT.lk_offline ) THEN 103 ! 104 IF( lk_vvl ) CALL dom_vvl_init ! Vertical variable mesh 105 ! 106 hu(:,:) = 0._wp ! Ocean depth at U-points 107 hv(:,:) = 0._wp ! Ocean depth at V-points 108 ht(:,:) = 0._wp ! Ocean depth at T-points 109 DO jk = 1, jpkm1 110 hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 111 hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 112 ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 113 END DO 114 ! ! Inverse of the local depth 115 hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:) 116 hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:) 117 ! 118 ENDIF 115 119 116 120 CALL dom_stp ! time step -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r7256 r7806 395 395 IF(lwp) WRITE(numout,*) ' zgr_bat : defines level and meter bathymetry' 396 396 IF(lwp) WRITE(numout,*) ' ~~~~~~~' 397 ! 398 ! (ISF) initialisation ice shelf draft and top level 399 risfdep(:,:)=0._wp 400 misfdep(:,:)=1 397 401 ! ! ================== ! 398 402 IF( ntopo == 0 .OR. ntopo == -1 ) THEN ! defined by hand ! … … 484 488 END DO 485 489 END DO 486 risfdep(:,:)=0.e0487 misfdep(:,:)=1488 490 ! 489 491 DEALLOCATE( idta, zdta ) … … 535 537 CALL iom_close( inum ) 536 538 ! 537 risfdep(:,:)=0._wp538 misfdep(:,:)=1539 539 IF ( ln_isfcav ) THEN 540 540 CALL iom_open ( 'isf_draft_meter.nc', inum ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r5602 r7806 65 65 #if defined key_lim3 || defined key_cice 66 66 REAL(wp), PUBLIC :: rhoic = 917._wp !: volumic mass of sea ice [kg/m3] 67 REAL(wp), PUBLIC :: rcdic = 2.034396_wp !: thermal conductivity of fresh ice 68 REAL(wp), PUBLIC :: rcdsn = 0.31_wp !: thermal conductivity of snow 69 REAL(wp), PUBLIC :: cpic = 2067.0_wp !: specific heat for ice 67 REAL(wp), PUBLIC :: rcdic = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K] 68 REAL(wp), PUBLIC :: cpic = 2067.0_wp !: specific heat of fresh ice [J/kg/K] 70 69 REAL(wp), PUBLIC :: lsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] 71 70 REAL(wp), PUBLIC :: lfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] … … 83 82 REAL(wp), PUBLIC :: xlic = 300.33e+6_wp !: volumetric latent heat fusion of ice [J/m3] 84 83 REAL(wp), PUBLIC :: xsn = 2.8e+6_wp !: volumetric latent heat of sublimation of snow [J/m3] 84 #endif 85 #if defined key_cice 86 REAL(wp), PUBLIC :: rcdsn = 0.31_wp !: thermal conductivity of snow [W/m/K], now namelist parameter for LIM3 85 87 #endif 86 88 #if defined key_lim3 … … 177 179 IF(lwp) THEN 178 180 WRITE(numout,*) 181 #if defined key_cice 179 182 WRITE(numout,*) ' thermal conductivity of the snow = ', rcdsn , ' J/s/m/K' 180 WRITE(numout,*) ' thermal conductivity of the ice = ', rcdic , ' J/s/m/K' 183 #endif 184 WRITE(numout,*) ' thermal conductivity of pure ice = ', rcdic , ' J/s/m/K' 181 185 WRITE(numout,*) ' fresh ice specific heat = ', cpic , ' J/kg/K' 182 186 WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', lfus , ' J/kg' -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r4990 r7806 166 166 ! 167 167 ENDIF 168 IF( l_trddyn ) THEN ! Put here so code doesn't crash when doing KE trend but needs to be done properly 169 CALL wrk_alloc( jpi, jpj, jpk, ztrdu, ztrdv ) 170 ENDIF 168 171 ! 169 172 ELSE ! fixed volume (add the surface pressure gradient + unweighted time stepping) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r5602 r7806 601 601 DO jk = 1, jpk 602 602 DO jj = 1, jpjm1 603 DO ji = 1, jpim1603 DO ji = 1, fs_jpim1 604 604 ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 605 605 & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) 606 IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = 4.0_wp / ze3 606 IF ( ze3 /= 0._wp ) THEN ; ze3f(ji,jj,jk) = 4.0_wp / ze3 607 ELSE ; ze3f(ji,jj,jk) = 0.0_wp 608 ENDIF 607 609 END DO 608 610 END DO … … 611 613 DO jk = 1, jpk 612 614 DO jj = 1, jpjm1 613 DO ji = 1, jpim1615 DO ji = 1, fs_jpim1 614 616 ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 615 617 & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) 616 618 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 617 619 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 618 IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = zmsk / ze3 620 IF ( ze3 /= 0._wp ) THEN ; ze3f(ji,jj,jk) = zmsk / ze3 621 ELSE ; ze3f(ji,jj,jk) = 0.0_wp 622 ENDIF 619 623 END DO 620 624 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r7398 r7806 235 235 ! automatic definitions of some of the xml attributs 236 236 CALL set_xmlatt 237 238 CALL set_1point 237 239 238 240 ! end file definition … … 1586 1588 zz=REAL(narea,wp) 1587 1589 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 1588 1590 1589 1591 END SUBROUTINE set_scalar 1592 1593 SUBROUTINE set_1point 1594 !!---------------------------------------------------------------------- 1595 !! *** ROUTINE set_1point *** 1596 !! 1597 !! ** Purpose : define zoom grid for scalar fields 1598 !! 1599 !!---------------------------------------------------------------------- 1600 REAL(wp), DIMENSION(1) :: zz = 1. 1601 INTEGER :: ix, iy 1602 !!---------------------------------------------------------------------- 1603 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! Nearest point to north pole should be ocean 1604 CALL iom_set_domain_attr('1point', zoom_ibegin=ix, zoom_jbegin=iy) 1605 1606 END SUBROUTINE set_1point 1590 1607 1591 1608 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r5601 r7806 804 804 ELSE 805 805 startloop = 3 806 pt2dl(2,ijpj) = psgn * pt2d r(3,ijpjm1)806 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 807 807 ENDIF 808 808 DO ji = startloop, nlci … … 816 816 ELSE 817 817 startloop = 3 818 pt2dl(2,ijpj) = psgn * pt2d r(3,ijpjm1)818 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 819 819 ENDIF 820 820 DO ji = startloop, nlci … … 910 910 DO ji = startloop , endloop 911 911 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 912 pt2dl(ji,ijpj)= 0.5 * (pt2d r(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1))912 pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 913 913 END DO 914 914 … … 926 926 DO ji = startloop , endloop 927 927 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 928 pt2dl(ji,ijpj) = pt2d r(ji,ijpjm1)928 pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 929 929 END DO 930 930 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r7256 r7806 4026 4026 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 4027 4027 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 4028 CHARACTER(len= 4) :: clios ! string to convert iostat in character for print4028 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 4029 4029 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 4030 4030 !!---------------------------------------------------------------------- … … 4032 4032 ! 4033 4033 ! ---------------- 4034 WRITE (clios, '(I 4.0)') kios4034 WRITE (clios, '(I5.0)') kios 4035 4035 IF( kios < 0 ) THEN 4036 4036 CALL ctl_warn( 'W A R N I N G: end of record or file while reading namelist ' & -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90
r7256 r7806 39 39 ! !!* namelist namsbc_alb 40 40 INTEGER :: nn_ice_alb 41 REAL(wp) :: rn_alb ice41 REAL(wp) :: rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt 42 42 43 43 !!---------------------------------------------------------------------- … … 101 101 IF( albd_init == 0 ) CALL albedo_init ! initialization 102 102 103 ralb_sf = rn_alb_sdry ! dry snow 104 ralb_sm = rn_alb_smlt ! melting snow 105 ralb_if = rn_alb_idry ! bare frozen ice 106 ralb_im = rn_alb_imlt ! bare puddled ice 103 107 104 108 SELECT CASE ( nn_ice_alb ) … … 109 113 CASE( 0 ) 110 114 111 ralb_sf = 0.80 ! dry snow112 ralb_sm = 0.65 ! melting snow113 ralb_if = 0.72 ! bare frozen ice114 ralb_im = rn_albice! bare puddled ice115 115 !ralb_sf = 0.80 ! dry snow 116 !ralb_sm = 0.65 ! melting snow 117 !ralb_if = 0.72 ! bare frozen ice 118 !ralb_im = ... ! bare puddled ice 119 116 120 ! Computation of ice albedo (free of snow) 117 121 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb(:,:,:) = ralb_im … … 163 167 CASE( 1 ) 164 168 165 ralb_im = rn_albice! bare puddled ice169 ! ralb_im = ... ! bare puddled ice 166 170 ! compilation of values from literature 167 168 169 171 ! ralb_sf = 0.85 ! dry snow 172 ! ralb_sm = 0.75 ! melting snow 173 ! ralb_if = 0.60 ! bare frozen ice 170 174 ! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 171 175 ! ralb_sf = 0.85 ! dry snow … … 248 252 !!---------------------------------------------------------------------- 249 253 INTEGER :: ios ! Local integer output status for namelist read 250 NAMELIST/namsbc_alb/ nn_ice_alb, rn_alb ice254 NAMELIST/namsbc_alb/ nn_ice_alb, rn_alb_sdry, rn_alb_smlt, rn_alb_idry , rn_alb_imlt 251 255 !!---------------------------------------------------------------------- 252 256 ! … … 268 272 WRITE(numout,*) ' Namelist namsbc_alb : albedo ' 269 273 WRITE(numout,*) ' choose the albedo parameterization nn_ice_alb = ', nn_ice_alb 270 WRITE(numout,*) ' albedo of bare puddled ice rn_albice = ', rn_albice 274 WRITE(numout,*) ' albedo of dry snow rn_alb_sdry = ', rn_alb_sdry 275 WRITE(numout,*) ' albedo of melting snow rn_alb_smlt = ', rn_alb_smlt 276 WRITE(numout,*) ' albedo of dry ice rn_alb_idry = ', rn_alb_idry 277 WRITE(numout,*) ' albedo of bare puddled ice rn_alb_imlt = ', rn_alb_imlt 271 278 ENDIF 272 279 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r5602 r7806 113 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] 114 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf , fwfisf_b !: ice shelf melting [Kg/m2/s] 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] 115 116 !! 116 117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts … … 164 165 ! 165 166 ALLOCATE( fwfisf (jpi,jpj), rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & 166 & fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 167 & fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , & 168 & fwficb (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) ) 167 169 ! 168 170 ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r7256 r7806 43 43 USE eosbn2 44 44 USE sbcrnf , ONLY : l_rnfcpl 45 USE sbcisf , ONLY : l_isfcpl 45 46 #if defined key_cpl_carbon_cycle 46 47 USE p4zflx, ONLY : oce_co2 … … 105 106 INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness 106 107 INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level 107 INTEGER, PARAMETER :: jprcv = 42 ! total number of fields received 108 INTEGER, PARAMETER :: jpr_isf = 43 109 INTEGER, PARAMETER :: jpr_icb = 44 110 INTEGER, PARAMETER :: jprcv = 44 ! total number of fields received 108 111 109 112 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere … … 149 152 ! Received from the atmosphere ! 150 153 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 151 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2 154 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_icb, sn_rcv_isf 152 155 ! Other namelist parameters ! 153 156 INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data … … 219 222 & sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, & 220 223 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx, & 221 & sn_rcv_co2 , nn_cplmodel , ln_usecplmask224 & sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf, nn_cplmodel , ln_usecplmask 222 225 !!--------------------------------------------------------------------- 223 226 ! … … 258 261 WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')' 259 262 WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')' 263 WRITE(numout,*)' iceberg = ', TRIM(sn_rcv_icb%cldes ), ' (', TRIM(sn_rcv_icb%clcat ), ')' 264 WRITE(numout,*)' ice shelf = ', TRIM(sn_rcv_isf%cldes ), ' (', TRIM(sn_rcv_isf%clcat ), ')' 260 265 WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 261 266 WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' … … 397 402 END SELECT 398 403 399 ! ! ------------------------- ! 400 ! ! Runoffs & Calving ! 401 ! ! ------------------------- ! 404 405 ! ! ---------------------------------------------------- ! 406 ! ! Runoffs, Calving, Iceberg, Iceshelf cavities ! 407 ! ! ---------------------------------------------------- ! 402 408 srcv(jpr_rnf )%clname = 'O_Runoff' 403 409 IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN … … 409 415 ENDIF 410 416 ! 411 srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. 417 srcv(jpr_cal)%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. 418 srcv(jpr_isf)%clname = 'OIcshelf' ; IF( TRIM( sn_rcv_isf%cldes) == 'coupled' ) srcv(jpr_isf)%laction = .TRUE. 419 srcv(jpr_icb)%clname = 'OIceberg' ; IF( TRIM( sn_rcv_icb%cldes) == 'coupled' ) srcv(jpr_icb)%laction = .TRUE. 420 421 IF( srcv(jpr_isf)%laction .AND. nn_isf > 0 ) THEN 422 l_isfcpl = .TRUE. ! -> no need to read isf in sbcisf 423 IF(lwp) WRITE(numout,*) 424 IF(lwp) WRITE(numout,*) ' iceshelf received from oasis ' 425 ENDIF 412 426 413 427 ! ! ------------------------- ! … … 1071 1085 ENDIF 1072 1086 ! 1087 ! 1073 1088 ! ! runoffs and calving (added in emp) 1074 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)1089 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1075 1090 IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 1091 1092 IF( srcv(jpr_icb)%laction ) THEN 1093 fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 1094 rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs 1095 ENDIF 1096 IF( srcv(jpr_isf)%laction ) fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 1076 1097 1077 1098 IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) … … 1091 1112 ENDIF 1092 1113 ENDIF 1114 ! 1115 IF( srcv(jpr_icb)%laction ) zqns(:,:) = zqns(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting 1116 ! 1093 1117 IF( ln_mixcpl ) THEN ; qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) 1094 1118 ELSE ; qns(:,:) = zqns(:,:) … … 1387 1411 ! 1388 1412 INTEGER :: jl ! dummy loop index 1389 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, z icefr, zmsk, zsnw1413 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw 1390 1414 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 1391 1415 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice … … 1395 1419 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1396 1420 ! 1397 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, z icefr, zmsk, zsnw )1421 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 1398 1422 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 1399 1423 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) … … 1418 1442 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1419 1443 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 1420 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation 1444 IF( iom_use('precip') ) & 1445 & CALL iom_put( 'precip' , frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) ! total precipitation 1446 IF( iom_use('rain') ) & 1447 & CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation 1448 IF( iom_use('rain_ao_cea') ) & 1449 & CALL iom_put( 'rain_ao_cea' , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1) ) ! liquid precipitation 1421 1450 IF( iom_use('hflx_rain_cea') ) & 1422 & CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip. 1451 CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) * tmask(:,:,1)) ! heat flux from liq. precip. 1452 IF( iom_use('hflx_prec_cea') ) & 1453 CALL iom_put( 'hflx_prec_cea', ztprecip * zcptn(:,:) * tmask(:,:,1) * p_frld(:,:) ) ! heat content flux from all precip (cell avg) 1454 IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) & 1455 ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 1423 1456 IF( iom_use('evap_ao_cea' ) ) & 1424 & CALL iom_put( 'evap_ao_cea' , frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )! ice-free oce evap (cell average)1457 CALL iom_put( 'evap_ao_cea' , ztmp * tmask(:,:,1) ) ! ice-free oce evap (cell average) 1425 1458 IF( iom_use('hflx_evap_cea') ) & 1426 & CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) )! heat flux from from evap (cell average)1427 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp1459 CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) * tmask(:,:,1) ) ! heat flux from from evap (cell average) 1460 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1428 1461 zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1429 1462 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) … … 1458 1491 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1459 1492 ENDIF 1493 1494 IF( srcv(jpr_icb)%laction ) THEN 1495 fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 1496 rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runoffs 1497 CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 1498 ENDIF 1499 IF( srcv(jpr_isf)%laction ) THEN 1500 fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 1501 CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 1502 ENDIF 1503 1460 1504 1461 1505 IF( ln_mixcpl ) THEN … … 1488 1532 ! runoffs and calving (put in emp_tot) 1489 1533 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1534 IF( iom_use('hflx_rnf_cea') ) & 1535 CALL iom_put( 'hflx_rnf_cea' , rnf(:,:) * zcptn(:,:) ) 1490 1536 IF( srcv(jpr_cal)%laction ) THEN 1491 1537 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1492 1538 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1493 1539 ENDIF 1540 1541 1542 IF( srcv(jpr_icb)%laction ) THEN 1543 fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 1544 rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runoffs 1545 CALL iom_put( 'iceberg_cea', frcv(jpr_icb)%z3(:,:,1) ) 1546 ENDIF 1547 IF( srcv(jpr_isf)%laction ) THEN 1548 fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 1549 CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) ) 1550 ENDIF 1551 1494 1552 1495 1553 IF( ln_mixcpl ) THEN … … 1560 1618 ENDIF 1561 1619 1620 !!chris 1621 !! The heat content associated to the ice shelf in removed in the routine sbcisf.F90 1622 ! 1623 IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting 1624 ! 1625 !! ! 1626 1562 1627 #if defined key_lim3 1563 1628 ! --- non solar flux over ocean --- ! … … 1566 1631 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 1567 1632 1633 ! Heat content per unit mass of snow (J/kg) 1634 WHERE( SUM( a_i, dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = cpic * SUM( (tn_ice -rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 ) 1635 ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:) 1636 ENDWHERE 1637 ! Heat content per unit mass of rain (J/kg) 1638 zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) -rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * p_frld(:,:) ) 1639 1568 1640 ! --- heat flux associated with emp (W/m2) --- ! 1569 1641 zqemp_oce(:,:) = - zevap_oce(:,:) * zcptn(:,:) & ! evap 1570 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcpt n(:,:) & ! liquid precip1571 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcpt n(:,:) - lfus ) ! solid precip over ocean + snow melting1642 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptrain(:,:) & ! liquid precip 1643 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw(:,:) - lfus ) ! solid precip over ocean + snow melting 1572 1644 ! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1573 1645 ! & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1574 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcpt n(:,:) - lfus ) ! solid precip over ice (only)1646 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptsnw(:,:) - lfus ) ! solid precip over ice (only) 1575 1647 ! qevap_ice=0 since we consider Tice=0degC 1576 1648 1577 1649 ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1578 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1650 zqprec_ice(:,:) = rhosn * ( zcptsnw(:,:) - lfus ) 1651 !zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1652 1579 1653 1580 1654 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! … … 1737 1811 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1738 1812 1739 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, z icefr, zmsk, zsnw )1813 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 1740 1814 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 1741 1815 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r7256 r7806 650 650 CONTAINS 651 651 SUBROUTINE sbc_ice_lim ( kt, kblk ) ! Dummy routine 652 INTEGER, INTENT(in) :: kt, kblk 652 653 WRITE(*,*) 'sbc_ice_lim: You should not have seen this print! error?', kt, kblk 653 654 END SUBROUTINE sbc_ice_lim -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90
r7256 r7806 32 32 PRIVATE 33 33 34 PUBLIC sbc_isf, sbc_isf_ div, sbc_isf_alloc ! routine called in sbcmod and divcur34 PUBLIC sbc_isf, sbc_isf_init, sbc_isf_div, sbc_isf_alloc ! routine called in sbcmod and divcur 35 35 36 36 ! public in order to be able to output then … … 54 54 REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 55 55 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base 56 57 LOGICAL, PUBLIC :: l_isfcpl = .false. ! isf recieved from oasis 56 58 57 59 … … 81 83 82 84 SUBROUTINE sbc_isf(kt) 85 83 86 INTEGER, INTENT(in) :: kt ! ocean time step 87 INTEGER :: ji, jj, jk 88 INTEGER :: ikt, ikb ! top and bottom level of the isf boundary layer 89 REAL(wp) :: zhk 90 REAL(wp) :: zt_frz, zpress 91 REAL(wp), DIMENSION(:,:,:), POINTER :: zfwfisf3d, zqhcisf3d, zqlatisf3d 92 REAL(wp), DIMENSION(:,: ), POINTER :: zqhcisf2d 93 REAL(wp) :: zhisf 94 95 96 IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 97 98 ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 99 DO jj = 1,jpj 100 DO ji = 1,jpi 101 ikt = misfkt(ji,jj) 102 ikb = misfkt(ji,jj) 103 ! thickness of boundary layer at least the top level thickness 104 rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 105 106 ! determine the deepest level influenced by the boundary layer 107 DO jk = ikt, mbkt(ji,jj) 108 IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 109 END DO 110 rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. 111 misfkb(ji,jj) = ikb ! last wet level of the tbl 112 r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 113 114 zhk = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1 115 ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb) ! proportion of bottom cell influenced by boundary layer 116 END DO 117 END DO 118 119 ! compute salf and heat flux 120 IF (nn_isf == 1) THEN 121 ! realistic ice shelf formulation 122 ! compute T/S/U/V for the top boundary layer 123 CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T') 124 CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T') 125 CALL sbc_isf_tbl(un(:,:,:),utbl(:,:),'U') 126 CALL sbc_isf_tbl(vn(:,:,:),vtbl(:,:),'V') 127 ! iom print 128 CALL iom_put('ttbl',ttbl(:,:)) 129 CALL iom_put('stbl',stbl(:,:)) 130 CALL iom_put('utbl',utbl(:,:)) 131 CALL iom_put('vtbl',vtbl(:,:)) 132 ! compute fwf and heat flux 133 IF( .NOT.l_isfcpl ) THEN ; CALL sbc_isf_cav (kt) 134 ELSE ; qisf(:,:) = fwfisf(:,:) * lfusisf ! heat flux 135 ENDIF 136 137 ELSE IF (nn_isf == 2) THEN 138 ! Beckmann and Goosse parametrisation 139 stbl(:,:) = soce 140 CALL sbc_isf_bg03(kt) 141 142 ELSE IF (nn_isf == 3) THEN 143 ! specified runoff in depth (Mathiot et al., XXXX in preparation) 144 IF( .NOT.l_isfcpl ) THEN 145 CALL fld_read ( kt, nn_fsbc, sf_rnfisf ) 146 fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 147 ENDIF 148 qisf(:,:) = fwfisf(:,:) * lfusisf ! heat flux 149 stbl(:,:) = soce 150 151 ELSE IF (nn_isf == 4) THEN 152 ! specified fwf and heat flux forcing beneath the ice shelf 153 IF( .NOT.l_isfcpl ) THEN 154 CALL fld_read ( kt, nn_fsbc, sf_fwfisf ) 155 !CALL fld_read ( kt, nn_fsbc, sf_qisf ) 156 fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1) ! fwf 157 ENDIF 158 qisf(:,:) = fwfisf(:,:) * lfusisf ! heat flux 159 !qisf(:,:) = sf_qisf(1)%fnow(:,:,1) ! heat flux 160 stbl(:,:) = soce 161 162 END IF 163 ! compute tsc due to isf 164 ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 165 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 166 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 167 risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 168 169 ! salt effect already take into account in vertical advection 170 risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 171 172 ! output 173 IF( iom_use('qlatisf' ) ) CALL iom_put('qlatisf', qisf) 174 IF( iom_use('fwfisf' ) ) CALL iom_put('fwfisf' , fwfisf * stbl(:,:) / soce ) 175 176 ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 177 fwfisf(:,:) = rdivisf * fwfisf(:,:) 178 179 ! lbclnk 180 CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 181 CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.) 182 CALL lbc_lnk(fwfisf(:,:) ,'T',1.) 183 CALL lbc_lnk(qisf(:,:) ,'T',1.) 184 185 ! Diagnostics 186 IF( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN 187 ! 188 CALL wrk_alloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 189 CALL wrk_alloc( jpi,jpj, zqhcisf2d ) 190 ! 191 zfwfisf3d(:,:,:) = 0.0_wp ! 3d ice shelf melting (kg/m2/s) 192 zqhcisf3d(:,:,:) = 0.0_wp ! 3d heat content flux (W/m2) 193 zqlatisf3d(:,:,:)= 0.0_wp ! 3d ice shelf melting latent heat flux (W/m2) 194 zqhcisf2d(:,:) = fwfisf(:,:) * zt_frz * rcp ! 2d heat content flux (W/m2) 195 ! 196 DO jj = 1,jpj 197 DO ji = 1,jpi 198 ikt = misfkt(ji,jj) 199 ikb = misfkb(ji,jj) 200 DO jk = ikt, ikb - 1 201 zhisf = r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 202 zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf(ji,jj) * zhisf 203 zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * zhisf 204 zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf(ji,jj) * zhisf 205 END DO 206 jk = ikb 207 zhisf = r1_hisf_tbl(ji,jj) * fse3t(ji,jj,jk) 208 zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf (ji,jj) * zhisf * ralpha(ji,jj) 209 zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * zhisf * ralpha(ji,jj) 210 zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf (ji,jj) * zhisf * ralpha(ji,jj) 211 END DO 212 END DO 213 ! 214 CALL iom_put( 'fwfisf3d' , zfwfisf3d (:,:,:) ) 215 CALL iom_put( 'qlatisf3d', zqlatisf3d(:,:,:) ) 216 CALL iom_put( 'qhcisf3d' , zqhcisf3d (:,:,:) ) 217 CALL iom_put( 'qhcisf' , zqhcisf2d (:,: ) ) 218 ! 219 CALL wrk_dealloc( jpi,jpj,jpk, zfwfisf3d, zqhcisf3d, zqlatisf3d ) 220 CALL wrk_dealloc( jpi,jpj, zqhcisf2d ) 221 ! 222 END IF 223 ! 224 END IF 225 ! 226 ! 227 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 228 IF( ln_rstart .AND. & ! Restart: read in restart file 229 & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 230 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 231 CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) ) ! before salt content isf_tsc trend 232 CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) ) ! before salt content isf_tsc trend 233 CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) ) ! before salt content isf_tsc trend 234 ELSE 235 fwfisf_b(:,:) = fwfisf(:,:) 236 risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 237 END IF 238 ENDIF 239 ! 240 IF( lrst_oce ) THEN 241 IF(lwp) WRITE(numout,*) 242 IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', & 243 & 'at it= ', kt,' date= ', ndastp 244 IF(lwp) WRITE(numout,*) '~~~~' 245 CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) ) 246 CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) ) 247 CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) ) 248 ENDIF 249 ! 250 END SUBROUTINE sbc_isf 251 252 SUBROUTINE sbc_isf_init 253 84 254 INTEGER :: ji, jj, jk, ijkmin, inum, ierror 85 255 INTEGER :: ikt, ikb ! top and bottom level of the isf boundary layer 86 REAL(wp) :: rmin87 256 REAL(wp) :: zhk 88 REAL(wp) :: zt_frz, zpress89 257 CHARACTER(len=256) :: cfisf , cvarzisf, cvarhisf ! name for isf file 90 258 CHARACTER(LEN=256) :: cnameis ! name of iceshelf file 91 259 CHARACTER (LEN=32) :: cvarLeff ! variable name for efficient Length scale 92 260 INTEGER :: ios ! Local integer output status for namelist read 261 93 262 ! 94 263 !!--------------------------------------------------------------------- … … 97 266 ! 98 267 ! 99 ! ! ====================== !100 IF( kt == nit000 ) THEN ! First call kt=nit000 !101 ! ! ====================== !102 268 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs 103 269 READ ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) … … 139 305 misfkt(:,:) = mikt(:,:) ! same indice for bg03 et cav => used in isfdiv 140 306 ELSE IF ((nn_isf == 3) .OR. (nn_isf == 2)) THEN 141 ALLOCATE( sf_rnfisf(1), STAT=ierror ) 142 ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 143 CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 307 IF( .NOT.l_isfcpl ) THEN 308 ALLOCATE( sf_rnfisf(1), STAT=ierror ) 309 ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 310 CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 311 ENDIF 144 312 145 313 !: read effective lenght (BG03) … … 182 350 183 351 ! load variable used in fldread (use for temporal interpolation of isf fwf forcing) 184 ALLOCATE( sf_fwfisf(1), sf_qisf(1), STAT=ierror ) 185 ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 186 ALLOCATE( sf_qisf(1)%fnow(jpi,jpj,1), sf_qisf(1)%fdta(jpi,jpj,1,2) ) 187 CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 188 !CALL fld_fill( sf_qisf , (/ sn_qisf /), cn_dirisf, 'sbc_isf_init', 'read heat flux isf data' , 'namsbc_isf' ) 352 IF( .NOT.l_isfcpl ) THEN 353 ALLOCATE( sf_fwfisf(1), sf_qisf(1), STAT=ierror ) 354 ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 355 ALLOCATE( sf_qisf(1)%fnow(jpi,jpj,1), sf_qisf(1)%fdta(jpi,jpj,1,2) ) 356 CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 357 !CALL fld_fill( sf_qisf , (/ sn_qisf /), cn_dirisf, 'sbc_isf_init', 'read heat flux isf data' , 'namsbc_isf' ) 358 ENDIF 189 359 END IF 190 191 360 ! save initial top boundary layer thickness 192 361 rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 193 194 END IF195 196 ! ! ---------------------------------------- !197 IF( kt /= nit000 ) THEN ! Swap of forcing fields !198 ! ! ---------------------------------------- !199 fwfisf_b (:,: ) = fwfisf (:,: ) ! Swap the ocean forcing fields except at nit000200 risf_tsc_b(:,:,:) = risf_tsc(:,:,:) ! where before fields are set at the end of the routine201 !202 ENDIF203 204 IF( MOD( kt-1, nn_fsbc) == 0 ) THEN205 206 ! compute bottom level of isf tbl and thickness of tbl below the ice shelf207 DO jj = 1,jpj208 DO ji = 1,jpi209 ikt = misfkt(ji,jj)210 ikb = misfkt(ji,jj)211 ! thickness of boundary layer at least the top level thickness212 rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt))213 214 ! determine the deepest level influenced by the boundary layer215 DO jk = ikt, mbkt(ji,jj)216 IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk217 END DO218 rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness.219 misfkb(ji,jj) = ikb ! last wet level of the tbl220 r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj)221 222 zhk = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1223 ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb) ! proportion of bottom cell influenced by boundary layer224 END DO225 END DO226 227 ! compute salf and heat flux228 IF (nn_isf == 1) THEN229 ! realistic ice shelf formulation230 ! compute T/S/U/V for the top boundary layer231 CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T')232 CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T')233 CALL sbc_isf_tbl(un(:,:,:),utbl(:,:),'U')234 CALL sbc_isf_tbl(vn(:,:,:),vtbl(:,:),'V')235 ! iom print236 CALL iom_put('ttbl',ttbl(:,:))237 CALL iom_put('stbl',stbl(:,:))238 CALL iom_put('utbl',utbl(:,:))239 CALL iom_put('vtbl',vtbl(:,:))240 ! compute fwf and heat flux241 CALL sbc_isf_cav (kt)242 243 ELSE IF (nn_isf == 2) THEN244 ! Beckmann and Goosse parametrisation245 stbl(:,:) = soce246 CALL sbc_isf_bg03(kt)247 248 ELSE IF (nn_isf == 3) THEN249 ! specified runoff in depth (Mathiot et al., XXXX in preparation)250 CALL fld_read ( kt, nn_fsbc, sf_rnfisf )251 fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting)252 qisf(:,:) = fwfisf(:,:) * lfusisf ! heat flux253 stbl(:,:) = soce254 255 ELSE IF (nn_isf == 4) THEN256 ! specified fwf and heat flux forcing beneath the ice shelf257 CALL fld_read ( kt, nn_fsbc, sf_fwfisf )258 !CALL fld_read ( kt, nn_fsbc, sf_qisf )259 fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1) ! fwf260 qisf(:,:) = fwfisf(:,:) * lfusisf ! heat flux261 !qisf(:,:) = sf_qisf(1)%fnow(:,:,1) ! heat flux262 stbl(:,:) = soce263 264 END IF265 ! compute tsc due to isf266 ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable).267 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04268 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress )269 risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 !270 271 ! salt effect already take into account in vertical advection272 risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0273 274 ! output275 IF( iom_use('qisf' ) ) CALL iom_put('qisf' , qisf)276 IF( iom_use('fwfisf') ) CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce )277 278 ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now279 fwfisf(:,:) = rdivisf * fwfisf(:,:)280 281 ! lbclnk282 CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.)283 CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.)284 CALL lbc_lnk(fwfisf(:,:) ,'T',1.)285 CALL lbc_lnk(qisf(:,:) ,'T',1.)286 287 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 !288 IF( ln_rstart .AND. & ! Restart: read in restart file289 & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN290 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file'291 CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) ) ! before salt content isf_tsc trend292 CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b', risf_tsc_b(:,:,jp_sal) ) ! before salt content isf_tsc trend293 CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b', risf_tsc_b(:,:,jp_tem) ) ! before salt content isf_tsc trend294 ELSE295 fwfisf_b(:,:) = fwfisf(:,:)296 risf_tsc_b(:,:,:)= risf_tsc(:,:,:)297 END IF298 ENDIF299 362 ! 300 END IF301 302 END SUBROUTINE sbc_isf 363 END SUBROUTINE sbc_isf_init 364 365 303 366 304 367 INTEGER FUNCTION sbc_isf_alloc() -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r7256 r7806 300 300 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialisation 301 301 ! 302 IF( nn_isf /= 0 ) CALL sbc_isf_init ! Compute iceshelves 303 302 304 CALL sbc_rnf_init ! Runof initialisation 303 305 ! … … 343 345 rnf_b (:,: ) = rnf (:,: ) 344 346 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 347 ENDIF 348 IF( nn_isf /= 0 ) THEN 349 fwfisf_b (:,: ) = fwfisf (:,: ) 350 risf_tsc_b(:,:,:) = risf_tsc(:,:,:) 345 351 ENDIF 346 352 ENDIF -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r5602 r7806 26 26 USE cla ! cross land advection (cla_traadv routine) 27 27 USE ldftra_oce ! lateral diffusion coefficient on tracers 28 USE trd_oce ! trends: ocean variables 29 USE trdtra ! trends manager: tracers 28 30 ! 29 31 USE in_out_manager ! I/O manager … … 79 81 INTEGER :: jk ! dummy loop index 80 82 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 83 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 81 84 !!---------------------------------------------------------------------- 82 85 ! … … 120 123 IF( ln_diaptr ) CALL dia_ptr( zvn ) ! diagnose the effective MSF 121 124 ! 122 125 IF( l_trdtra ) THEN !* Save ta and sa trends 126 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 127 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 128 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 129 ENDIF 130 ! 123 131 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 124 132 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, nit000, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! 2nd order centered … … 151 159 END SELECT 152 160 ! 161 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 162 DO jk = 1, jpkm1 163 ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) 164 ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) 165 END DO 166 CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 167 CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 168 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 169 ENDIF 153 170 ! ! print mean trends (used for debugging) 154 171 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv - Ta: ', mask1=tmask, & -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r7256 r7806 279 279 END IF 280 280 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 281 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 282 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 283 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 284 ENDIF 281 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 285 282 ! 286 283 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90
r7256 r7806 28 28 USE wrk_nemo ! Memory Allocation 29 29 USE timing ! Timing 30 USE diaptr ! Heat/Salt transport diagnostics 31 USE trddyn 32 USE trd_oce 30 33 31 34 IMPLICIT NONE … … 78 81 # endif 79 82 REAL(wp), POINTER, DIMENSION(:,:) :: zu_eiv, zv_eiv, zw_eiv, z2d 83 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, z3d_T 80 84 !!---------------------------------------------------------------------- 81 85 ! … … 84 88 # if defined key_diaeiv 85 89 CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 90 CALL wrk_alloc( jpi, jpj, jpk, z3d, z3d_T ) 86 91 # else 87 92 CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) … … 160 165 CALL iom_put( "voce_eiv", v_eiv ) ! j-eiv current 161 166 CALL iom_put( "woce_eiv", w_eiv ) ! vert. eiv current 162 IF( iom_use('ueiv_heattr') ) THEN 163 zztmp = 0.5 * rau0 * rcp 167 IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value 168 z2d(:,:) = rau0 * e12t(:,:) 169 DO jk = 1, jpk 170 z3d(:,:,jk) = w_eiv(:,:,jk) * z2d(:,:) 171 END DO 172 CALL iom_put( "weiv_masstr" , z3d ) 173 ENDIF 174 IF( iom_use("ueiv_masstr") .OR. iom_use("ueiv_heattr") .OR. iom_use('ueiv_heattr3d') & 175 .OR. iom_use("ueiv_salttr") .OR. iom_use('ueiv_salttr3d') ) THEN 176 z3d(:,:,jpk) = 0.e0 177 z2d(:,:) = 0.e0 178 DO jk = 1, jpkm1 179 z3d(:,:,jk) = rau0 * u_eiv(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 180 z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 181 END DO 182 CALL iom_put( "ueiv_masstr", z3d ) ! mass transport in i-direction 183 ENDIF 184 185 IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN 186 zztmp = 0.5 * rcp 164 187 z2d(:,:) = 0.e0 165 DO jk = 1, jpkm1 166 DO jj = 2, jpjm1 167 DO ji = fs_2, fs_jpim1 ! vector opt. 168 z2d(ji,jj) = z2d(ji,jj) + u_eiv(ji,jj,jk) & 169 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e2u(ji,jj) * fse3u(ji,jj,jk) 170 END DO 171 END DO 172 END DO 173 CALL lbc_lnk( z2d, 'U', -1. ) 174 CALL iom_put( "ueiv_heattr", zztmp * z2d ) ! heat transport in i-direction 188 z3d_T(:,:,:) = 0.e0 189 DO jk = 1, jpkm1 190 DO jj = 2, jpjm1 191 DO ji = fs_2, fs_jpim1 ! vector opt. 192 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 193 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 194 END DO 195 END DO 196 END DO 197 IF (iom_use('ueiv_heattr') ) THEN 198 CALL lbc_lnk( z2d, 'U', -1. ) 199 CALL iom_put( "ueiv_heattr", zztmp * z2d ) ! 2D heat transport in i-direction 200 ENDIF 201 IF (iom_use('ueiv_heattr3d') ) THEN 202 CALL lbc_lnk( z3d_T, 'U', -1. ) 203 CALL iom_put( "ueiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in i-direction 204 ENDIF 205 ENDIF 206 207 IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d') ) THEN 208 zztmp = 0.5 * 0.001 209 z2d(:,:) = 0.e0 210 z3d_T(:,:,:) = 0.e0 211 DO jk = 1, jpkm1 212 DO jj = 2, jpjm1 213 DO ji = fs_2, fs_jpim1 ! vector opt. 214 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 215 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 216 END DO 217 END DO 218 END DO 219 IF (iom_use('ueiv_salttr') ) THEN 220 CALL lbc_lnk( z2d, 'U', -1. ) 221 CALL iom_put( "ueiv_salttr", zztmp * z2d ) ! 2D salt transport in i-direction 222 ENDIF 223 IF (iom_use('ueiv_salttr3d') ) THEN 224 CALL lbc_lnk( z3d_T, 'U', -1. ) 225 CALL iom_put( "ueiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in i-direction 226 ENDIF 227 ENDIF 228 229 IF( iom_use("veiv_masstr") .OR. iom_use("veiv_heattr") .OR. iom_use('veiv_heattr3d') & 230 .OR. iom_use("veiv_salttr") .OR. iom_use('veiv_salttr3d') ) THEN 231 z3d(:,:,jpk) = 0.e0 232 DO jk = 1, jpkm1 233 z3d(:,:,jk) = rau0 * v_eiv(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) 234 END DO 235 CALL iom_put( "veiv_masstr", z3d ) ! mass transport in j-direction 175 236 ENDIF 176 237 177 IF( iom_use('veiv_heattr') ) THEN178 zztmp = 0.5 * r au0 * rcp238 IF( iom_use('veiv_heattr') .OR. iom_use('veiv_heattr3d') ) THEN 239 zztmp = 0.5 * rcp 179 240 z2d(:,:) = 0.e0 180 DO jk = 1, jpkm1 181 DO jj = 2, jpjm1 182 DO ji = fs_2, fs_jpim1 ! vector opt. 183 z2d(ji,jj) = z2d(ji,jj) + v_eiv(ji,jj,jk) & 184 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e1v(ji,jj) * fse3v(ji,jj,jk) 185 END DO 186 END DO 187 END DO 188 CALL lbc_lnk( z2d, 'V', -1. ) 189 CALL iom_put( "veiv_heattr", zztmp * z2d ) ! heat transport in i-direction 190 ENDIF 241 z3d_T(:,:,:) = 0.e0 242 DO jk = 1, jpkm1 243 DO jj = 2, jpjm1 244 DO ji = fs_2, fs_jpim1 ! vector opt. 245 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 246 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 247 END DO 248 END DO 249 END DO 250 IF (iom_use('veiv_heattr') ) THEN 251 CALL lbc_lnk( z2d, 'V', -1. ) 252 CALL iom_put( "veiv_heattr", zztmp * z2d ) ! 2D heat transport in j-direction 253 ENDIF 254 IF (iom_use('veiv_heattr3d') ) THEN 255 CALL lbc_lnk( z3d_T, 'V', -1. ) 256 CALL iom_put( "veiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in j-direction 257 ENDIF 258 ENDIF 259 260 IF( iom_use('veiv_salttr') .OR. iom_use('veiv_salttr3d') ) THEN 261 zztmp = 0.5 * 0.001 262 z2d(:,:) = 0.e0 263 z3d_T(:,:,:) = 0.e0 264 DO jk = 1, jpkm1 265 DO jj = 2, jpjm1 266 DO ji = fs_2, fs_jpim1 ! vector opt. 267 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 268 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 269 END DO 270 END DO 271 END DO 272 IF (iom_use('veiv_salttr') ) THEN 273 CALL lbc_lnk( z2d, 'V', -1. ) 274 CALL iom_put( "veiv_salttr", zztmp * z2d ) ! 2D salt transport in i-direction 275 ENDIF 276 IF (iom_use('veiv_salttr3d') ) THEN 277 CALL lbc_lnk( z3d_T, 'V', -1. ) 278 CALL iom_put( "veiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in i-direction 279 ENDIF 280 ENDIF 281 282 IF( iom_use('weiv_masstr') .OR. iom_use('weiv_heattr3d') .OR. iom_use('weiv_salttr3d')) THEN ! vertical mass transport & its square value 283 z2d(:,:) = rau0 * e12t(:,:) 284 DO jk = 1, jpk 285 z3d(:,:,jk) = w_eiv(:,:,jk) * z2d(:,:) 286 END DO 287 CALL iom_put( "weiv_masstr" , z3d ) ! mass transport in k-direction 288 ENDIF 289 290 IF( iom_use('weiv_heattr3d') ) THEN 291 zztmp = 0.5 * rcp 292 DO jk = 1, jpkm1 293 DO jj = 2, jpjm1 294 DO ji = fs_2, fs_jpim1 ! vector opt. 295 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj,jk+1,jp_tem) ) 296 END DO 297 END DO 298 END DO 299 CALL lbc_lnk( z3d_T, 'T', 1. ) 300 CALL iom_put( "weiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in k-direction 301 ENDIF 302 303 IF( iom_use('weiv_salttr3d') ) THEN 304 zztmp = 0.5 * 0.001 305 DO jk = 1, jpkm1 306 DO jj = 2, jpjm1 307 DO ji = fs_2, fs_jpim1 ! vector opt. 308 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj,jk+1,jp_sal) ) 309 END DO 310 END DO 311 END DO 312 CALL lbc_lnk( z3d_T, 'T', 1. ) 313 CALL iom_put( "weiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in k-direction 314 ENDIF 315 191 316 END IF 317 ! 318 IF( ln_diaptr .AND. cdtype == 'TRA' ) THEN 319 z3d(:,:,:) = 0._wp 320 DO jk = 1, jpkm1 321 DO jj = 2, jpjm1 322 DO ji = fs_2, fs_jpim1 ! vector opt. 323 z3d(ji,jj,jk) = v_eiv(ji,jj,jk) * 0.5 * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) & 324 & * e1v(ji,jj) * fse3v(ji,jj,jk) 325 END DO 326 END DO 327 END DO 328 CALL dia_ptr_ohst_components( jp_tem, 'eiv', z3d ) 329 z3d(:,:,:) = 0._wp 330 DO jk = 1, jpkm1 331 DO jj = 2, jpjm1 332 DO ji = fs_2, fs_jpim1 ! vector opt. 333 z3d(ji,jj,jk) = v_eiv(ji,jj,jk) * 0.5 * (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) & 334 & * e1v(ji,jj) * fse3v(ji,jj,jk) 335 END DO 336 END DO 337 END DO 338 CALL dia_ptr_ohst_components( jp_sal, 'eiv', z3d ) 339 ENDIF 340 341 IF( ln_KE_trd ) CALL trd_dyn(u_eiv, v_eiv, jpdyn_eivke, kt ) 192 342 # endif 193 ! 343 194 344 # if defined key_diaeiv 195 345 CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 346 CALL wrk_dealloc( jpi, jpj, jpk, z3d, z3d_T ) 196 347 # else 197 348 CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90
r5602 r7806 45 45 !!---------------------------------------------------------------------- 46 46 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 47 !! $Id$ 47 !! $Id$ 48 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 49 49 !!---------------------------------------------------------------------- … … 219 219 END IF 220 220 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 221 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 222 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 223 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 224 ENDIF 221 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 225 222 226 223 ! II. Vertical advective fluxes -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90
r5602 r7806 37 37 !!---------------------------------------------------------------------- 38 38 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 39 !! $Id$ 39 !! $Id$ 40 40 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 41 41 !!---------------------------------------------------------------------- … … 200 200 201 201 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 202 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 203 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 204 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 205 ENDIF 202 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 206 203 207 204 ! II. Vertical advective fluxes -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r5602 r7806 355 355 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 356 356 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 357 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 358 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 359 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 360 ENDIF 357 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', zwy(:,:,:) ) 361 358 ! 362 359 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r7256 r7806 27 27 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 28 28 USE diaptr ! poleward transport diagnostics 29 USE phycst 29 30 ! 30 31 USE lib_mpp ! MPP library … … 34 35 USE timing ! Timing 35 36 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 37 USE iom 36 38 37 39 IMPLICIT NONE … … 42 44 43 45 LOGICAL :: l_trd ! flag to compute trends 46 LOGICAL :: l_trans ! flag to output vertically integrated transports 44 47 45 48 !! * Substitutions … … 85 88 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - - 86 89 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 90 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz, zptry 91 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 88 92 !!---------------------------------------------------------------------- 89 93 ! … … 97 101 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 98 102 ! 99 l_trd = .FALSE.100 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.101 103 ENDIF 102 ! 103 IF( l_trd ) THEN 104 105 l_trd = .FALSE. 106 l_trans = .FALSE. 107 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 108 IF( cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") ) ) l_trans = .TRUE. 109 ! 110 IF( l_trd .OR. l_trans ) THEN 104 111 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 105 112 ztrdx(:,:,:) = 0.e0 ; ztrdy(:,:,:) = 0.e0 ; ztrdz(:,:,:) = 0.e0 113 CALL wrk_alloc( jpi, jpj, z2d ) 114 ENDIF 115 ! 116 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 117 CALL wrk_alloc( jpi, jpj, jpk, zptry ) 118 zptry(:,:,:) = 0._wp 106 119 ENDIF 107 120 ! … … 187 200 188 201 ! ! trend diagnostics (contribution of upstream fluxes) 189 IF( l_trd ) THEN202 IF( l_trd .OR. l_trans ) THEN 190 203 ! store intermediate advective trends 191 204 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 192 205 END IF 193 206 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 194 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 195 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 196 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 197 ENDIF 207 IF( cdtype == 'TRA' .AND. ln_diaptr ) zptry(:,:,:) = zwy(:,:,:) 198 208 199 209 ! 3. antidiffusive flux : high order minus low order … … 253 263 254 264 ! ! trend diagnostics (contribution of upstream fluxes) 255 IF( l_trd ) THEN265 IF( l_trd .OR. l_trans ) THEN 256 266 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 257 267 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 258 268 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 259 260 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 261 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 262 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 269 ENDIF 270 271 IF( l_trd ) THEN 272 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 273 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 274 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 263 275 END IF 264 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 276 277 IF( l_trans .AND. jn==jp_tem ) THEN 278 z2d(:,:) = 0._wp 279 DO jk = 1, jpkm1 280 DO jj = 2, jpjm1 281 DO ji = fs_2, fs_jpim1 ! vector opt. 282 z2d(ji,jj) = z2d(ji,jj) + ztrdx(ji,jj,jk) 283 END DO 284 END DO 285 END DO 286 CALL lbc_lnk( z2d, 'U', -1. ) 287 CALL iom_put( "uadv_heattr", rau0_rcp * z2d ) ! heat transport in i-direction 288 ! 289 z2d(:,:) = 0._wp 290 DO jk = 1, jpkm1 291 DO jj = 2, jpjm1 292 DO ji = fs_2, fs_jpim1 ! vector opt. 293 z2d(ji,jj) = z2d(ji,jj) + ztrdy(ji,jj,jk) 294 END DO 295 END DO 296 END DO 297 CALL lbc_lnk( z2d, 'V', -1. ) 298 CALL iom_put( "vadv_heattr", rau0_rcp * z2d ) ! heat transport in j-direction 299 ENDIF 300 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 265 301 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 266 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:)267 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:)302 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 303 CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 268 304 ENDIF 269 305 ! 270 306 END DO 271 307 ! 272 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 273 IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 308 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) 309 IF( l_trd .OR. l_trans ) THEN 310 CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 311 CALL wrk_dealloc( jpi, jpj, z2d ) 312 ENDIF 313 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 274 314 ! 275 315 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd') … … 318 358 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts 319 359 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz 360 REAL(wp), POINTER, DIMENSION(:,:,:) :: zptry 320 361 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs 321 362 !!---------------------------------------------------------------------- … … 339 380 CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 340 381 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 382 ENDIF 383 ! 384 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 385 CALL wrk_alloc( jpi, jpj,jpk, zptry ) 386 zptry(:,:,:) = 0._wp 341 387 ENDIF 342 388 ! … … 428 474 END IF 429 475 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 430 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 431 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 432 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 433 ENDIF 476 IF( cdtype == 'TRA' .AND. ln_diaptr ) zptry(:,:,:) = zwy(:,:,:) 434 477 435 478 ! 3. antidiffusive flux : high order minus low order … … 556 599 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 557 600 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 558 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:)559 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:)601 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) 602 CALL dia_ptr_ohst_components( jn, 'adv', zptry(:,:,:) ) 560 603 ENDIF 561 604 ! … … 566 609 CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 567 610 IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 611 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL wrk_dealloc( jpi, jpj, jpk, zptry ) 568 612 ! 569 613 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd_zts') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd_crs.F90
r7795 r7806 183 183 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 184 184 END IF 185 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)186 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN187 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) )188 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) )189 ENDIF190 185 191 186 ! 3. antidiffusive flux : high order minus low order … … 245 240 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 246 241 END IF 247 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)248 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN249 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:)250 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:)251 ENDIF252 242 ! 253 243 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r5602 r7806 177 177 END IF 178 178 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 179 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 180 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( ztv(:,:,:) ) 181 IF( jn == jp_sal ) str_adv(:) = ptr_sj( ztv(:,:,:) ) 182 ENDIF 179 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'adv', ztv(:,:,:) ) 183 180 184 181 ! TVD scheme for the vertical direction -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90
r5602 r7806 173 173 ! 174 174 ! "zonal" mean lateral diffusive heat and salt transport 175 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 176 IF( jn == jp_tem ) htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 177 IF( jn == jp_sal ) str_ldf(:) = ptr_sj( ztv(:,:,:) ) 178 ENDIF 175 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', ztv(:,:,:) ) 179 176 ! ! =========== 180 177 END DO ! tracer loop -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90
r5602 r7806 247 247 ! ! =============== 248 248 ! "Poleward" diffusive heat or salt transport 249 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 250 ! note sign is reversed to give down-gradient diffusive transports (#1043) 251 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 252 IF( jn == jp_sal) str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 253 ENDIF 249 ! note sign is reversed to give down-gradient diffusive transports (#1043) 250 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) CALL dia_ptr_ohst_components( jn, 'ldf', -zftv(:,:,:) ) 254 251 255 252 ! ! ************ ! ! =============== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r5602 r7806 235 235 ! 236 236 ! "Poleward" diffusive heat or salt transports (T-S case only) 237 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN238 237 ! note sign is reversed to give down-gradient diffusive transports (#1043) 239 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 240 IF( jn == jp_sal) str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 241 ENDIF 238 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', -zftv(:,:,:) ) 242 239 243 240 IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_crs.F90
r7311 r7806 210 210 ! ! =============== 211 211 ! 212 ! "Poleward" diffusive heat or salt transports (T-S case only)213 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN214 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( zftv(:,:,:) )215 IF( jn == jp_sal) str_ldf(:) = ptr_sj( zftv(:,:,:) )216 ENDIF217 212 218 213 #if defined key_diaar5 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90
r5602 r7806 386 386 ! 387 387 ! ! "Poleward" diffusive heat or salt transports (T-S case only) 388 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 389 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( zftv(:,:,:) ) ! 3.3 names 390 IF( jn == jp_sal) str_ldf(:) = ptr_sj( zftv(:,:,:) ) 391 ENDIF 388 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', zftv(:,:,:) ) 392 389 393 390 IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90
r5602 r7806 154 154 ! 155 155 ! "Poleward" diffusive heat or salt transports 156 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 157 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 158 IF( jn == jp_sal) str_ldf(:) = ptr_sj( ztv(:,:,:) ) 159 ENDIF 156 IF( cdtype == 'TRA' .AND. ln_diaptr ) CALL dia_ptr_ohst_components( jn, 'ldf', ztv(:,:,:) ) 160 157 ! ! ================== 161 158 END DO ! end of tracer loop -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_crs.F90
r6772 r7806 149 149 END DO ! End of slab 150 150 ! 151 ! "Poleward" diffusive heat or salt transports152 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN153 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( ztv(:,:,:) )154 IF( jn == jp_sal) str_ldf(:) = ptr_sj( ztv(:,:,:) )155 ENDIF156 151 ! ! ================== 157 152 END DO ! end of tracer loop -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r7256 r7806 129 129 130 130 ! trends computation initialisation 131 IF( l_trdtra ) THEN ! store now fields before applying the Asselin filter131 IF( l_trdtra ) THEN 132 132 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 133 ztrdt(:,:, :) = tsn(:,:,:,jp_tem)134 ztrds(:,:, :) = tsn(:,:,:,jp_sal)133 ztrdt(:,:,jk) = 0._wp 134 ztrds(:,:,jk) = 0._wp 135 135 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 136 136 CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 137 137 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 138 138 ENDIF 139 ! total trend for the non-time-filtered variables. 140 DO jk = 1, jpkm1 141 zfact = 1.0 / rdttra(jk) 142 ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsn(:,:,jk,jp_tem) ) * zfact 143 ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsn(:,:,jk,jp_sal) ) * zfact 144 END DO 145 CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt ) 146 CALL trd_tra( kt, 'TRA', jp_sal, jptra_tot, ztrds ) 147 ! Store now fields before applying the Asselin filter 148 ! in order to calculate Asselin filter trend later. 149 ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 150 ztrds(:,:,:) = tsn(:,:,:,jp_sal) 139 151 ENDIF 140 152 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r7256 r7806 248 248 END DO 249 249 END DO 250 IF( lrst_oce ) THEN251 IF(lwp) WRITE(numout,*)252 IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', &253 & 'at it= ', kt,' date= ', ndastp254 IF(lwp) WRITE(numout,*) '~~~~'255 CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) )256 CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem) )257 CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal) )258 ENDIF259 250 END IF 260 251 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trd_oce.F90
r5602 r7806 33 33 # endif 34 34 ! !!!* Active tracers trends indexes 35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 14!: Total trend nb: change it when adding/removing one indice below35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 20 !: Total trend nb: change it when adding/removing one indice below 36 36 ! =============== ! 37 37 INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1 !: x- horizontal advection … … 39 39 INTEGER, PUBLIC, PARAMETER :: jptra_zad = 3 !: z- vertical advection 40 40 INTEGER, PUBLIC, PARAMETER :: jptra_sad = 4 !: z- vertical advection 41 INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 5 !: lateral diffusion 42 INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 6 !: vertical diffusion 43 INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 7 !: "PURE" vert. diffusion (ln_traldf_iso=T) 44 INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 8 !: Bottom Boundary Condition (geoth. heating) 45 INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 9 !: Bottom Boundary Layer (diffusive and/or advective) 46 INTEGER, PUBLIC, PARAMETER :: jptra_npc = 10 !: non-penetrative convection treatment 47 INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 11 !: internal restoring (damping) 48 INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 12 !: penetrative solar radiation 49 INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 13 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) 50 INTEGER, PUBLIC, PARAMETER :: jptra_atf = 14 !: Asselin time filter 41 INTEGER, PUBLIC, PARAMETER :: jptra_totad = 5 !: total advection 42 INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 6 !: lateral diffusion 43 INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 7 !: vertical diffusion 44 INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 8 !: "PURE" vert. diffusion (ln_traldf_iso=T) 45 INTEGER, PUBLIC, PARAMETER :: jptra_evd = 9 !: EVD term (convection) 46 INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 10 !: Bottom Boundary Condition (geoth. heating) 47 INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 11 !: Bottom Boundary Layer (diffusive and/or advective) 48 INTEGER, PUBLIC, PARAMETER :: jptra_npc = 12 !: non-penetrative convection treatment 49 INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 13 !: internal restoring (damping) 50 INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 14 !: penetrative solar radiation 51 INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 15 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) 52 INTEGER, PUBLIC, PARAMETER :: jptra_atf = 16 !: Asselin time filter 53 INTEGER, PUBLIC, PARAMETER :: jptra_tot = 17 !: Model total trend 51 54 ! 52 55 ! !!!* Passive tracers trends indices (use if "key_top" defined) 53 INTEGER, PUBLIC, PARAMETER :: jptra_sms = 1 5!: sources m. sinks54 INTEGER, PUBLIC, PARAMETER :: jptra_radn = 1 6!: corr. trn<0 in trcrad55 INTEGER, PUBLIC, PARAMETER :: jptra_radb = 17!: corr. trb<0 in trcrad (like atf)56 INTEGER, PUBLIC, PARAMETER :: jptra_sms = 18 !: sources m. sinks 57 INTEGER, PUBLIC, PARAMETER :: jptra_radn = 19 !: corr. trn<0 in trcrad 58 INTEGER, PUBLIC, PARAMETER :: jptra_radb = 20 !: corr. trb<0 in trcrad (like atf) 56 59 ! 57 60 ! !!!* Momentum trends indices 58 INTEGER, PUBLIC, PARAMETER :: jptot_dyn = 1 5!: Total trend nb: change it when adding/removing one indice below61 INTEGER, PUBLIC, PARAMETER :: jptot_dyn = 16 !: Total trend nb: change it when adding/removing one indice below 59 62 ! =============== ! 60 63 INTEGER, PUBLIC, PARAMETER :: jpdyn_hpg = 1 !: hydrostatic pressure gradient … … 73 76 INTEGER, PUBLIC, PARAMETER :: jpdyn_spgflt = 14 !: filter contribution to surface pressure gradient (spg_flt) 74 77 INTEGER, PUBLIC, PARAMETER :: jpdyn_spgexp = 15 !: explicit contribution to surface pressure gradient (spg_flt) 78 INTEGER, PUBLIC, PARAMETER :: jpdyn_eivke = 16 !: K.E trend from Gent McWilliams scheme 75 79 ! 76 80 !!---------------------------------------------------------------------- -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdini.F90
r5602 r7806 91 91 !!gm end 92 92 ! 93 IF( lk_vvl .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' )93 ! IF( lk_vvl .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) 94 94 95 95 !!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90
r7256 r7806 27 27 USE lib_mpp ! MPP library 28 28 USE wrk_nemo ! Memory allocation 29 USE ldfslp ! Isopycnal slopes 29 30 30 31 IMPLICIT NONE … … 42 43 # include "domzgr_substitute.h90" 43 44 # include "vectopt_loop_substitute.h90" 45 # include "ldfeiv_substitute.h90" 46 44 47 !!---------------------------------------------------------------------- 45 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 192 195 CALL ken_p2k( kt , zke ) 193 196 CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w 197 CASE( jpdyn_eivke ) 198 ! CMIP6 diagnostic tknebto = tendency of KE from 199 ! parameterized mesoscale eddy advection 200 ! = vertical_integral( k (N S)^2 ) rho dz 201 ! rho = reference density 202 ! S = isoneutral slope. 203 ! Most terms are on W grid so work on this grid 204 #ifdef key_traldf_eiv 205 CALL wrk_alloc( jpi, jpj, zke2d ) 206 zke2d(:,:) = 0._wp 207 DO jk = 1,jpk 208 DO ji = 1,jpi 209 DO jj = 1,jpj 210 zke2d(ji,jj) = zke2d(ji,jj) + rau0 * fsaeiw(ji, jj, jk) & 211 & * ( wslpi(ji, jj, jk) * wslpi(ji,jj,jk) & 212 & + wslpj(ji, jj, jk) * wslpj(ji,jj,jk) ) & 213 & * rn2(ji,jj,jk) * fse3w(ji, jj, jk) 214 ENDDO 215 ENDDO 216 ENDDO 217 CALL iom_put("ketrd_eiv", zke2d) 218 CALL wrk_dealloc( jpi, jpj, zke2d ) 219 #endif 194 220 ! 195 221 END SELECT -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90
r7256 r7806 150 150 rab_pe(:,:,:,:) = 0._wp 151 151 ! 152 IF ( lk_vvl ) CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume')152 ! IF ( lk_vvl ) CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume') 153 153 ! 154 154 nkstp = nit000 - 1 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r4990 r7806 38 38 REAL(wp) :: r2dt ! time-step, = 2 rdttra except at nit000 (=rdttra) if neuler=0 39 39 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend 41 42 42 43 !! * Substitutions … … 55 56 !! *** FUNCTION trd_tra_alloc *** 56 57 !!--------------------------------------------------------------------- 57 ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , STAT= trd_tra_alloc )58 ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) 58 59 ! 59 60 IF( lk_mpp ) CALL mpp_sum ( trd_tra_alloc ) … … 104 105 ztrds(:,:,:) = 0._wp 105 106 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 107 CASE( jptra_evd ) ; avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 106 108 CASE DEFAULT ! other trends: masked trends 107 109 trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store … … 128 130 zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp 129 131 DO jk = 2, jpk 130 zwt(:,:,jk) = 132 zwt(:,:,jk) = avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 131 133 zws(:,:,jk) = fsavs(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 132 134 END DO … … 138 140 END DO 139 141 CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt ) 142 ! 143 ! ! Also calculate EVD trend at this point. 144 zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes 145 DO jk = 2, jpk 146 zwt(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 147 zws(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 148 END DO 149 ! 150 ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp 151 DO jk = 1, jpkm1 152 ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / fse3t(:,:,jk) 153 ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / fse3t(:,:,jk) 154 END DO 155 CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt ) 140 156 ! 141 157 CALL wrk_dealloc( jpi, jpj, jpk, zwt, zws, ztrdt ) … … 312 328 CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 313 329 ENDIF 330 CASE( jptra_totad ) ; CALL iom_put( "ttrd_totad" , ptrdx ) ! total advection 331 CALL iom_put( "strd_totad" , ptrdy ) 314 332 CASE( jptra_ldf ) ; CALL iom_put( "ttrd_ldf" , ptrdx ) ! lateral diffusion 315 333 CALL iom_put( "strd_ldf" , ptrdy ) … … 318 336 CASE( jptra_zdfp ) ; CALL iom_put( "ttrd_zdfp", ptrdx ) ! PURE vertical diffusion (no isoneutral contribution) 319 337 CALL iom_put( "strd_zdfp", ptrdy ) 338 CASE( jptra_evd ) ; CALL iom_put( "ttrd_evd", ptrdx ) ! EVD trend (convection) 339 CALL iom_put( "strd_evd", ptrdy ) 320 340 CASE( jptra_dmp ) ; CALL iom_put( "ttrd_dmp" , ptrdx ) ! internal restoring (damping) 321 341 CALL iom_put( "strd_dmp" , ptrdy ) … … 324 344 CASE( jptra_npc ) ; CALL iom_put( "ttrd_npc" , ptrdx ) ! static instability mixing 325 345 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 )346 CASE( jptra_nsr ) ; CALL iom_put( "ttrd_qns" , ptrdx(:,:,1) ) ! surface forcing + runoff (ln_rnf=T) 347 CALL iom_put( "strd_cdt" , ptrdy(:,:,1) ) ! output as 2D surface fields 328 348 CASE( jptra_qsr ) ; CALL iom_put( "ttrd_qsr" , ptrdx ) ! penetrative solar radiat. (only on temperature) 329 349 CASE( jptra_bbc ) ; CALL iom_put( "ttrd_bbc" , ptrdx ) ! geothermal heating (only on temperature) 330 350 CASE( jptra_atf ) ; CALL iom_put( "ttrd_atf" , ptrdx ) ! asselin time Filter 331 351 CALL iom_put( "strd_atf" , ptrdy ) 352 CASE( jptra_tot ) ; CALL iom_put( "ttrd_tot" , ptrdx ) ! model total trend 353 CALL iom_put( "strd_tot" , ptrdy ) 332 354 END SELECT 333 355 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90
r4990 r7806 19 19 USE zdf_oce ! ocean vertical physics variables 20 20 USE zdfkpp ! KPP vertical mixing 21 USE trd_oce ! trends: ocean variables 22 USE trdtra ! trends manager: tracers 21 23 USE in_out_manager ! I/O manager 22 24 USE iom ! for iom_put … … 122 124 zavt_evd(:,:,:) = avt(:,:,:) - zavt_evd(:,:,:) ! change in avt due to evd 123 125 CALL iom_put( "avt_evd", zavt_evd ) ! output this change 126 IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) 124 127 ! 125 128 IF( nn_timing == 1 ) CALL timing_stop('zdf_evd') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r7256 r7806 323 323 zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 324 324 ! ! TKE Langmuir circulation source term 325 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp -fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) / &325 en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) / & 326 326 & zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 327 327 END DO … … 436 436 DO ji = fs_2, fs_jpim1 ! vector opt. 437 437 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 438 & * ( 1._wp -fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)438 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 439 439 END DO 440 440 END DO … … 445 445 jk = nmln(ji,jj) 446 446 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 447 & * ( 1._wp -fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)447 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 448 448 END DO 449 449 END DO … … 461 461 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 462 462 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 463 & * ( 1._wp -fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)463 & * MAX(0.,1._wp - 2.*fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 464 464 END DO 465 465 END DO -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r7332 r7806 487 487 ! ! Diagnostics 488 488 IF( lk_floats ) CALL flo_init ! drifting Floats 489 IF( lk_diaar5 ) CALL dia_ar5_init ! ar5 diag490 489 CALL dia_ptr_init ! Poleward TRansports initialization 491 490 IF( lk_diadct ) CALL dia_dct_init ! Sections tranports … … 755 754 ! ilfax contains the set of allowed factors. 756 755 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 757 !!----------------------------------------------------------------------758 ! ilfax contains the set of allowed factors.759 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)760 756 761 757 ! Clear the error flag and initialise output vars -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90
r7256 r7806 237 237 IF( lk_diaar5 ) CALL dia_ar5( kstp ) ! ar5 diag 238 238 IF( lk_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 239 CALL dia_prod( kstp ) ! ocean model: product diagnostics 239 240 CALL dia_wri( kstp ) ! ocean model: outputs 240 241 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r7256 r7806 95 95 USE diahsb ! heat, salt and volume budgets (dia_hsb routine) 96 96 USE diaharm 97 USE diaprod ! ocean model: product diagnostics 97 98 USE flo_oce ! floats variables 98 99 USE floats ! floats computation (flo_stp routine) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r7256 r7806 180 180 ENDIF 181 181 182 9200 FORMAT('it:', i8, ' iter:', i4, ' r: ', e16.10, ' b: ',e16.10)183 9300 FORMAT(' it :', i8, ' ssh2: ', e16.10, ' Umax: ',e16.10,' Smin: ',e16.10)182 9200 FORMAT('it:', i8, ' iter:', i4, ' r: ',d23.16, ' b: ',d23.16 ) 183 9300 FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 184 184 ! 185 185 END SUBROUTINE stp_ctl -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90
r7256 r7806 621 621 ! 622 622 ! lfax contains the set of allowed factors. 623 data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, & 624 & 128, 64, 32, 16, 8, 4, 2 / 625 !!---------------------------------------------------------------------- 623 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 626 624 627 625 ! Clear the error flag and initialise output vars -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/par_my_trc.F90
r3680 r7806 7 7 !!---------------------------------------------------------------------- 8 8 !! NEMO/TOP 3.3 , NEMO Consortium (2010) 9 !! $Id$ 9 !! $Id$ 10 10 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 11 11 !!---------------------------------------------------------------------- … … 25 25 USE par_c14b , ONLY : jp_c14b_trd !: number of tracers in C14 26 26 27 USE par_age , ONLY : jp_age !: number of tracers in AGE 28 USE par_age , ONLY : jp_age_2d !: number of tracers in AGE 29 USE par_age , ONLY : jp_age_3d !: number of tracers in AGE 30 USE par_age , ONLY : jp_age_trd !: number of tracers in AGE 31 27 32 IMPLICIT NONE 28 33 29 INTEGER, PARAMETER :: jp_lm = jp_pisces + jp_cfc + jp_c14b !:30 INTEGER, PARAMETER :: jp_lm_2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d !:31 INTEGER, PARAMETER :: jp_lm_3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d !:32 INTEGER, PARAMETER :: jp_lm_trd = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd !:34 INTEGER, PARAMETER :: jp_lm = jp_pisces + jp_cfc + jp_c14b + jp_age !: 35 INTEGER, PARAMETER :: jp_lm_2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d + jp_age_2d !: 36 INTEGER, PARAMETER :: jp_lm_3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d + jp_age_3d !: 37 INTEGER, PARAMETER :: jp_lm_trd = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_age_trd !: 33 38 34 39 #if defined key_my_trc -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90
r7398 r7806 11 11 !! 2.0 ! 2007-12 (C. Ethe, G. Madec) F90 12 12 !! ! 2011-02 (J. Simeon, J.Orr ) update O2 solubility constants 13 !! 3.6 ! 2016-03 (O. Aumont) Change chemistry to MOCSY standards 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_pisces 15 16 !!---------------------------------------------------------------------- 16 !! 'key_pisces 'PISCES bio-model17 !! 'key_pisces*' PISCES bio-model 17 18 !!---------------------------------------------------------------------- 18 19 !! p4z_che : Sea water chemistry computed following OCMIP protocol … … 21 22 USE sms_pisces ! PISCES Source Minus Sink variables 22 23 USE lib_mpp ! MPP library 24 USE eosbn2, ONLY : nn_eos 23 25 24 26 IMPLICIT NONE 25 27 PRIVATE 26 28 27 PUBLIC p4z_che ! 28 PUBLIC p4z_che_alloc ! 29 30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sio3eq ! chemistry of Si 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fekeq ! chemistry of Fe 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemc ! Solubilities of O2 and CO2 33 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemo2 ! Solubilities of O2 and CO2 29 PUBLIC p4z_che ! 30 PUBLIC p4z_che_alloc ! 31 PUBLIC p4z_che_ahini ! 32 PUBLIC p4z_che_solve_hi ! 33 34 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sio3eq ! chemistry of Si 35 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fekeq ! chemistry of Fe 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemc ! Solubilities of O2 and CO2 37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemo2 ! Solubilities of O2 and CO2 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: fesol ! solubility of Fe 34 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tempis ! In situ temperature 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: salinprac ! Practical salinity 41 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akb3 !: ??? 43 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akw3 !: ??? 44 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akf3 !: ??? 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aks3 !: ??? 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak1p3 !: ??? 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak2p3 !: ??? 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak3p3 !: ??? 49 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aksi3 !: ??? 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: borat !: ??? 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fluorid !: ??? 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sulfat !: ??? 53 54 !!* Variable for chemistry of the CO2 cycle 35 55 36 56 REAL(wp), PUBLIC :: atcox = 0.20946 ! units atm 37 57 38 REAL(wp) :: salchl = 1. / 1.80655 ! conversion factor for salinity --> chlorinity (Wooster et al. 1969)39 58 REAL(wp) :: o2atm = 1. / ( 1000. * 0.20946 ) 40 59 41 REAL(wp) :: rgas = 83.14472 ! universal gas constants 42 REAL(wp) :: oxyco = 1. / 22.4144 ! converts from liters of an ideal gas to moles 43 44 REAL(wp) :: bor1 = 0.00023 ! borat constants 45 REAL(wp) :: bor2 = 1. / 10.82 46 47 REAL(wp) :: st1 = 0.14 ! constants for calculate concentrations for sulfate 48 REAL(wp) :: st2 = 1./96.062 ! (Morris & Riley 1966) 49 50 REAL(wp) :: ft1 = 0.000067 ! constants for calculate concentrations for fluorides 51 REAL(wp) :: ft2 = 1./18.9984 ! (Dickson & Riley 1979 ) 52 53 ! ! volumetric solubility constants for o2 in ml/L 54 REAL(wp) :: ox0 = 2.00856 ! from Table 1 for Eq 8 of Garcia and Gordon, 1992. 55 REAL(wp) :: ox1 = 3.22400 ! corrects for moisture and fugacity, but not total atmospheric pressure 56 REAL(wp) :: ox2 = 3.99063 ! Original PISCES code noted this was a solubility, but 57 REAL(wp) :: ox3 = 4.80299 ! was in fact a bunsen coefficient with units L-O2/(Lsw atm-O2) 58 REAL(wp) :: ox4 = 9.78188e-1 ! Hence, need to divide EXP( zoxy ) by 1000, ml-O2 => L-O2 59 REAL(wp) :: ox5 = 1.71069 ! and atcox = 0.20946 to add the 1/atm dimension. 60 REAL(wp) :: ox6 = -6.24097e-3 61 REAL(wp) :: ox7 = -6.93498e-3 62 REAL(wp) :: ox8 = -6.90358e-3 63 REAL(wp) :: ox9 = -4.29155e-3 64 REAL(wp) :: ox10 = -3.11680e-7 60 REAL(wp) :: rgas = 83.14472 ! universal gas constants 61 REAL(wp) :: oxyco = 1. / 22.4144 ! converts from liters of an ideal gas to moles 65 62 66 63 ! ! coeff. for seawater pressure correction : millero 95 67 64 ! ! AGRIF doesn't like the DATA instruction 68 REAL(wp) :: devk11 = -25.5 69 REAL(wp) :: devk12 = -15.82 70 REAL(wp) :: devk13 = -29.48 71 REAL(wp) :: devk14 = -25.60 72 REAL(wp) :: devk15 = -48.76 65 REAL(wp) :: devk10 = -25.5 66 REAL(wp) :: devk11 = -15.82 67 REAL(wp) :: devk12 = -29.48 68 REAL(wp) :: devk13 = -20.02 69 REAL(wp) :: devk14 = -18.03 70 REAL(wp) :: devk15 = -9.78 71 REAL(wp) :: devk16 = -48.76 72 REAL(wp) :: devk17 = -14.51 73 REAL(wp) :: devk18 = -23.12 74 REAL(wp) :: devk19 = -26.57 75 REAL(wp) :: devk110 = -29.48 73 76 ! 74 REAL(wp) :: devk21 = 0.1271 75 REAL(wp) :: devk22 = -0.0219 76 REAL(wp) :: devk23 = 0.1622 77 REAL(wp) :: devk24 = 0.2324 78 REAL(wp) :: devk25 = 0.5304 77 REAL(wp) :: devk20 = 0.1271 78 REAL(wp) :: devk21 = -0.0219 79 REAL(wp) :: devk22 = 0.1622 80 REAL(wp) :: devk23 = 0.1119 81 REAL(wp) :: devk24 = 0.0466 82 REAL(wp) :: devk25 = -0.0090 83 REAL(wp) :: devk26 = 0.5304 84 REAL(wp) :: devk27 = 0.1211 85 REAL(wp) :: devk28 = 0.1758 86 REAL(wp) :: devk29 = 0.2020 87 REAL(wp) :: devk210 = 0.1622 79 88 ! 89 REAL(wp) :: devk30 = 0. 80 90 REAL(wp) :: devk31 = 0. 81 REAL(wp) :: devk32 = 0. 82 REAL(wp) :: devk33 = 2.608E-3 83 REAL(wp) :: devk34 = -3.6246E-3 84 REAL(wp) :: devk35 = 0. 91 REAL(wp) :: devk32 = 2.608E-3 92 REAL(wp) :: devk33 = -1.409e-3 93 REAL(wp) :: devk34 = 0.316e-3 94 REAL(wp) :: devk35 = -0.942e-3 95 REAL(wp) :: devk36 = 0. 96 REAL(wp) :: devk37 = -0.321e-3 97 REAL(wp) :: devk38 = -2.647e-3 98 REAL(wp) :: devk39 = -3.042e-3 99 REAL(wp) :: devk310 = -2.6080e-3 85 100 ! 86 REAL(wp) :: devk41 = -3.08E-3 87 REAL(wp) :: devk42 = 1.13E-3 88 REAL(wp) :: devk43 = -2.84E-3 89 REAL(wp) :: devk44 = -5.13E-3 90 REAL(wp) :: devk45 = -11.76E-3 101 REAL(wp) :: devk40 = -3.08E-3 102 REAL(wp) :: devk41 = 1.13E-3 103 REAL(wp) :: devk42 = -2.84E-3 104 REAL(wp) :: devk43 = -5.13E-3 105 REAL(wp) :: devk44 = -4.53e-3 106 REAL(wp) :: devk45 = -3.91e-3 107 REAL(wp) :: devk46 = -11.76e-3 108 REAL(wp) :: devk47 = -2.67e-3 109 REAL(wp) :: devk48 = -5.15e-3 110 REAL(wp) :: devk49 = -4.08e-3 111 REAL(wp) :: devk410 = -2.84e-3 91 112 ! 92 REAL(wp) :: devk51 = 0.0877E-3 93 REAL(wp) :: devk52 = -0.1475E-3 94 REAL(wp) :: devk53 = 0. 95 REAL(wp) :: devk54 = 0.0794E-3 96 REAL(wp) :: devk55 = 0.3692E-3 113 REAL(wp) :: devk50 = 0.0877E-3 114 REAL(wp) :: devk51 = -0.1475E-3 115 REAL(wp) :: devk52 = 0. 116 REAL(wp) :: devk53 = 0.0794E-3 117 REAL(wp) :: devk54 = 0.09e-3 118 REAL(wp) :: devk55 = 0.054e-3 119 REAL(wp) :: devk56 = 0.3692E-3 120 REAL(wp) :: devk57 = 0.0427e-3 121 REAL(wp) :: devk58 = 0.09e-3 122 REAL(wp) :: devk59 = 0.0714e-3 123 REAL(wp) :: devk510 = 0.0 124 ! 125 ! General parameters 126 REAL(wp), PARAMETER :: pp_rdel_ah_target = 1.E-4_wp 127 REAL(wp), PARAMETER :: pp_ln10 = 2.302585092994045684018_wp 128 129 ! Maximum number of iterations for each method 130 INTEGER, PARAMETER :: jp_maxniter_atgen = 20 131 132 ! Bookkeeping variables for each method 133 ! - SOLVE_AT_GENERAL 134 INTEGER :: niter_atgen = jp_maxniter_atgen 97 135 98 136 !!* Substitution … … 114 152 !!--------------------------------------------------------------------- 115 153 INTEGER :: ji, jj, jk 116 REAL(wp) :: ztkel, zt , zt2, zsal , zsal2 , zbuf1 , zbuf2154 REAL(wp) :: ztkel, ztkel1, zt , zsal , zsal2 , zbuf1 , zbuf2 117 155 REAL(wp) :: ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 118 156 REAL(wp) :: zpres, ztc , zcl , zcpexp, zoxy , zcpexp2 119 157 REAL(wp) :: zsqrt, ztr , zlogt , zcek1, zc1, zplat 120 REAL(wp) :: zis , zis2 , zsal15, zisqrt, za1 158 REAL(wp) :: zis , zis2 , zsal15, zisqrt, za1, za2 121 159 REAL(wp) :: zckb , zck1 , zck2 , zckw , zak1 , zak2 , zakb , zaksp0, zakw 160 REAL(wp) :: zck1p, zck2p, zck3p, zcksi, zak1p, zak2p, zak3p, zaksi 122 161 REAL(wp) :: zst , zft , zcks , zckf , zaksp1 162 REAL(wp) :: total2free, free2SWS, total2SWS, SWS2total 163 123 164 !!--------------------------------------------------------------------- 124 165 ! 125 166 IF( nn_timing == 1 ) CALL timing_start('p4z_che') 167 ! 168 ! Computation of chemical constants require practical salinity 169 ! Thus, when TEOS08 is used, absolute salinity is converted to 170 ! practical salinity 171 ! ------------------------------------------------------------- 172 IF (nn_eos == -1) THEN 173 salinprac(:,:,:) = tsn(:,:,:,jp_sal) * 35.0 / 35.16504 174 ELSE 175 salinprac(:,:,:) = tsn(:,:,:,jp_sal) 176 ENDIF 177 126 178 ! 127 179 ! Computations of chemical constants require in situ temperature … … 134 186 DO ji = 1, jpi 135 187 zpres = fsdept(ji,jj,jk) / 1000. 136 za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * ( tsn(ji,jj,jk,jp_sal) - 35.0) )188 za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (salinprac(ji,jj,jk) - 35.0) ) 137 189 za2 = 0.0075 * ( 1.0 - tsn(ji,jj,jk,jp_tem) / 30.0 ) 138 190 tempis(ji,jj,jk) = tsn(ji,jj,jk,jp_tem) - za1 * zpres + za2 * zpres**2 … … 150 202 ztkel = tempis(ji,jj,1) + 273.15 151 203 zt = ztkel * 0.01 152 zt2 = zt * zt 153 zsal = tsn(ji,jj,1,jp_sal) + ( 1.- tmask(ji,jj,1) ) * 35. 154 zsal2 = zsal * zsal 155 zlogt = LOG( zt ) 204 zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. 156 205 ! ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 157 206 ! ! AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 158 207 zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel & 159 208 & + 0.0047036e-4*ztkel**2) 160 ! ! SET SOLUBILITIES OF O2 AND CO2 161 chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(kg uatm) 209 chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 * rhop(ji,jj,1) / 1000. ! mol/(L atm) 162 210 chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 163 211 chemc(ji,jj,3) = 57.7 - 0.118*ztkel … … 175 223 DO ji = 1, jpi 176 224 ztkel = tempis(ji,jj,jk) + 273.15 177 zsal = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35.225 zsal = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35. 178 226 zsal2 = zsal * zsal 179 227 ztgg = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel ) ! Set the GORDON & GARCIA scaled temperature … … 182 230 ztgg4 = ztgg3 * ztgg 183 231 ztgg5 = ztgg4 * ztgg 184 zoxy = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5 & 185 + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) + ox10 * zsal2 232 233 zoxy = 2.00856 + 3.22400 * ztgg + 3.99063 * ztgg2 + 4.80299 * ztgg3 & 234 & + 9.78188e-1 * ztgg4 + 1.71069 * ztgg5 + zsal * ( -6.24097e-3 & 235 & - 6.93498e-3 * ztgg - 6.90358e-3 * ztgg2 - 4.29155e-3 * ztgg3 ) & 236 & - 3.11680e-7 * zsal2 186 237 chemo2(ji,jj,jk) = ( EXP( zoxy ) * o2atm ) * oxyco * atcox ! mol/(L atm) 187 238 END DO … … 208 259 ! SET ABSOLUTE TEMPERATURE 209 260 ztkel = tempis(ji,jj,jk) + 273.15 210 zsal = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35.261 zsal = salinprac(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. 211 262 zsqrt = SQRT( zsal ) 212 263 zsal15 = zsqrt * zsal … … 219 270 220 271 ! CHLORINITY (WOOSTER ET AL., 1969) 221 zcl = zsal * salchl272 zcl = zsal / 1.80655 222 273 223 274 ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] 224 zst = st1 * zcl * st2275 zst = 0.14 * zcl /96.062 225 276 226 277 ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 227 zft = ft1 * zcl * ft2278 zft = 0.000067 * zcl /18.9984 228 279 229 280 ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) … … 233 284 & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & 234 285 & + LOG(1.0 - 0.001005 * zsal)) 235 !236 aphscale(ji,jj,jk) = ( 1. + zst / zcks )237 286 238 287 ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) … … 248 297 & * zlogt + 0.053105*zsqrt*ztkel 249 298 250 251 299 ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO 252 300 ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale … … 256 304 - 0.01781*zsal + 0.0001122*zsal*zsal) 257 305 258 ! PKW (H2O) (DICKSON AND RILEY, 1979) 259 zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt & 260 & + (118.67*ztr - 5.977 + 1.0495 * zlogt) & 261 & * zsqrt - 0.01615 * zsal 306 ! PKW (H2O) (MILLERO, 1995) from composite data 307 zckw = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr & 308 - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal 309 310 ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) 311 zck1p = -4576.752*ztr + 115.540 - 18.453*zlogt & 312 & + (-106.736*ztr + 0.69171) * zsqrt & 313 & + (-0.65643*ztr - 0.01844) * zsal 314 315 zck2p = -8814.715*ztr + 172.1033 - 27.927*zlogt & 316 & + (-160.340*ztr + 1.3566)*zsqrt & 317 & + (0.37335*ztr - 0.05778)*zsal 318 319 zck3p = -3070.75*ztr - 18.126 & 320 & + (17.27039*ztr + 2.81197) * zsqrt & 321 & + (-44.99486*ztr - 0.09984) * zsal 322 323 ! CONSTANT FOR SILICATE, MILLERO (1995) 324 zcksi = -8904.2*ztr + 117.400 - 19.334*zlogt & 325 & + (-458.79*ztr + 3.5913) * zisqrt & 326 & + (188.74*ztr - 1.5998) * zis & 327 & + (-12.1652*ztr + 0.07871) * zis2 & 328 & + LOG(1.0 - 0.001005*zsal) 262 329 263 330 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER … … 267 334 & - 0.07711*zsal + 0.0041249*zsal15 268 335 336 ! CONVERT FROM DIFFERENT PH SCALES 337 total2free = 1.0/(1.0 + zst/zcks) 338 free2SWS = 1. + zst/zcks + zft/(zckf*total2free) 339 total2SWS = total2free * free2SWS 340 SWS2total = 1.0 / total2SWS 341 269 342 ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 270 zak1 = 10**(zck1) 271 zak2 = 10**(zck2) 272 zakb = EXP( zckb )343 zak1 = 10**(zck1) * total2SWS 344 zak2 = 10**(zck2) * total2SWS 345 zakb = EXP( zckb ) * total2SWS 273 346 zakw = EXP( zckw ) 274 347 zaksp1 = 10**(zaksp0) 348 zak1p = exp( zck1p ) 349 zak2p = exp( zck2p ) 350 zak3p = exp( zck3p ) 351 zaksi = exp( zcksi ) 352 zckf = zckf * total2SWS 275 353 276 354 ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) … … 284 362 ! FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 285 363 ! SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) 286 zcpexp = zpres / (rgas*ztkel)287 zcpexp2 = zpres * z pres/(rgas*ztkel)364 zcpexp = zpres / (rgas*ztkel) 365 zcpexp2 = zpres * zcpexp 288 366 289 367 ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE … … 291 369 ! (CF. BROECKER ET AL., 1982) 292 370 293 zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 371 zbuf1 = - ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) 372 zbuf2 = 0.5 * ( devk40 + devk50 * ztc ) 373 ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 374 375 zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 294 376 zbuf2 = 0.5 * ( devk41 + devk51 * ztc ) 295 ak 13(ji,jj,jk) = zak1* EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 )377 ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 296 378 297 379 zbuf1 = - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) 298 380 zbuf2 = 0.5 * ( devk42 + devk52 * ztc ) 299 ak 23(ji,jj,jk) = zak2* EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 )381 akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 300 382 301 383 zbuf1 = - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) 302 384 zbuf2 = 0.5 * ( devk43 + devk53 * ztc ) 303 ak b3(ji,jj,jk) = zakb* EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 )385 akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 304 386 305 387 zbuf1 = - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) 306 388 zbuf2 = 0.5 * ( devk44 + devk54 * ztc ) 307 akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 308 389 aks3(ji,jj,jk) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 390 391 zbuf1 = - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) 392 zbuf2 = 0.5 * ( devk45 + devk55 * ztc ) 393 akf3(ji,jj,jk) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 394 395 zbuf1 = - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) 396 zbuf2 = 0.5 * ( devk47 + devk57 * ztc ) 397 ak1p3(ji,jj,jk) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 398 399 zbuf1 = - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) 400 zbuf2 = 0.5 * ( devk48 + devk58 * ztc ) 401 ak2p3(ji,jj,jk) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 402 403 zbuf1 = - ( devk19 + devk29 * ztc + devk39 * ztc * ztc ) 404 zbuf2 = 0.5 * ( devk49 + devk59 * ztc ) 405 ak3p3(ji,jj,jk) = zak3p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 406 407 zbuf1 = - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) 408 zbuf2 = 0.5 * ( devk410 + devk510 * ztc ) 409 aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 410 411 ! CONVERT FROM DIFFERENT PH SCALES 412 total2free = 1.0/(1.0 + zst/aks3(ji,jj,jk)) 413 free2SWS = 1. + zst/aks3(ji,jj,jk) + zft/akf3(ji,jj,jk) 414 total2SWS = total2free * free2SWS 415 SWS2total = 1.0 / total2SWS 416 417 ! Convert to total scale 418 ak13(ji,jj,jk) = ak13(ji,jj,jk) * SWS2total 419 ak23(ji,jj,jk) = ak23(ji,jj,jk) * SWS2total 420 akb3(ji,jj,jk) = akb3(ji,jj,jk) * SWS2total 421 akw3(ji,jj,jk) = akw3(ji,jj,jk) * SWS2total 422 ak1p3(ji,jj,jk) = ak1p3(ji,jj,jk) * SWS2total 423 ak2p3(ji,jj,jk) = ak2p3(ji,jj,jk) * SWS2total 424 ak3p3(ji,jj,jk) = ak3p3(ji,jj,jk) * SWS2total 425 aksi3(ji,jj,jk) = aksi3(ji,jj,jk) * SWS2total 426 akf3(ji,jj,jk) = akf3(ji,jj,jk) / total2free 309 427 310 428 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE 311 429 ! AS FUNCTION OF PRESSURE FOLLOWING MILLERO 312 430 ! (P. 1285) AND BERNER (1976) 313 zbuf1 = - ( devk1 5 + devk25 * ztc + devk35* ztc * ztc )314 zbuf2 = 0.5 * ( devk4 5 + devk55* ztc )431 zbuf1 = - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) 432 zbuf2 = 0.5 * ( devk46 + devk56 * ztc ) 315 433 aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 316 434 317 ! TOTAL BORATE CONCENTR. [MOLES/L] 318 borat(ji,jj,jk) = bor1 * zcl * bor2 435 ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] 436 borat(ji,jj,jk) = 0.0002414 * zcl / 10.811 437 sulfat(ji,jj,jk) = zst 438 fluorid(ji,jj,jk) = zft 319 439 320 440 ! Iron and SIO3 saturation concentration from ... 321 441 sio3eq(ji,jj,jk) = EXP( LOG( 10.) * ( 6.44 - 968. / ztkel ) ) * 1.e-6 322 fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ( 273.15 + ztc ) ) 323 442 fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ztkel ) 443 444 ! Liu and Millero (1999) only valid 5 - 50 degC 445 ztkel1 = MAX( 5. , tempis(ji,jj,jk) ) + 273.16 446 fesol(ji,jj,jk,1) = 10**((-13.486) - (0.1856* (zis**0.5)) + (0.3073*zis) + (5254.0/ztkel1)) 447 fesol(ji,jj,jk,2) = 10**(2.517 - (0.885*(zis**0.5)) + (0.2139 * zis) - (1320.0/ztkel1) ) 448 fesol(ji,jj,jk,3) = 10**(0.4511 - (0.3305*(zis**0.5)) - (1996.0/ztkel1) ) 449 fesol(ji,jj,jk,4) = 10**(-0.2965 - (0.7881*(zis**0.5)) - (4086.0/ztkel1) ) 450 fesol(ji,jj,jk,5) = 10**(4.4466 - (0.8505*(zis**0.5)) - (7980.0/ztkel1) ) 324 451 END DO 325 452 END DO … … 330 457 END SUBROUTINE p4z_che 331 458 459 SUBROUTINE p4z_che_ahini( p_hini ) 460 !!--------------------------------------------------------------------- 461 !! *** ROUTINE ahini_for_at *** 462 !! 463 !! Subroutine returns the root for the 2nd order approximation of the 464 !! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic 465 !! polynomial) around the local minimum, if it exists. 466 !! Returns * 1E-03_wp if p_alkcb <= 0 467 !! * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot 468 !! * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot 469 !! and the 2nd order approximation does not have 470 !! a solution 471 !!--------------------------------------------------------------------- 472 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_hini 473 INTEGER :: ji, jj, jk 474 REAL(wp) :: zca1, zba1 475 REAL(wp) :: zd, zsqrtd, zhmin 476 REAL(wp) :: za2, za1, za0 477 REAL(wp) :: p_dictot, p_bortot, p_alkcb 478 479 IF( nn_timing == 1 ) CALL timing_start('p4z_che_ahini') 480 ! 481 DO jk = 1, jpk 482 DO jj = 1, jpj 483 DO ji = 1, jpi 484 p_alkcb = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) 485 p_dictot = trb(ji,jj,jk,jpdic) * 1000. / (rhop(ji,jj,jk) + rtrn) 486 p_bortot = borat(ji,jj,jk) 487 IF (p_alkcb <= 0.) THEN 488 p_hini(ji,jj,jk) = 1.e-3 489 ELSEIF (p_alkcb >= (2.*p_dictot + p_bortot)) THEN 490 p_hini(ji,jj,jk) = 1.e-10_wp 491 ELSE 492 zca1 = p_dictot/( p_alkcb + rtrn ) 493 zba1 = p_bortot/ (p_alkcb + rtrn ) 494 ! Coefficients of the cubic polynomial 495 za2 = aKb3(ji,jj,jk)*(1. - zba1) + ak13(ji,jj,jk)*(1.-zca1) 496 za1 = ak13(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - zca1) & 497 & + ak13(ji,jj,jk)*ak23(ji,jj,jk)*(1. - (zca1+zca1)) 498 za0 = ak13(ji,jj,jk)*ak23(ji,jj,jk)*akb3(ji,jj,jk)*(1. - zba1 - (zca1+zca1)) 499 ! Taylor expansion around the minimum 500 zd = za2*za2 - 3.*za1 ! Discriminant of the quadratic equation 501 ! for the minimum close to the root 502 503 IF(zd > 0.) THEN ! If the discriminant is positive 504 zsqrtd = SQRT(zd) 505 IF(za2 < 0) THEN 506 zhmin = (-za2 + zsqrtd)/3. 507 ELSE 508 zhmin = -za1/(za2 + zsqrtd) 509 ENDIF 510 p_hini(ji,jj,jk) = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd) 511 ELSE 512 p_hini(ji,jj,jk) = 1.e-7 513 ENDIF 514 ! 515 ENDIF 516 END DO 517 END DO 518 END DO 519 ! 520 IF( nn_timing == 1 ) CALL timing_stop('p4z_che_ahini') 521 ! 522 END SUBROUTINE p4z_che_ahini 523 524 !=============================================================================== 525 SUBROUTINE anw_infsup( p_alknw_inf, p_alknw_sup ) 526 527 ! Subroutine returns the lower and upper bounds of "non-water-selfionization" 528 ! contributions to total alkalinity (the infimum and the supremum), i.e 529 ! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+]) 530 531 ! Argument variables 532 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_inf 533 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_sup 534 535 p_alknw_inf(:,:,:) = -trb(:,:,:,jppo4) * 1000. / (rhop(:,:,:) + rtrn) - sulfat(:,:,:) & 536 & - fluorid(:,:,:) 537 p_alknw_sup(:,:,:) = (2. * trb(:,:,:,jpdic) + 2. * trb(:,:,:,jppo4) + trb(:,:,:,jpsil) ) & 538 & * 1000. / (rhop(:,:,:) + rtrn) + borat(:,:,:) 539 540 END SUBROUTINE anw_infsup 541 542 543 SUBROUTINE p4z_che_solve_hi( p_hini, zhi ) 544 545 ! Universal pH solver that converges from any given initial value, 546 ! determines upper an lower bounds for the solution if required 547 548 ! Argument variables 549 !-------------------- 550 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: p_hini 551 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: zhi 552 553 ! Local variables 554 !----------------- 555 INTEGER :: ji, jj, jk, jn 556 REAL(wp) :: zh_ini, zh, zh_prev, zh_lnfactor 557 REAL(wp) :: zdelta, zh_delta 558 REAL(wp) :: zeqn, zdeqndh, zalka 559 REAL(wp) :: aphscale 560 REAL(wp) :: znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic 561 REAL(wp) :: znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor 562 REAL(wp) :: znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4 563 REAL(wp) :: znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil 564 REAL(wp) :: znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4 565 REAL(wp) :: znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu 566 REAL(wp) :: zalk_wat, zdalk_wat 567 REAL(wp) :: zfact, p_alktot, zdic, zbot, zpt, zst, zft, zsit 568 LOGICAL :: l_exitnow 569 REAL(wp), PARAMETER :: pz_exp_threshold = 1.0 570 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin 571 572 IF( nn_timing == 1 ) CALL timing_start('p4z_che_solve_hi') 573 ! Allocate temporary workspace 574 CALL wrk_alloc( jpi, jpj, jpk, zalknw_inf, zalknw_sup, rmask ) 575 CALL wrk_alloc( jpi, jpj, jpk, zh_min, zh_max, zeqn_absmin ) 576 577 CALL anw_infsup( zalknw_inf, zalknw_sup ) 578 579 rmask(:,:,:) = tmask(:,:,:) 580 zhi(:,:,:) = 0. 581 582 ! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree 583 DO jk = 1, jpk 584 DO jj = 1, jpj 585 DO ji = 1, jpi 586 IF (rmask(ji,jj,jk) == 1.) THEN 587 p_alktot = trb(ji,jj,jk,jptal) * 1000. / (rhop(ji,jj,jk) + rtrn) 588 aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) 589 zh_ini = p_hini(ji,jj,jk) 590 591 zdelta = (p_alktot-zalknw_inf(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale 592 593 IF(p_alktot >= zalknw_inf(ji,jj,jk)) THEN 594 zh_min(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_inf(ji,jj,jk) + SQRT(zdelta) ) 595 ELSE 596 zh_min(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_inf(ji,jj,jk)) + SQRT(zdelta) ) / 2. 597 ENDIF 598 599 zdelta = (p_alktot-zalknw_sup(ji,jj,jk))**2 + 4.*akw3(ji,jj,jk)/aphscale 600 601 IF(p_alktot <= zalknw_sup(ji,jj,jk)) THEN 602 zh_max(ji,jj,jk) = aphscale*(-(p_alktot-zalknw_sup(ji,jj,jk)) + SQRT(zdelta) ) / 2. 603 ELSE 604 zh_max(ji,jj,jk) = 2.*akw3(ji,jj,jk) /( p_alktot-zalknw_sup(ji,jj,jk) + SQRT(zdelta) ) 605 ENDIF 606 607 zhi(ji,jj,jk) = MAX(MIN(zh_max(ji,jj,jk), zh_ini), zh_min(ji,jj,jk)) 608 ENDIF 609 END DO 610 END DO 611 END DO 612 613 zeqn_absmin(:,:,:) = HUGE(1._wp) 614 615 DO jn = 1, jp_maxniter_atgen 616 DO jk = 1, jpk 617 DO jj = 1, jpj 618 DO ji = 1, jpi 619 IF (rmask(ji,jj,jk) == 1.) THEN 620 zfact = rhop(ji,jj,jk) / 1000. + rtrn 621 p_alktot = trb(ji,jj,jk,jptal) / zfact 622 zdic = trb(ji,jj,jk,jpdic) / zfact 623 zbot = borat(ji,jj,jk) 624 zpt = trb(ji,jj,jk,jppo4) / zfact * po4r 625 zsit = trb(ji,jj,jk,jpsil) / zfact 626 zst = sulfat (ji,jj,jk) 627 zft = fluorid(ji,jj,jk) 628 aphscale = 1. + sulfat(ji,jj,jk)/aks3(ji,jj,jk) 629 zh = zhi(ji,jj,jk) 630 zh_prev = zh 631 632 ! H2CO3 - HCO3 - CO3 : n=2, m=0 633 znumer_dic = 2.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk) 634 zdenom_dic = ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*(ak13(ji,jj,jk) + zh) 635 zalk_dic = zdic * (znumer_dic/zdenom_dic) 636 zdnumer_dic = ak13(ji,jj,jk)*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh & 637 *(4.*ak13(ji,jj,jk)*ak23(ji,jj,jk) + zh*ak13(ji,jj,jk)) 638 zdalk_dic = -zdic*(zdnumer_dic/zdenom_dic**2) 639 640 641 ! B(OH)3 - B(OH)4 : n=1, m=0 642 znumer_bor = akb3(ji,jj,jk) 643 zdenom_bor = akb3(ji,jj,jk) + zh 644 zalk_bor = zbot * (znumer_bor/zdenom_bor) 645 zdnumer_bor = akb3(ji,jj,jk) 646 zdalk_bor = -zbot*(zdnumer_bor/zdenom_bor**2) 647 648 649 ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1 650 znumer_po4 = 3.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & 651 & + zh*(2.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh* ak1p3(ji,jj,jk)) 652 zdenom_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & 653 & + zh*( ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh*(ak1p3(ji,jj,jk) + zh)) 654 zalk_po4 = zpt * (znumer_po4/zdenom_po4 - 1.) ! Zero level of H3PO4 = 1 655 zdnumer_po4 = ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & 656 & + zh*(4.*ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & 657 & + zh*(9.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk)*ak3p3(ji,jj,jk) & 658 & + ak1p3(ji,jj,jk)*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) & 659 & + zh*(4.*ak1p3(ji,jj,jk)*ak2p3(ji,jj,jk) + zh * ak1p3(ji,jj,jk) ) ) ) 660 zdalk_po4 = -zpt * (zdnumer_po4/zdenom_po4**2) 661 662 ! H4SiO4 - H3SiO4 : n=1, m=0 663 znumer_sil = aksi3(ji,jj,jk) 664 zdenom_sil = aksi3(ji,jj,jk) + zh 665 zalk_sil = zsit * (znumer_sil/zdenom_sil) 666 zdnumer_sil = aksi3(ji,jj,jk) 667 zdalk_sil = -zsit * (zdnumer_sil/zdenom_sil**2) 668 669 ! HSO4 - SO4 : n=1, m=1 670 aphscale = 1.0 + zst/aks3(ji,jj,jk) 671 znumer_so4 = aks3(ji,jj,jk) * aphscale 672 zdenom_so4 = aks3(ji,jj,jk) * aphscale + zh 673 zalk_so4 = zst * (znumer_so4/zdenom_so4 - 1.) 674 zdnumer_so4 = aks3(ji,jj,jk) 675 zdalk_so4 = -zst * (zdnumer_so4/zdenom_so4**2) 676 677 ! HF - F : n=1, m=1 678 znumer_flu = akf3(ji,jj,jk) 679 zdenom_flu = akf3(ji,jj,jk) + zh 680 zalk_flu = zft * (znumer_flu/zdenom_flu - 1.) 681 zdnumer_flu = akf3(ji,jj,jk) 682 zdalk_flu = -zft * (zdnumer_flu/zdenom_flu**2) 683 684 ! H2O - OH 685 aphscale = 1.0 + zst/aks3(ji,jj,jk) 686 zalk_wat = akw3(ji,jj,jk)/zh - zh/aphscale 687 zdalk_wat = -akw3(ji,jj,jk)/zh**2 - 1./aphscale 688 689 ! CALCULATE [ALK]([CO3--], [HCO3-]) 690 zeqn = zalk_dic + zalk_bor + zalk_po4 + zalk_sil & 691 & + zalk_so4 + zalk_flu & 692 & + zalk_wat - p_alktot 693 694 zalka = p_alktot - (zalk_bor + zalk_po4 + zalk_sil & 695 & + zalk_so4 + zalk_flu + zalk_wat) 696 697 zdeqndh = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil & 698 & + zdalk_so4 + zdalk_flu + zdalk_wat 699 700 ! Adapt bracketing interval 701 IF(zeqn > 0._wp) THEN 702 zh_min(ji,jj,jk) = zh_prev 703 ELSEIF(zeqn < 0._wp) THEN 704 zh_max(ji,jj,jk) = zh_prev 705 ENDIF 706 707 IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin(ji,jj,jk)) THEN 708 ! if the function evaluation at the current point is 709 ! not decreasing faster than with a bisection step (at least linearly) 710 ! in absolute value take one bisection step on [ph_min, ph_max] 711 ! ph_new = (ph_min + ph_max)/2d0 712 ! 713 ! In terms of [H]_new: 714 ! [H]_new = 10**(-ph_new) 715 ! = 10**(-(ph_min + ph_max)/2d0) 716 ! = SQRT(10**(-(ph_min + phmax))) 717 ! = SQRT(zh_max * zh_min) 718 zh = SQRT(zh_max(ji,jj,jk) * zh_min(ji,jj,jk)) 719 zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below 720 ELSE 721 ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH 722 ! = -zdeqndh * LOG(10) * [H] 723 ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10)) 724 ! 725 ! pH_new = pH_old + \deltapH 726 ! 727 ! [H]_new = 10**(-pH_new) 728 ! = 10**(-pH_old - \Delta pH) 729 ! = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10))) 730 ! = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10))) 731 ! = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old)) 732 733 zh_lnfactor = -zeqn/(zdeqndh*zh_prev) 734 735 IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN 736 zh = zh_prev*EXP(zh_lnfactor) 737 ELSE 738 zh_delta = zh_lnfactor*zh_prev 739 zh = zh_prev + zh_delta 740 ENDIF 741 742 IF( zh < zh_min(ji,jj,jk) ) THEN 743 ! if [H]_new < [H]_min 744 ! i.e., if ph_new > ph_max then 745 ! take one bisection step on [ph_prev, ph_max] 746 ! ph_new = (ph_prev + ph_max)/2d0 747 ! In terms of [H]_new: 748 ! [H]_new = 10**(-ph_new) 749 ! = 10**(-(ph_prev + ph_max)/2d0) 750 ! = SQRT(10**(-(ph_prev + phmax))) 751 ! = SQRT([H]_old*10**(-ph_max)) 752 ! = SQRT([H]_old * zh_min) 753 zh = SQRT(zh_prev * zh_min(ji,jj,jk)) 754 zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below 755 ENDIF 756 757 IF( zh > zh_max(ji,jj,jk) ) THEN 758 ! if [H]_new > [H]_max 759 ! i.e., if ph_new < ph_min, then 760 ! take one bisection step on [ph_min, ph_prev] 761 ! ph_new = (ph_prev + ph_min)/2d0 762 ! In terms of [H]_new: 763 ! [H]_new = 10**(-ph_new) 764 ! = 10**(-(ph_prev + ph_min)/2d0) 765 ! = SQRT(10**(-(ph_prev + ph_min))) 766 ! = SQRT([H]_old*10**(-ph_min)) 767 ! = SQRT([H]_old * zhmax) 768 zh = SQRT(zh_prev * zh_max(ji,jj,jk)) 769 zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below 770 ENDIF 771 ENDIF 772 773 zeqn_absmin(ji,jj,jk) = MIN( ABS(zeqn), zeqn_absmin(ji,jj,jk)) 774 775 ! Stop iterations once |\delta{[H]}/[H]| < rdel 776 ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel 777 ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)| 778 779 ! Alternatively: 780 ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))| 781 ! ~ 1/LOG(10) * |\Delta [H]|/[H] 782 ! < 1/LOG(10) * rdel 783 784 ! Hence |zeqn/(zdeqndh*zh)| < rdel 785 786 ! rdel <-- pp_rdel_ah_target 787 l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target) 788 789 IF(l_exitnow) THEN 790 rmask(ji,jj,jk) = 0. 791 ENDIF 792 793 zhi(ji,jj,jk) = zh 794 795 IF(jn >= jp_maxniter_atgen) THEN 796 zhi(ji,jj,jk) = -1._wp 797 ENDIF 798 799 ENDIF 800 END DO 801 END DO 802 END DO 803 END DO 804 ! 805 CALL wrk_dealloc( jpi, jpj, jpk, zalknw_inf, zalknw_sup, rmask ) 806 CALL wrk_dealloc( jpi, jpj, jpk, zh_min, zh_max, zeqn_absmin ) 807 808 809 IF( nn_timing == 1 ) CALL timing_stop('p4z_che_solve_hi') 810 811 812 END SUBROUTINE p4z_che_solve_hi 332 813 333 814 INTEGER FUNCTION p4z_che_alloc() … … 335 816 !! *** ROUTINE p4z_che_alloc *** 336 817 !!---------------------------------------------------------------------- 337 ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk), & 338 & tempis(jpi,jpj,jpk), STAT=p4z_che_alloc ) 818 INTEGER :: ierr(3) ! Local variables 819 !!---------------------------------------------------------------------- 820 821 ierr(:) = 0 822 823 ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk), STAT=ierr(1) ) 824 825 ALLOCATE( akb3(jpi,jpj,jpk) , tempis(jpi, jpj, jpk), & 826 & akw3(jpi,jpj,jpk) , borat (jpi,jpj,jpk) , & 827 & aks3(jpi,jpj,jpk) , akf3(jpi,jpj,jpk) , & 828 & ak1p3(jpi,jpj,jpk) , ak2p3(jpi,jpj,jpk) , & 829 & ak3p3(jpi,jpj,jpk) , aksi3(jpi,jpj,jpk) , & 830 & fluorid(jpi,jpj,jpk) , sulfat(jpi,jpj,jpk) , & 831 & salinprac(jpi,jpj,jpk), STAT=ierr(2) ) 832 833 ALLOCATE( fesol(jpi,jpj,jpk,5), STAT=ierr(3) ) 834 835 !* Variable for chemistry of the CO2 cycle 836 p4z_che_alloc = MAXVAL( ierr ) 339 837 ! 340 838 IF( p4z_che_alloc /= 0 ) CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') … … 354 852 355 853 !!====================================================================== 356 END MODULE p4zche854 END MODULE p4zche -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90
r7398 r7806 85 85 REAL(wp) :: zfld, zflu, zfld16, zflu16, zfact 86 86 REAL(wp) :: zvapsw, zsal, zfco2, zxc2, xCO2approx, ztkel, zfugcoeff 87 REAL(wp) :: zph, z ah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co287 REAL(wp) :: zph, zdic, zsch_o2, zsch_co2 88 88 REAL(wp) :: zyr_dec, zdco2dt 89 89 CHARACTER (len=25) :: charout … … 120 120 #endif 121 121 122 DO jm = 1, 10 123 !CDIR NOVERRCHK 124 DO jj = 1, jpj 125 !CDIR NOVERRCHK 126 DO ji = 1, jpi 127 128 ! DUMMY VARIABLES FOR DIC, H+, AND BORATE 129 zbot = borat(ji,jj,1) 130 zfact = rhop(ji,jj,1) / 1000. + rtrn 131 zdic = trb(ji,jj,1,jpdic) / zfact 132 zph = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 133 zalka = trb(ji,jj,1,jptal) / zfact 134 135 ! CALCULATE [ALK]([CO3--], [HCO3-]) 136 zalk = zalka - ( akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1) & 137 & + zbot / ( 1.+ zph / akb3(ji,jj,1) ) ) 138 139 ! CALCULATE [H+] AND [H2CO3] 140 zah2 = SQRT( (zdic-zalk)**2 + 4.* ( zalk * ak23(ji,jj,1) & 141 & / ak13(ji,jj,1) ) * ( 2.* zdic - zalk ) ) 142 zah2 = 0.5 * ak13(ji,jj,1) / zalk * ( ( zdic - zalk ) + zah2 ) 143 zh2co3(ji,jj) = ( 2.* zdic - zalk ) / ( 2.+ ak13(ji,jj,1) / zah2 ) * zfact 144 hi(ji,jj,1) = zah2 * zfact 145 END DO 122 DO jj = 1, jpj 123 DO ji = 1, jpi 124 ! DUMMY VARIABLES FOR DIC, H+, AND BORATE 125 zfact = rhop(ji,jj,1) / 1000. + rtrn 126 zdic = trb(ji,jj,1,jpdic) 127 zph = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 128 ! CALCULATE [H2CO3] 129 zh2co3(ji,jj) = zdic/(1. + ak13(ji,jj,1)/zph + ak13(ji,jj,1)*ak23(ji,jj,1)/zph**2) 146 130 END DO 147 131 END DO 148 149 132 150 133 ! -------------- … … 262 245 ENDIF 263 246 ! 247 #if defined key_cpl_carbon_cycle 248 ! change units for carbon cycle coupling 249 oce_co2(:,:) = oce_co2(:,:) / e1e2t(:,:) * rfact2r ! in molC/m2/s 250 #endif 251 ! 264 252 CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 265 253 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90
r7398 r7806 22 22 USE sms_pisces ! PISCES Source Minus Sink variables 23 23 USE prtctl_trc,ONLY : prt_ctl_trc_info,prt_ctl_trc ! print control for debugging 24 USE p4zche 24 25 25 26 IMPLICIT NONE … … 58 59 ! 59 60 INTEGER, INTENT(in) :: kt, knt ! ocean time step 60 INTEGER :: ji, jj, jk, jn 61 REAL(wp) :: zalk, zdic, zph, zah2 62 REAL(wp) :: zdispot, zfact, zcalcon, zalka, zaldi 61 INTEGER :: ji, jj, jk 62 REAL(wp) :: zdispot, zfact, zcalcon 63 63 REAL(wp) :: zomegaca, zexcess, zexcess0 64 64 CHARACTER (len=25) :: charout 65 REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss 65 REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss, zhinit, zhi 66 66 !!--------------------------------------------------------------------- 67 67 ! 68 68 IF( nn_timing == 1 ) CALL timing_start('p4z_lys') 69 69 ! 70 CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss )70 CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss, zhinit, zhi ) 71 71 ! 72 72 zco3 (:,:,:) = 0. 73 73 zcaldiss(:,:,:) = 0. 74 zhinit(:,:,:) = hi(:,:,:) * 1000. / ( rhop(:,:,:) + rtrn ) 74 75 ! ------------------------------------------- 75 76 ! COMPUTE [CO3--] and [H+] CONCENTRATIONS 76 77 ! ------------------------------------------- 77 78 DO jn = 1, 5 ! BEGIN OF ITERATION 79 ! 80 !CDIR NOVERRCHK 81 DO jk = 1, jpkm1 82 !CDIR NOVERRCHK 83 DO jj = 1, jpj 84 !CDIR NOVERRCHK 85 DO ji = 1, jpi 86 zfact = rhop(ji,jj,jk) / 1000. + rtrn 87 zph = hi(ji,jj,jk) * tmask(ji,jj,jk) / zfact + ( 1.-tmask(ji,jj,jk) ) * 1.e-9 ! [H+] 88 zdic = trb(ji,jj,jk,jpdic) / zfact 89 zalka = trb(ji,jj,jk,jptal) / zfact 90 ! CALCULATE [ALK]([CO3--], [HCO3-]) 91 zalk = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn ) & 92 & + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 93 ! CALCULATE [H+] and [CO3--] 94 zaldi = zdic - zalk 95 zah2 = SQRT( zaldi * zaldi + 4.* ( zalk * ak23(ji,jj,jk) / ak13(ji,jj,jk) ) * ( zdic + zaldi ) ) 96 zah2 = 0.5 * ak13(ji,jj,jk) / zalk * ( zaldi + zah2 ) 97 ! 98 zco3(ji,jj,jk) = zalk / ( 2. + zah2 / ak23(ji,jj,jk) ) * zfact 99 hi(ji,jj,jk) = zah2 * zfact 100 END DO 78 79 CALL p4z_che_solve_hi( zhinit, zhi ) 80 81 DO jk = 1, jpkm1 82 DO jj = 1, jpj 83 DO ji = 1, jpi 84 zco3(ji,jj,jk) = trb(ji,jj,jk,jpdic) * ak13(ji,jj,jk) * ak23(ji,jj,jk) / (zhi(ji,jj,jk)**2 & 85 & + ak13(ji,jj,jk) * zhi(ji,jj,jk) + ak13(ji,jj,jk) * ak23(ji,jj,jk) + rtrn ) 86 hi(ji,jj,jk) = zhi(ji,jj,jk) * rhop(ji,jj,jk) / 1000. 101 87 END DO 102 88 END DO 103 ! 104 END DO 89 END DO 105 90 106 91 ! --------------------------------------------------------- … … 136 121 ! AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION 137 122 zcaldiss(ji,jj,jk) = zdispot * rfact2 / rmtss ! calcite dissolution 138 zco3(ji,jj,jk) = zco3(ji,jj,jk) + zcaldiss(ji,jj,jk)139 123 ! 140 124 tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2. * zcaldiss(ji,jj,jk) … … 165 149 ENDIF 166 150 ! 167 CALL wrk_dealloc( jpi, jpj, jpk, zco3, zc o3sat, zcaldiss)151 CALL wrk_dealloc( jpi, jpj, jpk, zco3, zcaldiss, zhinit, zhi, zco3sat ) 168 152 ! 169 153 IF( nn_timing == 1 ) CALL timing_stop('p4z_lys') … … 184 168 !! 185 169 !!---------------------------------------------------------------------- 186 INTEGER :: ji, jj, jk187 170 INTEGER :: ios ! Local integer output status for namelist read 188 REAL(wp) :: zcaralk, zbicarb, zco3189 REAL(wp) :: ztmas, ztmas1190 191 171 NAMELIST/nampiscal/ kdca, nca 192 172 !!---------------------------------------------------------------------- -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90
r7398 r7806 269 269 ENDIF 270 270 271 ! set the number of level over which river runoffs are applied272 ! online configuration : computed in sbcrnf273 IF( lk_offline ) THEN274 nk_rnf(:,:) = 1275 h_rnf (:,:) = e3t_0(:,:,1)276 ENDIF277 271 278 272 ! dust input from the atmosphere -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90
r7398 r7806 83 83 CALL p4z_che ! initialize the chemical constants 84 84 ! 85 IF( .NOT. ln_rsttr ) THEN ; CALL p4z_ ph_ini ! set PH at kt=nit00085 IF( .NOT. ln_rsttr ) THEN ; CALL p4z_che_ahini( hi ) ! set PH at kt=nit000 86 86 ELSE ; CALL p4z_rst( nittrc000, 'READ' ) !* read or initialize all required fields 87 87 ENDIF … … 308 308 END SUBROUTINE p4z_sms_init 309 309 310 SUBROUTINE p4z_ph_ini311 !!---------------------------------------------------------------------312 !! *** ROUTINE p4z_ini_ph ***313 !!314 !! ** Purpose : Initialization of chemical variables of the carbon cycle315 !!---------------------------------------------------------------------316 INTEGER :: ji, jj, jk317 REAL(wp) :: zcaralk, zbicarb, zco3318 REAL(wp) :: ztmas, ztmas1319 !!---------------------------------------------------------------------320 321 ! Set PH from total alkalinity, borat (???), akb3 (???) and ak23 (???)322 ! --------------------------------------------------------323 DO jk = 1, jpk324 DO jj = 1, jpj325 DO ji = 1, jpi326 ztmas = tmask(ji,jj,jk)327 ztmas1 = 1. - tmask(ji,jj,jk)328 zcaralk = trb(ji,jj,jk,jptal) - borat(ji,jj,jk) / ( 1. + 1.E-8 / ( rtrn + akb3(ji,jj,jk) ) )329 zco3 = ( zcaralk - trb(ji,jj,jk,jpdic) ) * ztmas + 0.5e-3 * ztmas1330 zbicarb = ( 2. * trb(ji,jj,jk,jpdic) - zcaralk )331 hi(ji,jj,jk) = ( ak23(ji,jj,jk) * zbicarb / zco3 ) * ztmas + 1.e-9 * ztmas1332 END DO333 END DO334 END DO335 !336 END SUBROUTINE p4z_ph_ini337 338 310 SUBROUTINE p4z_rst( kt, cdrw ) 339 311 !!--------------------------------------------------------------------- … … 348 320 INTEGER , INTENT(in) :: kt ! ocean time-step 349 321 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 350 !351 INTEGER :: ji, jj, jk352 REAL(wp) :: zcaralk, zbicarb, zco3353 REAL(wp) :: ztmas, ztmas1354 322 !!--------------------------------------------------------------------- 355 323 … … 363 331 CALL iom_get( numrtr, jpdom_autoglo, 'PH' , hi(:,:,:) ) 364 332 ELSE 365 ! hi(:,:,:) = 1.e-9 366 CALL p4z_ph_ini 333 CALL p4z_che_ahini( hi ) 367 334 ENDIF 368 335 CALL iom_get( numrtr, jpdom_autoglo, 'Silicalim', xksi(:,:) ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90
r7256 r7806 93 93 94 94 !!* Variable for chemistry of the CO2 cycle 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akb3 !: ???96 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak13 !: ??? 97 96 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ak23 !: ??? 98 97 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aksp !: ??? 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akw3 !: ???100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: borat !: ???101 98 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hi !: ??? 102 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: excess !: ??? … … 153 150 154 151 !* Variable for chemistry of the CO2 cycle 155 ALLOCATE( ak b3(jpi,jpj,jpk) , ak13 (jpi,jpj,jpk) ,&152 ALLOCATE( ak13 (jpi,jpj,jpk) , & 156 153 & ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , & 157 & akw3(jpi,jpj,jpk) , borat (jpi,jpj,jpk) , &158 154 & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , & 159 155 & aphscale(jpi,jpj,jpk), STAT=ierr(4) ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90
r5602 r7806 89 89 r2dt(:) = 2. * rdttrc(:) ! = 2 rdttrc (leapfrog) 90 90 ENDIF 91 ! ! effective transport 92 DO jk = 1, jpkm1 93 ! ! eulerian transport only 94 zun(:,:,jk) = e2u (:,:) * fse3u(:,:,jk) * un(:,:,jk) 95 zvn(:,:,jk) = e1v (:,:) * fse3v(:,:,jk) * vn(:,:,jk) 96 zwn(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) 97 ! 98 END DO 99 ! 100 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 101 zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 102 zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 91 ! 92 IF( lk_offline ) THEN 93 zun(:,:,:) = un(:,:,:) ! effective transport already in un/vn/wn 94 zvn(:,:,:) = vn(:,:,:) 95 zwn(:,:,:) = wn(:,:,:) 96 ELSE 97 ! ! effective transport 98 DO jk = 1, jpkm1 99 ! ! eulerian transport only 100 zun(:,:,jk) = e2u (:,:) * fse3u(:,:,jk) * un(:,:,jk) 101 zvn(:,:,jk) = e1v (:,:) * fse3v(:,:,jk) * vn(:,:,jk) 102 zwn(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) 103 ! 104 END DO 105 ! 106 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 107 zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 108 zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 109 ENDIF 110 ! 111 zun(:,:,jpk) = 0._wp ! no transport trough the bottom 112 zvn(:,:,jpk) = 0._wp ! no transport trough the bottom 113 zwn(:,:,jpk) = 0._wp ! no transport trough the bottom 114 ! 115 116 IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif ) & ! add the eiv transport (if necessary) 117 & CALL tra_adv_eiv( kt, nittrc000, zun, zvn, zwn, 'TRC' ) 118 ! 119 IF( ln_mle ) CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the mle transport (if necessary) 120 ! 103 121 ENDIF 104 !105 zun(:,:,jpk) = 0._wp ! no transport trough the bottom106 zvn(:,:,jpk) = 0._wp ! no transport trough the bottom107 zwn(:,:,jpk) = 0._wp ! no transport trough the bottom108 109 IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif ) & ! add the eiv transport (if necessary)110 & CALL tra_adv_eiv( kt, nittrc000, zun, zvn, zwn, 'TRC' )111 !112 IF( ln_mle ) CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the mle transport (if necessary)113 122 ! 114 123 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcrad.F90
r7398 r7806 28 28 !!---------------------------------------------------------------------- 29 29 !! NEMO/TOP 3.3 , NEMO Consortium (2010) 30 !! $Id$ 30 !! $Id$ 31 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 32 32 !!---------------------------------------------------------------------- … … 61 61 ENDIF 62 62 63 IF( lk_age ) CALL trc_rad_sms( kt, trb, trn, jp_age0 , jp_age1 ) ! AGE tracer 63 64 IF( lk_cfc ) CALL trc_rad_sms( kt, trb, trn, jp_cfc0 , jp_cfc1 ) ! CFC model 64 65 IF( lk_c14b ) CALL trc_rad_sms( kt, trb, trn, jp_c14b0, jp_c14b1 ) ! bomb C14 65 66 IF( lk_pisces ) CALL trc_rad_sms( kt, trb, trn, jp_pcs0 , jp_pcs1, cpreserv='Y' ) ! PISCES model 66 IF( lk_my_trc ) CALL trc_rad_sms( kt, trb, trn, jp_myt0 , jp_myt1 67 IF( lk_my_trc ) CALL trc_rad_sms( kt, trb, trn, jp_myt0 , jp_myt1, cpreserv='Y' ) ! MY_TRC model 67 68 68 69 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r7256 r7806 129 129 ! Coupling offline : runoff are in emp which contains E-P-R 130 130 ! 131 IF( .NOT. lk_offline .AND. lk_vvl ) THEN ! online coupling withvvl131 IF( lk_vvl ) THEN ! linear free surface vvl 132 132 zsfx(:,:) = 0._wp 133 ELSE ! online coupling free surface or offline with free surface133 ELSE ! no vvl 134 134 zsfx(:,:) = emp(:,:) 135 135 ENDIF -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r7805 r7806 30 30 USE par_pisces , ONLY : lk_pisces, jp_pcs0 , jp_pcs1 31 31 USE par_my_trc , ONLY : lk_my_trc, jp_myt0 , jp_myt1 32 USE par_age , ONLY : lk_age , jp_age0 , jp_age1 32 33 33 34 USE trc_oce , ONLY : lk_degrad, lk_offline, facvol, r_si2, trc_oce_ext_lev 34 35 USE trc_oce , ONLY : nn_dttrc 35 36 USE trc_oce , ONLY : etot3 36 USE trc , ONLY : nittrc000 37 USE trc , ONLY : nittrc000,nn_rsttr 37 38 USE trc , ONLY : trb,trn,tra 38 39 USE trc , ONLY : trc2d,trc3d -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/par_trc.F90
r4529 r7806 14 14 USE par_c14b ! C14 bomb tracer 15 15 USE par_cfc ! CFC 11 and 12 tracers 16 USE par_age ! AGE tracer 16 17 USE par_my_trc ! user defined passive tracers 17 18 … … 24 25 ! Passive tracers : Total size 25 26 ! --------------- ! total number of passive tracers, of 2d and 3d output and trend arrays 26 INTEGER, PUBLIC, PARAMETER :: jptra = jp_pisces + jp_cfc + jp_c14b + jp_ my_trc27 INTEGER, PUBLIC, PARAMETER :: jpdia2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d + jp_ my_trc_2d28 INTEGER, PUBLIC, PARAMETER :: jpdia3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d + jp_ my_trc_3d27 INTEGER, PUBLIC, PARAMETER :: jptra = jp_pisces + jp_cfc + jp_c14b + jp_age + jp_my_trc 28 INTEGER, PUBLIC, PARAMETER :: jpdia2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d + jp_age_2d + jp_my_trc_2d 29 INTEGER, PUBLIC, PARAMETER :: jpdia3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d + jp_age_3d + jp_my_trc_3d 29 30 ! ! total number of sms diagnostic arrays 30 INTEGER, PUBLIC, PARAMETER :: jpdiabio = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_ my_trc_trd31 INTEGER, PUBLIC, PARAMETER :: jpdiabio = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_age_trd + jp_my_trc_trd 31 32 32 33 ! 1D configuration ("key_c1d") … … 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/TOP 3.3 , NEMO Consortium (2010) 44 !! $Id$ 45 !! $Id$ 45 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 47 !!====================================================================== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r7398 r7806 23 23 USE trcini_pisces ! PISCES initialisation 24 24 USE trcini_c14b ! C14 bomb initialisation 25 USE trcini_age ! AGE initialisation 25 26 USE trcini_my_trc ! MY_TRC initialisation 26 27 USE trcdta ! initialisation from files … … 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/TOP 4.0 , NEMO Consortium (2011) 45 !! $Id$ 46 !! $Id$ 46 47 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 48 !!---------------------------------------------------------------------- … … 98 99 99 100 IF( lk_pisces ) CALL trc_ini_pisces ! PISCES bio-model 100 IF( lk_cfc ) CALL trc_ini_cfc ! CFC tracers101 IF( lk_cfc ) CALL trc_ini_cfc ! CFC tracers 101 102 IF( lk_c14b ) CALL trc_ini_c14b ! C14 bomb tracer 102 IF( lk_my_trc ) CALL trc_ini_my_trc ! MY_TRC tracers 103 IF( lk_age ) CALL trc_ini_age ! AGE tracer 104 IF( lk_my_trc ) CALL trc_ini_my_trc ! MY_TRC tracers 103 105 104 106 CALL trc_ice_ini ! Tracers in sea ice -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcnam.F90
r7256 r7806 24 24 USE trcnam_cfc ! CFC SMS namelist 25 25 USE trcnam_c14b ! C14 SMS namelist 26 USE trcnam_age ! AGE SMS namelist 26 27 USE trcnam_my_trc ! MY_TRC SMS namelist 27 28 USE trd_oce … … 61 62 62 63 ! ! passive tracer informations 63 CALL trc_nam_trc64 CALL trc_nam_trc 64 65 65 66 ! ! Parameters of additional diagnostics 66 CALL trc_nam_dia67 IF( .NOT. lk_iomput) CALL trc_nam_dia 67 68 68 69 ! ! namelist of transport 69 CALL trc_nam_trp70 CALL trc_nam_trp 70 71 71 72 … … 161 162 ENDIF 162 163 163 IF( lk_c14b ) THEN ; CALL trc_nam_c14b ! C14 bomb tracers 164 ELSE ; IF(lwp) WRITE(numout,*) ' C14 not used' 165 ENDIF 166 167 IF( lk_my_trc ) THEN ; CALL trc_nam_my_trc ! MY_TRC tracers 168 ELSE ; IF(lwp) WRITE(numout,*) ' MY_TRC not used' 164 IF( lk_c14b ) THEN ; CALL trc_nam_c14b ! C14 bomb tracers 165 ELSE ; IF(lwp) WRITE(numout,*) ' C14 not used' 166 ENDIF 167 168 IF( lk_age ) THEN ; CALL trc_nam_age ! AGE tracer 169 ELSE ; IF(lwp) WRITE(numout,*) ' AGE not used' 170 ENDIF 171 172 IF( lk_my_trc ) THEN ; CALL trc_nam_my_trc ! MY_TRC tracers 173 ELSE ; IF(lwp) WRITE(numout,*) ' MY_TRC not used' 169 174 ENDIF 170 175 ! … … 359 364 ENDIF 360 365 361 IF( ln_diatrc .AND. .NOT. lk_iomput) THEN366 IF( ln_diatrc ) THEN 362 367 ALLOCATE( trc2d(jpi,jpj,jpdia2d), trc3d(jpi,jpj,jpk,jpdia3d), & 363 368 & ctrc2d(jpdia2d), ctrc2l(jpdia2d), ctrc2u(jpdia2d) , & … … 370 375 ENDIF 371 376 372 IF( ( ln_diabio .AND. .NOT. lk_iomput ).OR. l_trdtrc ) THEN377 IF( ln_diabio .OR. l_trdtrc ) THEN 373 378 ALLOCATE( trbio (jpi,jpj,jpk,jpdiabio) , & 374 379 & ctrbio(jpdiabio), ctrbil(jpdiabio), ctrbiu(jpdiabio), STAT = ierr ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsms.F90
r7256 r7806 18 18 USE trcsms_cfc ! CFC 11 & 12 19 19 USE trcsms_c14b ! C14b tracer 20 USE trcsms_age ! AGE tracer 20 21 USE trcsms_my_trc ! MY_TRC tracers 21 22 USE prtctl_trc ! Print control for debbuging … … 28 29 !!---------------------------------------------------------------------- 29 30 !! NEMO/TOP 3.3 , NEMO Consortium (2010) 30 !! $Id$ 31 !! $Id$ 31 32 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 32 33 !!---------------------------------------------------------------------- … … 51 52 IF( lk_cfc ) CALL trc_sms_cfc ( kt ) ! surface fluxes of CFC 52 53 IF( lk_c14b ) CALL trc_sms_c14b ( kt ) ! surface fluxes of C14 54 IF( lk_age ) CALL trc_sms_age ( kt ) ! AGE tracer 53 55 IF( lk_my_trc ) CALL trc_sms_my_trc ( kt ) ! MY_TRC tracers 54 56 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r7398 r7806 32 32 REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step 33 33 REAL(wp) :: rdt_sampl 34 INTEGER :: nb_rec_per_day 34 INTEGER :: nb_rec_per_day, ktdcy 35 35 REAL(wp) :: rsecfst, rseclast 36 36 LOGICAL :: llnew … … 86 86 tra(:,:,:,:) = 0.e0 87 87 ! 88 88 IF( .NOT.lk_offline ) CALL trc_rst_opn ( kt ) ! Open tracer restart file 89 89 IF( lrst_trc ) CALL trc_rst_cal ( kt, 'WRITE' ) ! calendar 90 90 IF( lk_iomput ) THEN ; CALL trc_wri ( kt ) ! output of passive tracers with iom I/O manager … … 131 131 INTEGER, INTENT(in) :: kt 132 132 INTEGER :: jn 133 REAL(wp) :: zkt 133 REAL(wp) :: zkt, zrec 134 134 CHARACTER(len=1) :: cl1 ! 1 character 135 135 CHARACTER(len=2) :: cl2 ! 2 characters … … 153 153 ! 154 154 ! !* Restart: read in restart file 155 IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 .AND. & 156 iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 .AND. & 157 iom_varid( numrtr, 'ktdcy' , ldstop = .FALSE. ) > 0 ) THEN 158 CALL iom_get( numrtr, 'ktdcy', zkt ) ! A mean of qsr 155 IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 & 156 & .AND. iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 & 157 & .AND. iom_varid( numrtr, 'ktdcy' , ldstop = .FALSE. ) > 0 & 158 & .AND. iom_varid( numrtr, 'nrdcy' , ldstop = .FALSE. ) > 0 ) THEN 159 160 CALL iom_get( numrtr, 'ktdcy', zkt ) 159 161 rsecfst = INT( zkt ) * rdttrc(1) 160 162 IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' 161 163 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean ) ! A mean of qsr 162 DO jn = 1, nb_rec_per_day 163 IF( jn <= 9 ) THEN 164 WRITE(cl1,'(i1)') jn 165 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr 166 ELSE 167 WRITE(cl2,'(i2.2)') jn 168 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr 169 ENDIF 170 ENDDO 164 CALL iom_get( numrtr, 'nrdcy', zrec ) ! Number of record per days 165 IF( INT( zrec ) == nb_rec_per_day ) THEN 166 DO jn = 1, nb_rec_per_day 167 IF( jn <= 9 ) THEN 168 WRITE(cl1,'(i1)') jn 169 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) ! A mean of qsr 170 ELSE 171 WRITE(cl2,'(i2.2)') jn 172 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) ! A mean of qsr 173 ENDIF 174 ENDDO 175 ELSE 176 DO jn = 1, nb_rec_per_day 177 qsr_arr(:,:,jn) = qsr_mean(:,:) 178 ENDDO 179 ENDIF 171 180 ELSE !* no restart: set from nit000 values 172 181 IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values' … … 185 194 llnew = ( rseclast - rsecfst ) .ge. rdt_sampl ! new shortwave to store 186 195 IF( llnew ) THEN 187 IF( lwp ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', kt, & 196 ktdcy = kt 197 IF( lwp .AND. kt < nittrc000 + 100 ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', ktdcy, & 188 198 & ' time = ', rseclast/3600.,'hours ' 189 199 rsecfst = rseclast … … 199 209 IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file kt =', kt 200 210 IF(lwp) WRITE(numout,*) '~~~~~~~' 201 zkt = REAL( kt, wp ) 202 CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) 211 zkt = REAL( ktdcy, wp ) 212 zrec = REAL( nb_rec_per_day, wp ) 213 CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) 214 CALL iom_rstput( kt, nitrst, numrtw, 'nrdcy', zrec ) 203 215 DO jn = 1, nb_rec_per_day 204 216 IF( jn <= 9 ) THEN -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcwri.F90
r6101 r7806 20 20 USE trcwri_cfc 21 21 USE trcwri_c14b 22 USE trcwri_age 22 23 USE trcwri_my_trc 23 24 … … 59 60 IF( lk_cfc ) CALL trc_wri_cfc ! surface fluxes of CFC 60 61 IF( lk_c14b ) CALL trc_wri_c14b ! surface fluxes of C14 62 IF( lk_age ) CALL trc_wri_age ! AGE tracer 61 63 IF( lk_my_trc ) CALL trc_wri_my_trc ! MY_TRC tracers 62 64 ! … … 78 80 !!---------------------------------------------------------------------- 79 81 !! NEMO/TOP 3.3 , NEMO Consortium (2010) 80 !! $Id$ 82 !! $Id$ 81 83 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 82 84 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.