- Timestamp:
- 2020-04-07T18:34:56+02:00 (4 years ago)
- Location:
- NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE
- Files:
-
- 1 deleted
- 27 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/BDY/bdyini.F90
r12143 r12706 398 398 jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) 399 399 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) 400 400 nbrdta(:,:,:) = 0 ! initialize nbrdta as it may not be completely defined for each bdy 401 401 402 ! Calculate global boundary index arrays or read in from file 402 403 !------------------------------------------------------------ -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/BDY/bdyvol.F90
r12143 r12706 143 143 ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 144 144 ! ------------------------------------------------------ 145 IF( MOD( kt, nn_write) == 0 .AND. ( kc == 1 ) ) THEN145 IF( MOD( kt, MAX(nn_write,1) ) == 0 .AND. ( kc == 1 ) ) THEN 146 146 ! 147 147 ! compute residual transport across boundary -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diaar5.F90
r10425 r12706 71 71 INTEGER, INTENT( in ) :: kt ! ocean time-step index 72 72 ! 73 INTEGER :: ji, jj, jk ! dummy loop arguments74 REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass 73 INTEGER :: ji, jj, jk, iks, ikb ! dummy loop arguments 74 REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst 75 75 REAL(wp) :: zaw, zbw, zrw 76 76 ! 77 77 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace 78 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpe 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zrhd , zrhop 78 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpe, z2d ! 2D workspace 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zrhd , zrhop, ztpot ! 3D workspace 80 80 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace 81 81 … … 86 86 87 87 IF( l_ar5 ) THEN 88 ALLOCATE( zarea_ssh(jpi,jpj) , zbotpres(jpi,jpj) )88 ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) ) 89 89 ALLOCATE( zrhd(jpi,jpj,jpk) , zrhop(jpi,jpj,jpk) ) 90 90 ALLOCATE( ztsn(jpi,jpj,jpk,jpts) ) … … 92 92 ENDIF 93 93 ! 94 CALL iom_put( 'e2u' , e2u (:,:) ) 95 CALL iom_put( 'e1v' , e1v (:,:) ) 96 CALL iom_put( 'areacello', area(:,:) ) 97 ! 98 IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN 99 zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace 100 DO jk = 1, jpkm1 101 zrhd(:,:,jk) = area(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) 102 END DO 103 CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 104 CALL iom_put( 'masscello' , rau0 * e3t_n(:,:,:) * tmask(:,:,:) ) ! ocean mass 105 ENDIF 106 ! 107 IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness 108 DO jj = 1, jpj 109 DO ji = 1, jpi 110 ikb = mbkt(ji,jj) 111 z2d(ji,jj) = e3t_n(ji,jj,ikb) 112 END DO 113 END DO 114 CALL iom_put( 'e3tb', z2d ) 115 ENDIF 116 ! 94 117 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN 95 118 ! ! total volume of liquid seawater 96 zvolssh = SUM( zarea_ssh(:,:) ) 97 CALL mpp_sum( 'diaar5', zvolssh ) 98 zvol = vol0 + zvolssh 119 zvolssh = glob_sum( 'diaar5', zarea_ssh(:,:) ) 120 zvol = vol0 + zvolssh 99 121 100 122 CALL iom_put( 'voltot', zvol ) … … 118 140 DO ji = 1, jpi 119 141 DO jj = 1, jpj 120 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 142 iks = mikt(ji,jj) 143 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,iks) + riceload(ji,jj) 121 144 END DO 122 145 END DO … … 129 152 END IF 130 153 ! 131 zarho = SUM( area(:,:) * zbotpres(:,:) ) 132 CALL mpp_sum( 'diaar5', zarho ) 154 zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) ) 133 155 zssh_steric = - zarho / area_tot 134 156 CALL iom_put( 'sshthster', zssh_steric ) … … 147 169 DO ji = 1,jpi 148 170 DO jj = 1,jpj 149 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 171 iks = mikt(ji,jj) 172 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,iks) + riceload(ji,jj) 150 173 END DO 151 174 END DO … … 155 178 END IF 156 179 ! 157 zarho = SUM( area(:,:) * zbotpres(:,:) ) 158 CALL mpp_sum( 'diaar5', zarho ) 180 zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) ) 159 181 zssh_steric = - zarho / area_tot 160 182 CALL iom_put( 'sshsteric', zssh_steric ) 161 162 183 ! ! ocean bottom pressure 163 184 zztmp = rau0 * grav * 1.e-4_wp ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa … … 168 189 169 190 IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN 170 ! ! Mean density anomalie, temperature and salinity171 ztemp = 0._wp172 zsal = 0._wp173 DO jk = 1, jpkm1174 DO jj = 1, jpj175 DO ji = 1, jpi176 zztmp = area(ji,jj) * e3t_n(ji,jj,jk)177 ztemp = ztemp + zztmp * tsn(ji,jj,jk,jp_tem)178 zsal = zsal + zztmp * tsn(ji,jj,jk,jp_sal)179 ENDDO180 ENDDO181 END DO 182 IF( ln_linssh ) THEN191 ! ! Mean density anomalie, temperature and salinity 192 ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity 193 DO jk = 1, jpkm1 194 DO jj = 1, jpj 195 DO ji = 1, jpi 196 zztmp = area(ji,jj) * e3t_n(ji,jj,jk) 197 ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * tsn(ji,jj,jk,jp_tem) 198 ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * tsn(ji,jj,jk,jp_sal) 199 ENDDO 200 ENDDO 201 ENDDO 202 203 IF( ln_linssh ) THEN 183 204 IF( ln_isfcav ) THEN 184 205 DO ji = 1, jpi 185 206 DO jj = 1, jpj 186 ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 187 zsal = zsal + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 207 iks = mikt(ji,jj) 208 ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * tsn(ji,jj,iks,jp_tem) 209 ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * tsn(ji,jj,iks,jp_sal) 188 210 END DO 189 211 END DO 190 212 ELSE 191 zt emp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) )192 z sal = zsal + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) )213 ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * tsn(:,:,1,jp_tem) 214 ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * tsn(:,:,1,jp_sal) 193 215 END IF 194 216 ENDIF 195 IF( lk_mpp ) THEN 196 CALL mpp_sum( 'diaar5', ztemp ) 197 CALL mpp_sum( 'diaar5', zsal ) 198 END IF 199 ! 200 zmass = rau0 * ( zarho + zvol ) ! total mass of liquid seawater 201 ztemp = ztemp / zvol ! potential temperature in liquid seawater 202 zsal = zsal / zvol ! Salinity of liquid seawater 217 ! 218 ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem) ) 219 zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal) ) 220 zmass = rau0 * ( zarho + zvol ) 203 221 ! 204 222 CALL iom_put( 'masstot', zmass ) 205 CALL iom_put( 'temptot', ztemp ) 206 CALL iom_put( 'saltot' , zsal ) 207 ! 223 CALL iom_put( 'temptot', ztemp / zvol ) 224 CALL iom_put( 'saltot' , zsal / zvol ) 225 ! 226 ENDIF 227 228 IF( ln_teos10 ) THEN ! ! potential temperature (TEOS-10 case) 229 IF( iom_use( 'toce_pot') .OR. iom_use( 'temptot_pot' ) .OR. iom_use( 'sst_pot' ) & 230 .OR. iom_use( 'ssttot' ) .OR. iom_use( 'tosmint_pot' ) ) THEN 231 ! 232 ALLOCATE( ztpot(jpi,jpj,jpk) ) 233 ztpot(:,:,jpk) = 0._wp 234 DO jk = 1, jpkm1 235 ztpot(:,:,jk) = eos_pt_from_ct( tsn(:,:,jk,jp_tem), tsn(:,:,jk,jp_sal) ) 236 END DO 237 ! 238 CALL iom_put( 'toce_pot', ztpot(:,:,:) ) ! potential temperature (TEOS-10 case) 239 CALL iom_put( 'sst_pot' , ztpot(:,:,1) ) ! surface temperature 240 ! 241 IF( iom_use( 'temptot_pot' ) ) THEN ! Output potential temperature in case we use TEOS-10 242 z2d(:,:) = 0._wp 243 DO jk = 1, jpkm1 244 z2d(:,:) = z2d(:,:) + area(:,:) * e3t_n(:,:,jk) * ztpot(:,:,jk) 245 END DO 246 ztemp = glob_sum( 'diaar5', z2d(:,:) ) 247 CALL iom_put( 'temptot_pot', ztemp / zvol ) 248 ENDIF 249 ! 250 IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10 251 zsst = glob_sum( 'diaar5', area(:,:) * ztpot(:,:,1) ) 252 CALL iom_put( 'ssttot', zsst / area_tot ) 253 ENDIF 254 ! Vertical integral of temperature 255 IF( iom_use( 'tosmint_pot') ) THEN 256 z2d(:,:) = 0._wp 257 DO jk = 1, jpkm1 258 DO jj = 1, jpj 259 DO ji = 1, jpi ! vector opt. 260 z2d(ji,jj) = z2d(ji,jj) + rau0 * e3t_n(ji,jj,jk) * ztpot(ji,jj,jk) 261 END DO 262 END DO 263 END DO 264 CALL iom_put( 'tosmint_pot', z2d ) 265 ENDIF 266 DEALLOCATE( ztpot ) 267 ENDIF 268 ELSE 269 IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80 270 zsst = glob_sum( 'diaar5', area(:,:) * tsn(:,:,1,jp_tem) ) 271 CALL iom_put('ssttot', zsst / area_tot ) 272 ENDIF 208 273 ENDIF 209 274 210 275 IF( iom_use( 'tnpeo' )) THEN 211 ! Work done against stratification by vertical mixing212 ! Exclude points where rn2 is negative as convection kicks in here and213 ! work is not being done against stratification276 ! Work done against stratification by vertical mixing 277 ! Exclude points where rn2 is negative as convection kicks in here and 278 ! work is not being done against stratification 214 279 ALLOCATE( zpe(jpi,jpj) ) 215 280 zpe(:,:) = 0._wp … … 219 284 DO ji = 1, jpi 220 285 IF( rn2(ji,jj,jk) > 0._wp ) THEN 221 zrw = ( gdepw_n(ji,jj,jk ) - gdept_n(ji,jj,jk) ) & 222 & / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) ) 223 !!gm this can be reduced to : (depw-dept) / e3w (NB idem dans bn2 !) 224 ! zrw = ( gdept_n(ji,jj,jk) - gdepw_n(ji,jj,jk) ) / e3w_n(ji,jj,jk) 225 !!gm end 286 zrw = ( gdept_n(ji,jj,jk) - gdepw_n(ji,jj,jk) ) / e3w_n(ji,jj,jk) 226 287 ! 227 288 zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw 228 289 zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw 229 290 ! 230 zpe(ji, jj) = zpe(ji, jj)&291 zpe(ji, jj) = zpe(ji,jj) & 231 292 & - grav * ( avt(ji,jj,jk) * zaw * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) & 232 293 & - avs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) ) … … 239 300 DO ji = 1, jpi 240 301 DO jj = 1, jpj 241 zpe(ji,jj) = zpe(ji,jj) + avt(ji, jj, jk) * MIN(0._wp,rn2(ji, jj, jk)) * rau0 * e3w_n(ji, jj,jk)302 zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rau0 * e3w_n(ji,jj,jk) 242 303 END DO 243 304 END DO 244 305 END DO 245 306 ENDIF 246 !!gm useless lbc_lnk since the computation above is performed over 1:jpi & 1:jpj247 !!gm CALL lbc_lnk( 'diaar5', zpe, 'T', 1._wp)248 307 CALL iom_put( 'tnpeo', zpe ) 249 308 DEALLOCATE( zpe ) … … 251 310 252 311 IF( l_ar5 ) THEN 253 DEALLOCATE( zarea_ssh , zbotpres )312 DEALLOCATE( zarea_ssh , zbotpres, z2d ) 254 313 DEALLOCATE( zrhd , zrhop ) 255 314 DEALLOCATE( ztsn ) … … 287 346 CALL lbc_lnk( 'diaar5', z2d, 'U', -1. ) 288 347 IF( cptr == 'adv' ) THEN 289 IF( ktra == jp_tem ) CALL iom_put( "uadv_heattr", rau0_rcp * z2d ) ! advective heat transport in i-direction290 IF( ktra == jp_sal ) CALL iom_put( "uadv_salttr", rau0 * z2d ) ! advective salt transport in i-direction348 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rau0_rcp * z2d ) ! advective heat transport in i-direction 349 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rau0 * z2d ) ! advective salt transport in i-direction 291 350 ENDIF 292 351 IF( cptr == 'ldf' ) THEN 293 IF( ktra == jp_tem ) CALL iom_put( "udiff_heattr", rau0_rcp * z2d ) ! diffusive heat transport in i-direction294 IF( ktra == jp_sal ) CALL iom_put( "udiff_salttr", rau0 * z2d ) ! diffusive salt transport in i-direction352 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rau0_rcp * z2d ) ! diffusive heat transport in i-direction 353 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rau0 * z2d ) ! diffusive salt transport in i-direction 295 354 ENDIF 296 355 ! … … 305 364 CALL lbc_lnk( 'diaar5', z2d, 'V', -1. ) 306 365 IF( cptr == 'adv' ) THEN 307 IF( ktra == jp_tem ) CALL iom_put( "vadv_heattr", rau0_rcp * z2d ) ! advective heat transport in j-direction308 IF( ktra == jp_sal ) CALL iom_put( "vadv_salttr", rau0 * z2d ) ! advective salt transport in j-direction366 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rau0_rcp * z2d ) ! advective heat transport in j-direction 367 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rau0 * z2d ) ! advective salt transport in j-direction 309 368 ENDIF 310 369 IF( cptr == 'ldf' ) THEN 311 IF( ktra == jp_tem ) CALL iom_put( "vdiff_heattr", rau0_rcp * z2d ) ! diffusive heat transport in j-direction312 IF( ktra == jp_sal ) CALL iom_put( "vdiff_salttr", rau0 * z2d ) ! diffusive salt transport in j-direction370 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rau0_rcp * z2d ) ! diffusive heat transport in j-direction 371 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rau0 * z2d ) ! diffusive salt transport in j-direction 313 372 ENDIF 314 373 … … 323 382 !!---------------------------------------------------------------------- 324 383 INTEGER :: inum 325 INTEGER :: ik 384 INTEGER :: ik, idep 326 385 INTEGER :: ji, jj, jk ! dummy loop indices 327 386 REAL(wp) :: zztmp 328 387 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 388 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 329 389 ! 330 390 !!---------------------------------------------------------------------- … … 340 400 IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 341 401 342 area(:,:) = e1e2t(:,:) * tmask_i(:,:)343 344 area_tot = SUM( area(:,:) ) ; CALL mpp_sum( 'diaar5', area_tot ) 345 346 vol0= 0._wp402 area(:,:) = e1e2t(:,:) 403 area_tot = glob_sum( 'diaar5', area(:,:) ) 404 405 ALLOCATE( zvol0(jpi,jpj) ) 406 zvol0 (:,:) = 0._wp 347 407 thick0(:,:) = 0._wp 348 408 DO jk = 1, jpkm1 349 vol0 = vol0 + SUM( area (:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) ) 350 thick0(:,:) = thick0(:,:) + tmask_i(:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) 351 END DO 352 CALL mpp_sum( 'diaar5', vol0 ) 409 DO jj = 1, jpj ! interpolation of salinity at the last ocean level (i.e. the partial step) 410 DO ji = 1, jpi 411 idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 412 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * area(ji,jj) 413 thick0(ji,jj) = thick0(ji,jj) + idep 414 END DO 415 END DO 416 END DO 417 vol0 = glob_sum( 'diaar5', zvol0 ) 418 DEALLOCATE( zvol0 ) 353 419 354 420 IF( iom_use( 'sshthster' ) ) THEN 355 ALLOCATE( zsaldta(jpi,jpj,jp j,jpts) )421 ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) ) 356 422 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 357 423 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diahth.F90
r10425 r12706 11 11 !! 3.2 ! 2009-07 (S. Masson) hc300 bugfix + cleaning + add new diag 12 12 !!---------------------------------------------------------------------- 13 #if defined key_diahth14 !!----------------------------------------------------------------------15 !! 'key_diahth' : thermocline depth diag.16 !!----------------------------------------------------------------------17 13 !! dia_hth : Compute varius diagnostics associated with the mixed layer 18 14 !!---------------------------------------------------------------------- … … 32 28 PUBLIC dia_hth_alloc ! routine called by nemogcm.F90 33 29 34 LOGICAL , PUBLIC, PARAMETER :: lk_diahth = .TRUE.!: thermocline-20d depths flag30 LOGICAL, SAVE :: l_hth !: thermocline-20d depths flag 35 31 36 32 ! note: following variables should move to local variables once iom_put is always used 37 33 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] 38 34 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] 35 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd26 !: depth of 26 C isotherm [m] 39 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] 40 37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc7 !: heat content of first 700 m [W] 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] 40 41 41 42 42 !!---------------------------------------------------------------------- … … 52 52 !!--------------------------------------------------------------------- 53 53 ! 54 ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd28(jpi,jpj), htc3(jpi,jpj), STAT=dia_hth_alloc ) 54 ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd26(jpi,jpj), hd28(jpi,jpj), & 55 & htc3(jpi,jpj), htc7(jpi,jpj), htc20(jpi,jpj), STAT=dia_hth_alloc ) 55 56 ! 56 57 CALL mpp_sum ( 'diahth', dia_hth_alloc ) … … 82 83 INTEGER, INTENT( in ) :: kt ! ocean time-step index 83 84 !! 84 INTEGER :: ji, jj, jk ! dummy loop arguments 85 INTEGER :: iid, ilevel ! temporary integers 86 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ik20, ik28 ! levels 87 REAL(wp) :: zavt5 = 5.e-4_wp ! Kz criterion for the turbocline depth 88 REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth 89 REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth 90 REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth 91 REAL(wp) :: zthick_0, zcoef ! temporary scalars 92 REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop 93 REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace 94 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 96 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho10_3 ! MLD: rho = rho10m + zrho3 97 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) 98 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ztinv ! max of temperature inversion 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdepinv ! depth of temperature inversion 100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zmaxdzT ! max of dT/dz 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zthick ! vertical integration thickness 104 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdelr ! delta rho equivalent to deltaT = 0.2 85 INTEGER :: ji, jj, jk ! dummy loop arguments 86 REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth 87 REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth 88 REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth 89 REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop 90 REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace 91 REAL(wp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 92 REAL(wp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 93 REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3 94 REAL(wp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) 95 REAL(wp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion 96 REAL(wp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion 97 REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 98 REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 99 REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz 100 REAL(wp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2 105 101 !!---------------------------------------------------------------------- 106 102 IF( ln_timing ) CALL timing_start('dia_hth') 107 103 108 104 IF( kt == nit000 ) THEN 105 l_hth = .FALSE. 106 IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) .OR. & 107 & iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & 108 & iom_use( '20d' ) .OR. iom_use( '26d' ) .OR. iom_use( '28d' ) .OR. & 109 & iom_use( 'hc300' ) .OR. iom_use( 'hc700' ) .OR. iom_use( 'hc2000' ) .OR. & 110 & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) l_hth = .TRUE. 109 111 ! ! allocate dia_hth array 110 IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard arrays' ) 111 112 IF(.NOT. ALLOCATED(ik20) ) THEN 113 ALLOCATE(ik20(jpi,jpj), ik28(jpi,jpj), & 114 & zabs2(jpi,jpj), & 115 & ztm2(jpi,jpj), & 116 & zrho10_3(jpi,jpj),& 117 & zpycn(jpi,jpj), & 118 & ztinv(jpi,jpj), & 119 & zdepinv(jpi,jpj), & 120 & zrho0_3(jpi,jpj), & 121 & zrho0_1(jpi,jpj), & 122 & zmaxdzT(jpi,jpj), & 123 & zthick(jpi,jpj), & 124 & zdelr(jpi,jpj), STAT=ji) 125 CALL mpp_sum('diahth', ji) 126 IF( ji /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard ocean arrays' ) 127 END IF 128 129 IF(lwp) WRITE(numout,*) 130 IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth' 131 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 132 IF(lwp) WRITE(numout,*) 112 IF( l_hth ) THEN 113 IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard arrays' ) 114 IF(lwp) WRITE(numout,*) 115 IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth' 116 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 117 IF(lwp) WRITE(numout,*) 118 ENDIF 133 119 ENDIF 134 120 135 ! initialization 136 ztinv (:,:) = 0._wp 137 zdepinv(:,:) = 0._wp 138 zmaxdzT(:,:) = 0._wp 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 142 hth (ji,jj) = zztmp 143 zabs2 (ji,jj) = zztmp 144 ztm2 (ji,jj) = zztmp 145 zrho10_3(ji,jj) = zztmp 146 zpycn (ji,jj) = zztmp 147 END DO 148 END DO 149 IF( nla10 > 1 ) THEN 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 153 zrho0_3(ji,jj) = zztmp 154 zrho0_1(ji,jj) = zztmp 155 END DO 156 END DO 121 IF( l_hth ) THEN 122 ! 123 IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) ) THEN 124 ! initialization 125 ztinv (:,:) = 0._wp 126 zdepinv(:,:) = 0._wp 127 zmaxdzT(:,:) = 0._wp 128 DO jj = 1, jpj 129 DO ji = 1, jpi 130 zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 131 hth (ji,jj) = zztmp 132 zabs2 (ji,jj) = zztmp 133 ztm2 (ji,jj) = zztmp 134 zrho10_3(ji,jj) = zztmp 135 zpycn (ji,jj) = zztmp 136 END DO 137 END DO 138 IF( nla10 > 1 ) THEN 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 142 zrho0_3(ji,jj) = zztmp 143 zrho0_1(ji,jj) = zztmp 144 END DO 145 END DO 146 ENDIF 147 148 ! Preliminary computation 149 ! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC) 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 IF( tmask(ji,jj,nla10) == 1. ) THEN 153 zu = 1779.50 + 11.250 * tsn(ji,jj,nla10,jp_tem) - 3.80 * tsn(ji,jj,nla10,jp_sal) & 154 & - 0.0745 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) & 155 & - 0.0100 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_sal) 156 zv = 5891.00 + 38.000 * tsn(ji,jj,nla10,jp_tem) + 3.00 * tsn(ji,jj,nla10,jp_sal) & 157 & - 0.3750 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) 158 zut = 11.25 - 0.149 * tsn(ji,jj,nla10,jp_tem) - 0.01 * tsn(ji,jj,nla10,jp_sal) 159 zvt = 38.00 - 0.750 * tsn(ji,jj,nla10,jp_tem) 160 zw = (zu + 0.698*zv) * (zu + 0.698*zv) 161 zdelr(ji,jj) = ztem2 * (1000.*(zut*zv - zvt*zu)/zw) 162 ELSE 163 zdelr(ji,jj) = 0._wp 164 ENDIF 165 END DO 166 END DO 167 168 ! ------------------------------------------------------------- ! 169 ! thermocline depth: strongest vertical gradient of temperature ! 170 ! turbocline depth (mixing layer depth): avt = zavt5 ! 171 ! MLD: rho = rho(1) + zrho3 ! 172 ! MLD: rho = rho(1) + zrho1 ! 173 ! ------------------------------------------------------------- ! 174 DO jk = jpkm1, 2, -1 ! loop from bottom to 2 175 DO jj = 1, jpj 176 DO ji = 1, jpi 177 ! 178 zzdep = gdepw_n(ji,jj,jk) 179 zztmp = ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) & 180 & / zzdep * tmask(ji,jj,jk) ! vertical gradient of temperature (dT/dz) 181 zzdep = zzdep * tmask(ji,jj,1) 182 183 IF( zztmp > zmaxdzT(ji,jj) ) THEN 184 zmaxdzT(ji,jj) = zztmp 185 hth (ji,jj) = zzdep ! max and depth of dT/dz 186 ENDIF 187 188 IF( nla10 > 1 ) THEN 189 zztmp = rhop(ji,jj,jk) - rhop(ji,jj,1) ! delta rho(1) 190 IF( zztmp > zrho3 ) zrho0_3(ji,jj) = zzdep ! > 0.03 191 IF( zztmp > zrho1 ) zrho0_1(ji,jj) = zzdep ! > 0.01 192 ENDIF 193 END DO 194 END DO 195 END DO 196 197 CALL iom_put( 'mlddzt', hth ) ! depth of the thermocline 198 IF( nla10 > 1 ) THEN 199 CALL iom_put( 'mldr0_3', zrho0_3 ) ! MLD delta rho(surf) = 0.03 200 CALL iom_put( 'mldr0_1', zrho0_1 ) ! MLD delta rho(surf) = 0.01 201 ENDIF 202 ! 203 ENDIF 204 ! 205 IF( iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & 206 & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) THEN 207 ! ------------------------------------------------------------- ! 208 ! MLD: abs( tn - tn(10m) ) = ztem2 ! 209 ! Top of thermocline: tn = tn(10m) - ztem2 ! 210 ! MLD: rho = rho10m + zrho3 ! 211 ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) ! 212 ! temperature inversion: max( 0, max of tn - tn(10m) ) ! 213 ! depth of temperature inversion ! 214 ! ------------------------------------------------------------- ! 215 DO jk = jpkm1, nlb10, -1 ! loop from bottom to nlb10 216 DO jj = 1, jpj 217 DO ji = 1, jpi 218 ! 219 zzdep = gdepw_n(ji,jj,jk) * tmask(ji,jj,1) 220 ! 221 zztmp = tsn(ji,jj,nla10,jp_tem) - tsn(ji,jj,jk,jp_tem) ! - delta T(10m) 222 IF( ABS(zztmp) > ztem2 ) zabs2 (ji,jj) = zzdep ! abs > 0.2 223 IF( zztmp > ztem2 ) ztm2 (ji,jj) = zzdep ! > 0.2 224 zztmp = -zztmp ! delta T(10m) 225 IF( zztmp > ztinv(ji,jj) ) THEN ! temperature inversion 226 ztinv(ji,jj) = zztmp 227 zdepinv (ji,jj) = zzdep ! max value and depth 228 ENDIF 229 230 zztmp = rhop(ji,jj,jk) - rhop(ji,jj,nla10) ! delta rho(10m) 231 IF( zztmp > zrho3 ) zrho10_3(ji,jj) = zzdep ! > 0.03 232 IF( zztmp > zdelr(ji,jj) ) zpycn (ji,jj) = zzdep ! > equi. delta T(10m) - 0.2 233 ! 234 END DO 235 END DO 236 END DO 237 238 CALL iom_put( 'mld_dt02', zabs2 ) ! MLD abs(delta t) - 0.2 239 CALL iom_put( 'topthdep', ztm2 ) ! T(10) - 0.2 240 CALL iom_put( 'mldr10_3', zrho10_3 ) ! MLD delta rho(10m) = 0.03 241 CALL iom_put( 'pycndep' , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 242 CALL iom_put( 'tinv' , ztinv ) ! max. temp. inv. (t10 ref) 243 CALL iom_put( 'depti' , zdepinv ) ! depth of max. temp. inv. (t10 ref) 244 ! 245 ENDIF 246 247 ! ------------------------------- ! 248 ! Depth of 20C/26C/28C isotherm ! 249 ! ------------------------------- ! 250 IF( iom_use ('20d') ) THEN ! depth of the 20 isotherm 251 ztem2 = 20. 252 CALL dia_hth_dep( ztem2, hd20 ) 253 CALL iom_put( '20d', hd20 ) 254 ENDIF 255 ! 256 IF( iom_use ('26d') ) THEN ! depth of the 26 isotherm 257 ztem2 = 26. 258 CALL dia_hth_dep( ztem2, hd26 ) 259 CALL iom_put( '26d', hd26 ) 260 ENDIF 261 ! 262 IF( iom_use ('28d') ) THEN ! depth of the 28 isotherm 263 ztem2 = 28. 264 CALL dia_hth_dep( ztem2, hd28 ) 265 CALL iom_put( '28d', hd28 ) 266 ENDIF 267 268 ! ----------------------------- ! 269 ! Heat content of first 300 m ! 270 ! ----------------------------- ! 271 IF( iom_use ('hc300') ) THEN 272 zzdep = 300. 273 CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), htc3 ) 274 CALL iom_put( 'hc300', rau0_rcp * htc3 ) ! vertically integrated heat content (J/m2) 275 ENDIF 276 ! 277 ! ----------------------------- ! 278 ! Heat content of first 700 m ! 279 ! ----------------------------- ! 280 IF( iom_use ('hc700') ) THEN 281 zzdep = 700. 282 CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), htc7 ) 283 CALL iom_put( 'hc700', rau0_rcp * htc7 ) ! vertically integrated heat content (J/m2) 284 285 ENDIF 286 ! 287 ! ----------------------------- ! 288 ! Heat content of first 2000 m ! 289 ! ----------------------------- ! 290 IF( iom_use ('hc2000') ) THEN 291 zzdep = 2000. 292 CALL dia_hth_htc( zzdep, tsn(:,:,:,jp_tem), htc20 ) 293 CALL iom_put( 'hc2000', rau0_rcp * htc20 ) ! vertically integrated heat content (J/m2) 294 ENDIF 295 ! 157 296 ENDIF 297 298 ! 299 IF( ln_timing ) CALL timing_stop('dia_hth') 300 ! 301 END SUBROUTINE dia_hth 302 303 SUBROUTINE dia_hth_dep( ptem, pdept ) 304 ! 305 REAL(wp), INTENT(in) :: ptem 306 REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pdept 307 ! 308 INTEGER :: ji, jj, jk, iid 309 REAL(wp) :: zztmp, zzdep 310 INTEGER, DIMENSION(jpi,jpj) :: iktem 158 311 159 ! Preliminary computation 160 ! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC) 161 DO jj = 1, jpj 162 DO ji = 1, jpi 163 IF( tmask(ji,jj,nla10) == 1. ) THEN 164 zu = 1779.50 + 11.250 * tsn(ji,jj,nla10,jp_tem) - 3.80 * tsn(ji,jj,nla10,jp_sal) & 165 & - 0.0745 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) & 166 & - 0.0100 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_sal) 167 zv = 5891.00 + 38.000 * tsn(ji,jj,nla10,jp_tem) + 3.00 * tsn(ji,jj,nla10,jp_sal) & 168 & - 0.3750 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) 169 zut = 11.25 - 0.149 * tsn(ji,jj,nla10,jp_tem) - 0.01 * tsn(ji,jj,nla10,jp_sal) 170 zvt = 38.00 - 0.750 * tsn(ji,jj,nla10,jp_tem) 171 zw = (zu + 0.698*zv) * (zu + 0.698*zv) 172 zdelr(ji,jj) = ztem2 * (1000.*(zut*zv - zvt*zu)/zw) 173 ELSE 174 zdelr(ji,jj) = 0._wp 175 ENDIF 176 END DO 177 END DO 178 179 ! ------------------------------------------------------------- ! 180 ! thermocline depth: strongest vertical gradient of temperature ! 181 ! turbocline depth (mixing layer depth): avt = zavt5 ! 182 ! MLD: rho = rho(1) + zrho3 ! 183 ! MLD: rho = rho(1) + zrho1 ! 184 ! ------------------------------------------------------------- ! 185 DO jk = jpkm1, 2, -1 ! loop from bottom to 2 186 DO jj = 1, jpj 187 DO ji = 1, jpi 188 ! 189 zzdep = gdepw_n(ji,jj,jk) 190 zztmp = ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) / zzdep * tmask(ji,jj,jk) ! vertical gradient of temperature (dT/dz) 191 zzdep = zzdep * tmask(ji,jj,1) 192 193 IF( zztmp > zmaxdzT(ji,jj) ) THEN 194 zmaxdzT(ji,jj) = zztmp ; hth (ji,jj) = zzdep ! max and depth of dT/dz 195 ENDIF 196 197 IF( nla10 > 1 ) THEN 198 zztmp = rhop(ji,jj,jk) - rhop(ji,jj,1) ! delta rho(1) 199 IF( zztmp > zrho3 ) zrho0_3(ji,jj) = zzdep ! > 0.03 200 IF( zztmp > zrho1 ) zrho0_1(ji,jj) = zzdep ! > 0.01 201 ENDIF 202 203 END DO 204 END DO 205 END DO 206 207 CALL iom_put( "mlddzt", hth ) ! depth of the thermocline 208 IF( nla10 > 1 ) THEN 209 CALL iom_put( "mldr0_3", zrho0_3 ) ! MLD delta rho(surf) = 0.03 210 CALL iom_put( "mldr0_1", zrho0_1 ) ! MLD delta rho(surf) = 0.01 211 ENDIF 212 213 ! ------------------------------------------------------------- ! 214 ! MLD: abs( tn - tn(10m) ) = ztem2 ! 215 ! Top of thermocline: tn = tn(10m) - ztem2 ! 216 ! MLD: rho = rho10m + zrho3 ! 217 ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) ! 218 ! temperature inversion: max( 0, max of tn - tn(10m) ) ! 219 ! depth of temperature inversion ! 220 ! ------------------------------------------------------------- ! 221 DO jk = jpkm1, nlb10, -1 ! loop from bottom to nlb10 222 DO jj = 1, jpj 223 DO ji = 1, jpi 224 ! 225 zzdep = gdepw_n(ji,jj,jk) * tmask(ji,jj,1) 226 ! 227 zztmp = tsn(ji,jj,nla10,jp_tem) - tsn(ji,jj,jk,jp_tem) ! - delta T(10m) 228 IF( ABS(zztmp) > ztem2 ) zabs2 (ji,jj) = zzdep ! abs > 0.2 229 IF( zztmp > ztem2 ) ztm2 (ji,jj) = zzdep ! > 0.2 230 zztmp = -zztmp ! delta T(10m) 231 IF( zztmp > ztinv(ji,jj) ) THEN ! temperature inversion 232 ztinv(ji,jj) = zztmp ; zdepinv (ji,jj) = zzdep ! max value and depth 233 ENDIF 234 235 zztmp = rhop(ji,jj,jk) - rhop(ji,jj,nla10) ! delta rho(10m) 236 IF( zztmp > zrho3 ) zrho10_3(ji,jj) = zzdep ! > 0.03 237 IF( zztmp > zdelr(ji,jj) ) zpycn (ji,jj) = zzdep ! > equi. delta T(10m) - 0.2 238 ! 239 END DO 240 END DO 241 END DO 242 243 CALL iom_put( "mld_dt02", zabs2 ) ! MLD abs(delta t) - 0.2 244 CALL iom_put( "topthdep", ztm2 ) ! T(10) - 0.2 245 CALL iom_put( "mldr10_3", zrho10_3 ) ! MLD delta rho(10m) = 0.03 246 CALL iom_put( "pycndep" , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 247 CALL iom_put( "tinv" , ztinv ) ! max. temp. inv. (t10 ref) 248 CALL iom_put( "depti" , zdepinv ) ! depth of max. temp. inv. (t10 ref) 249 250 251 ! ----------------------------------- ! 252 ! search deepest level above 20C/28C ! 253 ! ----------------------------------- ! 254 ik20(:,:) = 1 255 ik28(:,:) = 1 312 ! --------------------------------------- ! 313 ! search deepest level above ptem ! 314 ! --------------------------------------- ! 315 iktem(:,:) = 1 256 316 DO jk = 1, jpkm1 ! beware temperature is not always decreasing with depth => loop from top to bottom 257 317 DO jj = 1, jpj 258 318 DO ji = 1, jpi 259 319 zztmp = tsn(ji,jj,jk,jp_tem) 260 IF( zztmp >= 20. ) ik20(ji,jj) = jk 261 IF( zztmp >= 28. ) ik28(ji,jj) = jk 320 IF( zztmp >= ptem ) iktem(ji,jj) = jk 262 321 END DO 263 322 END DO 264 323 END DO 265 324 266 ! --------------------------- !267 ! Depth of 20C/28C isotherm!268 ! --------------------------- !325 ! ------------------------------- ! 326 ! Depth of ptem isotherm ! 327 ! ------------------------------- ! 269 328 DO jj = 1, jpj 270 329 DO ji = 1, jpi 271 330 ! 272 zzdep = gdepw_n(ji,jj,mbkt(ji,jj)+1) ! depth of the o ean bottom331 zzdep = gdepw_n(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean bottom 273 332 ! 274 iid = ik 20(ji,jj)333 iid = iktem(ji,jj) 275 334 IF( iid /= 1 ) THEN 276 zztmp =gdept_n(ji,jj,iid ) & ! linear interpolation335 zztmp = gdept_n(ji,jj,iid ) & ! linear interpolation 277 336 & + ( gdept_n(ji,jj,iid+1) - gdept_n(ji,jj,iid) ) & 278 337 & * ( 20.*tmask(ji,jj,iid+1) - tsn(ji,jj,iid,jp_tem) ) & 279 338 & / ( tsn(ji,jj,iid+1,jp_tem) - tsn(ji,jj,iid,jp_tem) + (1.-tmask(ji,jj,1)) ) 280 hd20(ji,jj) = MIN( zztmp , zzdep) * tmask(ji,jj,1) ! bound by the ocean depth339 pdept(ji,jj) = MIN( zztmp , zzdep) * tmask(ji,jj,1) ! bound by the ocean depth 281 340 ELSE 282 hd20(ji,jj) = 0._wp341 pdept(ji,jj) = 0._wp 283 342 ENDIF 284 !285 iid = ik28(ji,jj)286 IF( iid /= 1 ) THEN287 zztmp = gdept_n(ji,jj,iid ) & ! linear interpolation288 & + ( gdept_n(ji,jj,iid+1) - gdept_n(ji,jj,iid) ) &289 & * ( 28.*tmask(ji,jj,iid+1) - tsn(ji,jj,iid,jp_tem) ) &290 & / ( tsn(ji,jj,iid+1,jp_tem) - tsn(ji,jj,iid,jp_tem) + (1.-tmask(ji,jj,1)) )291 hd28(ji,jj) = MIN( zztmp , zzdep ) * tmask(ji,jj,1) ! bound by the ocean depth292 ELSE293 hd28(ji,jj) = 0._wp294 ENDIF295 296 343 END DO 297 344 END DO 298 CALL iom_put( "20d", hd20 ) ! depth of the 20 isotherm 299 CALL iom_put( "28d", hd28 ) ! depth of the 28 isotherm 300 301 ! ----------------------------- ! 302 ! Heat content of first 300 m ! 303 ! ----------------------------- ! 304 305 ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_1d to do this search...) 306 ilevel = 0 307 zthick_0 = 0._wp 308 DO jk = 1, jpkm1 309 zthick_0 = zthick_0 + e3t_1d(jk) 310 IF( zthick_0 < 300. ) ilevel = jk 311 END DO 345 ! 346 END SUBROUTINE dia_hth_dep 347 348 349 SUBROUTINE dia_hth_htc( pdep, ptn, phtc ) 350 ! 351 REAL(wp), INTENT(in) :: pdep ! depth over the heat content 352 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptn 353 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc 354 ! 355 INTEGER :: ji, jj, jk, ik 356 REAL(wp), DIMENSION(jpi,jpj) :: zthick 357 INTEGER , DIMENSION(jpi,jpj) :: ilevel 358 359 312 360 ! surface boundary condition 313 IF( ln_linssh ) THEN ; zthick(:,:) = sshn(:,:) ; htc3(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1) 314 ELSE ; zthick(:,:) = 0._wp ; htc3(:,:) = 0._wp 361 362 IF( .NOT. ln_linssh ) THEN ; zthick(:,:) = 0._wp ; phtc(:,:) = 0._wp 363 ELSE ; zthick(:,:) = sshn(:,:) ; phtc(:,:) = ptn(:,:,1) * sshn(:,:) * tmask(:,:,1) 315 364 ENDIF 316 ! integration down to ilevel 317 DO jk = 1, ilevel 318 zthick(:,:) = zthick(:,:) + e3t_n(:,:,jk) 319 htc3 (:,:) = htc3 (:,:) + e3t_n(:,:,jk) * tsn(:,:,jk,jp_tem) * tmask(:,:,jk) 320 END DO 321 ! deepest layer 322 zthick(:,:) = 300. - zthick(:,:) ! remaining thickness to reach 300m 365 ! 366 ilevel(:,:) = 1 367 DO jk = 2, jpkm1 368 DO jj = 1, jpj 369 DO ji = 1, jpi 370 IF( ( gdept_n(ji,jj,jk) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN 371 ilevel(ji,jj) = jk 372 zthick(ji,jj) = zthick(ji,jj) + e3t_n(ji,jj,jk) 373 phtc (ji,jj) = phtc (ji,jj) + e3t_n(ji,jj,jk) * ptn(ji,jj,jk) 374 ENDIF 375 ENDDO 376 ENDDO 377 ENDDO 378 ! 323 379 DO jj = 1, jpj 324 380 DO ji = 1, jpi 325 htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem) & 326 & * MIN( e3t_n(ji,jj,ilevel+1), zthick(ji,jj) ) * tmask(ji,jj,ilevel+1) 381 ik = ilevel(ji,jj) 382 zthick(ji,jj) = pdep - zthick(ji,jj) ! remaining thickness to reach depht pdep 383 phtc(ji,jj) = phtc(ji,jj) + ptn(ji,jj,ik+1) * MIN( e3t_n(ji,jj,ik+1), zthick(ji,jj) ) & 384 * tmask(ji,jj,ik+1) 327 385 END DO 328 END DO 329 ! from temperature to heat contain 330 zcoef = rau0 * rcp 331 htc3(:,:) = zcoef * htc3(:,:) 332 CALL iom_put( "hc300", htc3 ) ! first 300m heat content 333 ! 334 IF( ln_timing ) CALL timing_stop('dia_hth') 335 ! 336 END SUBROUTINE dia_hth 337 338 #else 339 !!---------------------------------------------------------------------- 340 !! Default option : Empty module 341 !!---------------------------------------------------------------------- 342 LOGICAL , PUBLIC, PARAMETER :: lk_diahth = .FALSE. !: thermocline-20d depths flag 343 CONTAINS 344 SUBROUTINE dia_hth( kt ) ! Empty routine 345 IMPLICIT NONE 346 INTEGER, INTENT( in ) :: kt 347 WRITE(*,*) 'dia_hth: You should not have seen this print! error?', kt 348 END SUBROUTINE dia_hth 349 #endif 386 ENDDO 387 ! 388 ! 389 END SUBROUTINE dia_hth_htc 350 390 351 391 !!====================================================================== -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diaptr.F90
r12143 r12706 10 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 11 11 !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 12 !! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment 12 13 !!---------------------------------------------------------------------- 13 14 … … 42 43 43 44 ! !!** namelist namptr ** 44 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv !: Heat TRansports (adv, diff, Bolus.) 45 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv !: Salt TRansports (adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.) 47 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic ) 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 48 47 49 48 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 50 49 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 51 INTEGER, P UBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)50 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 52 51 53 52 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup 54 53 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp) 55 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 56 57 CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 60 61 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 62 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 54 REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rau0) 55 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 58 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 60 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 63 61 64 62 !! * Substitutions … … 80 78 REAL(wp) :: zsfc,zvfc ! local scalar 81 79 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace83 80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 81 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 84 82 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 85 REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace 86 REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace 87 83 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 88 84 ! 89 85 !overturning calculation 90 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 91 REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function 92 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace 93 94 95 CHARACTER( len = 12 ) :: cl1 86 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 87 REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 88 89 REAL(wp), DIMENSION(jpi,jpj,jpk,nptr) :: z4d1, z4d2 90 REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function 96 91 !!---------------------------------------------------------------------- 97 92 ! 98 93 IF( ln_timing ) CALL timing_start('dia_ptr') 99 100 94 ! 101 95 IF( PRESENT( pvtr ) ) THEN 102 IF( iom_use("zomsfglo") ) THEN ! effective MSF 103 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport 104 DO jk = 2, jpkm1 105 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 96 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 97 DO jn = 1, nptr ! by sub-basins 98 z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas 99 DO jk = jpkm1, 1, -1 100 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 101 END DO 102 DO ji = 1, jpi 103 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 104 ENDDO 106 105 END DO 107 DO ji = 1, jpi 108 z3d(ji,:,:) = z3d(1,:,:) 109 ENDDO 110 cl1 = TRIM('zomsf'//clsubb(1) ) 111 CALL iom_put( cl1, z3d * rc_sv ) 112 DO jn = 2, nptr ! by sub-basins 113 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 114 DO jk = 2, jpkm1 115 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 116 END DO 117 DO ji = 1, jpi 118 z3d(ji,:,:) = z3d(1,:,:) 119 ENDDO 120 cl1 = TRIM('zomsf'//clsubb(jn) ) 121 CALL iom_put( cl1, z3d * rc_sv ) 122 END DO 123 ENDIF 124 IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 106 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 107 ENDIF 108 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 109 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 125 110 ! define fields multiplied by scalar 126 111 zmask(:,:,:) = 0._wp 127 112 zts(:,:,:,:) = 0._wp 128 zvn(:,:,:) = 0._wp129 113 DO jk = 1, jpkm1 130 114 DO jj = 1, jpjm1 … … 134 118 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 135 119 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 136 zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc137 120 ENDDO 138 121 ENDDO 139 122 ENDDO 140 123 ENDIF 141 IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 142 sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 143 r1_sjk(:,:,1) = 0._wp 144 WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 145 146 ! i-mean T and S, j-Stream-Function, global 147 tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 148 sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 149 v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 150 151 htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 152 str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 153 154 z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW) 155 DO ji = 1, jpi 156 z2d(ji,:) = z2d(1,:) 157 ENDDO 158 cl1 = 'sophtove' 159 CALL iom_put( TRIM(cl1), z2d ) 160 z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg) 161 DO ji = 1, jpi 162 z2d(ji,:) = z2d(1,:) 163 ENDDO 164 cl1 = 'sopstove' 165 CALL iom_put( TRIM(cl1), z2d ) 166 IF( ln_subbas ) THEN 167 DO jn = 2, nptr 168 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 169 r1_sjk(:,:,jn) = 0._wp 170 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 171 172 ! i-mean T and S, j-Stream-Function, basin 173 tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 174 sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 175 v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 176 htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 177 str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 178 179 z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW) 180 DO ji = 1, jpi 181 z2d(ji,:) = z2d(1,:) 182 ENDDO 183 cl1 = TRIM('sophtove_'//clsubb(jn)) 184 CALL iom_put( cl1, z2d ) 185 z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg) 186 DO ji = 1, jpi 187 z2d(ji,:) = z2d(1,:) 188 ENDDO 189 cl1 = TRIM('sopstove_'//clsubb(jn)) 190 CALL iom_put( cl1, z2d ) 191 END DO 192 ENDIF 193 ENDIF 194 IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 195 ! Calculate barotropic heat and salt transport here 196 sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 197 r1_sjk(:,1,1) = 0._wp 198 WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 199 200 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 201 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 202 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 203 htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 204 str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 205 z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW) 206 DO ji = 2, jpi 207 z2d(ji,:) = z2d(1,:) 208 ENDDO 209 cl1 = 'sophtbtr' 210 CALL iom_put( TRIM(cl1), z2d ) 211 z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg) 212 DO ji = 2, jpi 213 z2d(ji,:) = z2d(1,:) 214 ENDDO 215 cl1 = 'sopstbtr' 216 CALL iom_put( TRIM(cl1), z2d ) 217 IF( ln_subbas ) THEN 218 DO jn = 2, nptr 219 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 220 r1_sjk(:,1,jn) = 0._wp 221 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 222 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 223 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 224 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 225 htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 226 str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 227 z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW) 228 DO ji = 1, jpi 229 z2d(ji,:) = z2d(1,:) 230 ENDDO 231 cl1 = TRIM('sophtbtr_'//clsubb(jn)) 232 CALL iom_put( cl1, z2d ) 233 z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg) 234 DO ji = 1, jpi 235 z2d(ji,:) = z2d(1,:) 236 ENDDO 237 cl1 = TRIM('sopstbtr_'//clsubb(jn)) 238 CALL iom_put( cl1, z2d ) 239 ENDDO 240 ENDIF !ln_subbas 241 ENDIF !iom_use("sopstbtr....) 124 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 125 DO jn = 1, nptr 126 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 127 r1_sjk(:,:,jn) = 0._wp 128 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 129 ! i-mean T and S, j-Stream-Function, basin 130 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 131 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 132 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 133 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 134 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 135 ! 136 ENDDO 137 DO jn = 1, nptr 138 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 139 DO ji = 1, jpi 140 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 141 ENDDO 142 ENDDO 143 CALL iom_put( 'sophtove', z3dtr ) 144 DO jn = 1, nptr 145 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 146 DO ji = 1, jpi 147 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 148 ENDDO 149 ENDDO 150 CALL iom_put( 'sopstove', z3dtr ) 151 ENDIF 152 153 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 154 ! Calculate barotropic heat and salt transport here 155 DO jn = 1, nptr 156 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 157 r1_sjk(:,1,jn) = 0._wp 158 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 159 ! 160 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 161 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 162 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 163 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 164 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 165 ! 166 ENDDO 167 DO jn = 1, nptr 168 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 169 DO ji = 1, jpi 170 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 171 ENDDO 172 ENDDO 173 CALL iom_put( 'sophtbtr', z3dtr ) 174 DO jn = 1, nptr 175 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 176 DO ji = 1, jpi 177 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 178 ENDDO 179 ENDDO 180 CALL iom_put( 'sopstbtr', z3dtr ) 181 ENDIF 242 182 ! 243 183 ELSE 244 184 ! 245 IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface 185 zmask(:,:,:) = 0._wp 186 zts(:,:,:,:) = 0._wp 187 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 246 188 DO jk = 1, jpkm1 247 189 DO jj = 1, jpj … … 254 196 END DO 255 197 END DO 198 ! 256 199 DO jn = 1, nptr 257 200 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 258 cl1 = TRIM('zosrf'//clsubb(jn) ) 259 CALL iom_put( cl1, zmask ) 260 ! 261 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 262 & / MAX( zmask(1,:,:), 10.e-15 ) 263 DO ji = 1, jpi 264 z3d(ji,:,:) = z3d(1,:,:) 265 ENDDO 266 cl1 = TRIM('zotem'//clsubb(jn) ) 267 CALL iom_put( cl1, z3d ) 268 ! 269 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 270 & / MAX( zmask(1,:,:), 10.e-15 ) 271 DO ji = 1, jpi 272 z3d(ji,:,:) = z3d(1,:,:) 273 ENDDO 274 cl1 = TRIM('zosal'//clsubb(jn) ) 275 CALL iom_put( cl1, z3d ) 276 END DO 201 z4d1(:,:,:,jn) = zmask(:,:,:) 202 ENDDO 203 CALL iom_put( 'zosrf', z4d1 ) 204 ! 205 DO jn = 1, nptr 206 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 207 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 208 DO ji = 1, jpi 209 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 210 ENDDO 211 ENDDO 212 CALL iom_put( 'zotem', z4d2 ) 213 ! 214 DO jn = 1, nptr 215 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 216 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 217 DO ji = 1, jpi 218 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 219 ENDDO 220 ENDDO 221 CALL iom_put( 'zosal', z4d2 ) 222 ! 277 223 ENDIF 278 224 ! 279 225 ! ! Advective and diffusive heat and salt transport 280 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 281 z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW) 282 DO ji = 1, jpi 283 z2d(ji,:) = z2d(1,:) 284 ENDDO 285 cl1 = 'sophtadv' 286 CALL iom_put( TRIM(cl1), z2d ) 287 z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg) 288 DO ji = 1, jpi 289 z2d(ji,:) = z2d(1,:) 290 ENDDO 291 cl1 = 'sopstadv' 292 CALL iom_put( TRIM(cl1), z2d ) 293 IF( ln_subbas ) THEN 294 DO jn=2,nptr 295 z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW) 296 DO ji = 1, jpi 297 z2d(ji,:) = z2d(1,:) 298 ENDDO 299 cl1 = TRIM('sophtadv_'//clsubb(jn)) 300 CALL iom_put( cl1, z2d ) 301 z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg) 302 DO ji = 1, jpi 303 z2d(ji,:) = z2d(1,:) 304 ENDDO 305 cl1 = TRIM('sopstadv_'//clsubb(jn)) 306 CALL iom_put( cl1, z2d ) 307 ENDDO 308 ENDIF 309 ENDIF 310 ! 311 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 312 z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW) 313 DO ji = 1, jpi 314 z2d(ji,:) = z2d(1,:) 315 ENDDO 316 cl1 = 'sophtldf' 317 CALL iom_put( TRIM(cl1), z2d ) 318 z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg) 319 DO ji = 1, jpi 320 z2d(ji,:) = z2d(1,:) 321 ENDDO 322 cl1 = 'sopstldf' 323 CALL iom_put( TRIM(cl1), z2d ) 324 IF( ln_subbas ) THEN 325 DO jn=2,nptr 326 z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW) 327 DO ji = 1, jpi 328 z2d(ji,:) = z2d(1,:) 329 ENDDO 330 cl1 = TRIM('sophtldf_'//clsubb(jn)) 331 CALL iom_put( cl1, z2d ) 332 z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg) 333 DO ji = 1, jpi 334 z2d(ji,:) = z2d(1,:) 335 ENDDO 336 cl1 = TRIM('sopstldf_'//clsubb(jn)) 337 CALL iom_put( cl1, z2d ) 338 ENDDO 339 ENDIF 340 ENDIF 341 342 IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN 343 z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW) 344 DO ji = 1, jpi 345 z2d(ji,:) = z2d(1,:) 346 ENDDO 347 cl1 = 'sophteiv' 348 CALL iom_put( TRIM(cl1), z2d ) 349 z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg) 350 DO ji = 1, jpi 351 z2d(ji,:) = z2d(1,:) 352 ENDDO 353 cl1 = 'sopsteiv' 354 CALL iom_put( TRIM(cl1), z2d ) 355 IF( ln_subbas ) THEN 356 DO jn=2,nptr 357 z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW) 226 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 227 ! 228 DO jn = 1, nptr 229 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 230 DO ji = 1, jpi 231 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 232 ENDDO 233 ENDDO 234 CALL iom_put( 'sophtadv', z3dtr ) 235 DO jn = 1, nptr 236 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 237 DO ji = 1, jpi 238 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 239 ENDDO 240 ENDDO 241 CALL iom_put( 'sopstadv', z3dtr ) 242 ENDIF 243 ! 244 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 245 ! 246 DO jn = 1, nptr 247 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 248 DO ji = 1, jpi 249 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 250 ENDDO 251 ENDDO 252 CALL iom_put( 'sophtldf', z3dtr ) 253 DO jn = 1, nptr 254 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 255 DO ji = 1, jpi 256 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 257 ENDDO 258 ENDDO 259 CALL iom_put( 'sopstldf', z3dtr ) 260 ENDIF 261 ! 262 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 263 ! 264 DO jn = 1, nptr 265 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 266 DO ji = 1, jpi 267 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 268 ENDDO 269 ENDDO 270 CALL iom_put( 'sophteiv', z3dtr ) 271 DO jn = 1, nptr 272 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 273 DO ji = 1, jpi 274 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 275 ENDDO 276 ENDDO 277 CALL iom_put( 'sopsteiv', z3dtr ) 278 ENDIF 279 ! 280 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 281 zts(:,:,:,:) = 0._wp 282 DO jk = 1, jpkm1 283 DO jj = 1, jpjm1 358 284 DO ji = 1, jpi 359 z2d(ji,:) = z2d(1,:) 285 zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) 286 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 287 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 360 288 ENDDO 361 cl1 = TRIM('sophteiv_'//clsubb(jn)) 362 CALL iom_put( cl1, z2d ) 363 z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg) 364 DO ji = 1, jpi 365 z2d(ji,:) = z2d(1,:) 366 ENDDO 367 cl1 = TRIM('sopsteiv_'//clsubb(jn)) 368 CALL iom_put( cl1, z2d ) 369 ENDDO 370 ENDIF 289 ENDDO 290 ENDDO 291 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 292 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 293 DO jn = 1, nptr 294 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 295 DO ji = 1, jpi 296 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 297 ENDDO 298 ENDDO 299 CALL iom_put( 'sophtvtr', z3dtr ) 300 DO jn = 1, nptr 301 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 302 DO ji = 1, jpi 303 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 304 ENDDO 305 ENDDO 306 CALL iom_put( 'sopstvtr', z3dtr ) 307 ENDIF 308 ! 309 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 310 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 311 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 312 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 371 313 ENDIF 372 314 ! … … 384 326 !! ** Purpose : Initialization, namelist read 385 327 !!---------------------------------------------------------------------- 386 INTEGER :: jn ! local integers 387 INTEGER :: inum, ierr ! local integers 388 INTEGER :: ios ! Local integer output status for namelist read 328 INTEGER :: inum, jn, ios, ierr ! local integers 389 329 !! 390 330 NAMELIST/namptr/ ln_diaptr, ln_subbas 391 !!---------------------------------------------------------------------- 331 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 332 !!---------------------------------------------------------------------- 333 392 334 393 335 REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport … … 397 339 REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport 398 340 READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 399 902 IF( ios >0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' )341 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 400 342 IF(lwm) WRITE ( numond, namptr ) 401 343 … … 406 348 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 407 349 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr 408 WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas409 350 ENDIF 410 351 411 352 IF( ln_diaptr ) THEN 412 353 ! 413 IF( ln_subbas ) THEN414 nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific415 ALLOCATE( clsubb(nptr) )416 clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc'417 ELSE418 nptr = 1 ! Global only419 ALLOCATE( clsubb(nptr) )420 clsubb(1) = 'glo'421 ENDIF422 423 ! ! allocate dia_ptr arrays424 354 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 425 355 426 356 rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt 357 rc_ggram = rc_ggram * rau0 ! conversion from m3/s to Gg/s 427 358 428 359 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 429 360 430 IF( ln_subbas ) THEN ! load sub-basin mask 431 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 432 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 433 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 434 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 435 CALL iom_close( inum ) 436 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 437 WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean 438 ELSE WHERE ; btm30(:,:) = ssmask(:,:) 439 END WHERE 440 ENDIF 441 442 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 443 444 DO jn = 1, nptr 361 btmsk(:,:,1) = tmask_i(:,:) 362 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 363 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 364 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 365 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 366 CALL iom_close( inum ) 367 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 368 DO jn = 2, nptr 445 369 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 446 370 END DO 371 ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations 372 WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp) 373 zmsk(:,:) = 0._wp ! mask out Southern Ocean 374 ELSE WHERE 375 zmsk(:,:) = ssmask(:,:) 376 END WHERE 377 btmsk34(:,:,1) = btmsk(:,:,1) 378 DO jn = 2, nptr 379 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only 380 ENDDO 447 381 448 382 ! Initialise arrays to zero because diatpr is called before they are first calculated 449 383 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 450 htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp 451 htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp 452 htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp 453 htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp 454 htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp 384 hstr_adv(:,:,:) = 0._wp 385 hstr_ldf(:,:,:) = 0._wp 386 hstr_eiv(:,:,:) = 0._wp 387 hstr_ove(:,:,:) = 0._wp 388 hstr_btr(:,:,:) = 0._wp ! 389 hstr_vtr(:,:,:) = 0._wp ! 455 390 ! 456 391 ENDIF … … 471 406 INTEGER :: jn ! 472 407 408 ! 473 409 IF( cptr == 'adv' ) THEN 474 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 475 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) ) 410 IF( ktra == jp_tem ) THEN 411 DO jn = 1, nptr 412 hstr_adv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 413 ENDDO 414 ENDIF 415 IF( ktra == jp_sal ) THEN 416 DO jn = 1, nptr 417 hstr_adv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 418 ENDDO 419 ENDIF 476 420 ENDIF 421 ! 477 422 IF( cptr == 'ldf' ) THEN 478 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 479 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 423 IF( ktra == jp_tem ) THEN 424 DO jn = 1, nptr 425 hstr_ldf(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 426 ENDDO 427 ENDIF 428 IF( ktra == jp_sal ) THEN 429 DO jn = 1, nptr 430 hstr_ldf(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 431 ENDDO 432 ENDIF 480 433 ENDIF 434 ! 481 435 IF( cptr == 'eiv' ) THEN 482 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 483 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 436 IF( ktra == jp_tem ) THEN 437 DO jn = 1, nptr 438 hstr_eiv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 439 ENDDO 440 ENDIF 441 IF( ktra == jp_sal ) THEN 442 DO jn = 1, nptr 443 hstr_eiv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 444 ENDDO 445 ENDIF 484 446 ENDIF 485 447 ! 486 IF( ln_subbas ) THEN 487 ! 488 IF( cptr == 'adv' ) THEN 489 IF( ktra == jp_tem ) THEN 490 DO jn = 2, nptr 491 htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 492 END DO 493 ENDIF 494 IF( ktra == jp_sal ) THEN 495 DO jn = 2, nptr 496 str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 497 END DO 498 ENDIF 499 ENDIF 500 IF( cptr == 'ldf' ) THEN 501 IF( ktra == jp_tem ) THEN 502 DO jn = 2, nptr 503 htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 504 END DO 505 ENDIF 506 IF( ktra == jp_sal ) THEN 507 DO jn = 2, nptr 508 str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 509 END DO 510 ENDIF 511 ENDIF 512 IF( cptr == 'eiv' ) THEN 513 IF( ktra == jp_tem ) THEN 514 DO jn = 2, nptr 515 htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 516 END DO 517 ENDIF 518 IF( ktra == jp_sal ) THEN 519 DO jn = 2, nptr 520 str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 521 END DO 522 ENDIF 523 ENDIF 524 ! 448 IF( cptr == 'vtr' ) THEN 449 IF( ktra == jp_tem ) THEN 450 DO jn = 1, nptr 451 hstr_vtr(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 452 ENDDO 453 ENDIF 454 IF( ktra == jp_sal ) THEN 455 DO jn = 1, nptr 456 hstr_vtr(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 457 ENDDO 458 ENDIF 525 459 ENDIF 460 ! 526 461 END SUBROUTINE dia_ptr_hst 527 462 … … 536 471 ierr(:) = 0 537 472 ! 538 ALLOCATE( btmsk(jpi,jpj,nptr) , & 539 & htr_adv(jpj,nptr) , str_adv(jpj,nptr) , & 540 & htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 541 & htr_ove(jpj,nptr) , str_ove(jpj,nptr) , & 542 & htr_btr(jpj,nptr) , str_btr(jpj,nptr) , & 543 & htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) ) 544 ! 545 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 546 ! 547 ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) ) 548 549 ! 550 dia_ptr_alloc = MAXVAL( ierr ) 551 CALL mpp_sum( 'diaptr', dia_ptr_alloc ) 473 IF( .NOT. ALLOCATED( btmsk ) ) THEN 474 ALLOCATE( btmsk(jpi,jpj,nptr) , btmsk34(jpi,jpj,nptr), & 475 & hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), & 476 & hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), & 477 & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) 478 ! 479 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 480 ! 481 dia_ptr_alloc = MAXVAL( ierr ) 482 CALL mpp_sum( 'diaptr', dia_ptr_alloc ) 483 ENDIF 552 484 ! 553 485 END FUNCTION dia_ptr_alloc … … 565 497 !! ** Action : - p_fval: i-k-mean poleward flux of pva 566 498 !!---------------------------------------------------------------------- 567 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) 568 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask499 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 500 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 569 501 ! 570 502 INTEGER :: ji, jj, jk ! dummy loop arguments … … 577 509 ijpj = jpj 578 510 p_fval(:) = 0._wp 579 IF( PRESENT( pmsk ) ) THEN 580 DO jk = 1, jpkm1 581 DO jj = 2, jpjm1 582 DO ji = fs_2, fs_jpim1 ! Vector opt. 583 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 584 END DO 511 DO jk = 1, jpkm1 512 DO jj = 2, jpjm1 513 DO ji = fs_2, fs_jpim1 ! Vector opt. 514 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 585 515 END DO 586 516 END DO 587 ELSE 588 DO jk = 1, jpkm1 589 DO jj = 2, jpjm1 590 DO ji = fs_2, fs_jpim1 ! Vector opt. 591 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 592 END DO 593 END DO 594 END DO 595 ENDIF 517 END DO 596 518 #if defined key_mpp_mpi 597 519 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) … … 612 534 !! ** Action : - p_fval: i-k-mean poleward flux of pva 613 535 !!---------------------------------------------------------------------- 614 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) 615 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask536 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 537 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 616 538 ! 617 539 INTEGER :: ji,jj ! dummy loop arguments … … 624 546 ijpj = jpj 625 547 p_fval(:) = 0._wp 626 IF( PRESENT( pmsk ) ) THEN 627 DO jj = 2, jpjm1 628 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 629 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 630 END DO 548 DO jj = 2, jpjm1 549 DO ji = fs_2, fs_jpim1 ! Vector opt. 550 p_fval(jj) = p_fval(jj) + pva(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 631 551 END DO 632 ELSE 633 DO jj = 2, jpjm1 634 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 635 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 636 END DO 637 END DO 638 ENDIF 552 END DO 639 553 #if defined key_mpp_mpi 640 554 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) … … 643 557 END FUNCTION ptr_sj_2d 644 558 559 FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval ) 560 !!---------------------------------------------------------------------- 561 !! *** ROUTINE ptr_ci_2d *** 562 !! 563 !! ** Purpose : "meridional" cumulated sum computation of a j-flux array 564 !! 565 !! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i). 566 !! 567 !! ** Action : - p_fval: j-cumulated sum of pva 568 !!---------------------------------------------------------------------- 569 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 570 ! 571 INTEGER :: ji,jj,jc ! dummy loop arguments 572 INTEGER :: ijpj ! ??? 573 REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value 574 !!-------------------------------------------------------------------- 575 ! 576 ijpj = jpj ! ??? 577 p_fval(:,:) = 0._wp 578 DO jc = 1, jpnj ! looping over all processors in j axis 579 DO jj = 2, jpjm1 580 DO ji = fs_2, fs_jpim1 ! Vector opt. 581 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 582 END DO 583 END DO 584 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. ) 585 END DO 586 ! 587 END FUNCTION ptr_ci_2d 588 589 645 590 646 591 FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) … … 656 601 !! 657 602 IMPLICIT none 658 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) 659 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask603 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point 604 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 660 605 !! 661 606 INTEGER :: ji, jj, jk ! dummy loop arguments … … 673 618 p_fval(:,:) = 0._wp 674 619 ! 675 IF( PRESENT( pmsk ) ) THEN 676 DO jk = 1, jpkm1 677 DO jj = 2, jpjm1 678 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 679 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 680 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 681 END DO 620 DO jk = 1, jpkm1 621 DO jj = 2, jpjm1 622 DO ji = fs_2, fs_jpim1 ! Vector opt. 623 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 682 624 END DO 683 625 END DO 684 ELSE 685 DO jk = 1, jpkm1 686 DO jj = 2, jpjm1 687 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 688 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 689 END DO 690 END DO 691 END DO 692 END IF 626 END DO 693 627 ! 694 628 #if defined key_mpp_mpi -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diawri.F90
r12143 r12706 48 48 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 49 49 USE in_out_manager ! I/O manager 50 USE diatmb ! Top,middle,bottom output51 50 USE dia25h ! 25h Mean output 52 51 USE iom ! … … 393 392 CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2) 394 393 ! 395 396 IF (ln_diatmb) CALL dia_tmb ! tmb values397 394 398 395 IF (ln_dia25h) CALL dia_25h( kt ) ! 25h averaging -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DOM/daymod.F90
r10068 r12706 93 93 CALL ymds2ju( nyear, nmonth, nday, nhour*3600._wp+nminute*60._wp, fjulday ) 94 94 IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error 95 IF( n n_time0*3600 - ndt05 .lt. 0 ) fjulday = fjulday + 1. ! move back to the day at nit000 (and not at nit000 - 1)96 95 IF( nhour*3600 + nminute*60 - ndt05 .lt. 0 ) fjulday = fjulday + 1. ! move back to the day at nit000 (and not at nit000 - 1) 96 97 97 nsec1jan000 = 0 98 98 CALL day_mth -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DYN/divhor.F90
r11987 r12706 72 72 IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence ' 73 73 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 74 hdivn(:,:,:) = 0._wp ! initialize hdivn for the halos at the first time step 74 75 ENDIF 75 76 ! -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DYN/dynnxt.F90
r12143 r12706 226 226 zcoef = atfp * rdt * r1_rau0 227 227 228 e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 228 DO jk = 1, jpkm1 229 e3t_b(:,:,jk) = e3t_b(:,:,jk) - zcoef * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,jk) & 230 & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) 231 END DO 229 232 230 233 IF ( ln_rnf ) THEN 231 IF( ln_rnf_depth ) THEN 232 DO jk = 1, jpkm1 ! Deal with Rivers separetely, as can be through depth too 233 DO jj = 1, jpj 234 DO ji = 1, jpi 235 IF( jk <= nk_rnf(ji,jj) ) THEN 236 e3t_b(ji,jj,jk) = e3t_b(ji,jj,jk) - zcoef * ( - rnf_b(ji,jj) + rnf(ji,jj) ) & 237 & * ( e3t_n(ji,jj,jk) / h_rnf(ji,jj) ) * tmask(ji,jj,jk) 238 ENDIF 239 ENDDO 240 ENDDO 241 ENDDO 242 ELSE 243 e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef * ( -rnf_b(:,:) + rnf(:,:))*tmask(:,:,1) 244 ENDIF 245 END IF 246 ! 247 ! ice shelf melting (deal separatly as it can be in depth) 248 ! PM: we could probably define a generic subroutine to do the in depth correction 249 ! to manage rnf, isf and possibly in the futur icb, tide water glacier (...) 250 ! ...(kt, coef, ktop, kbot, hz, fwf_b, fwf) 251 IF ( ln_isf ) CALL isf_dynnxt( kt, atfp * rdt ) 234 DO jk = 1, jpkm1 235 e3t_b(:,:,jk) = e3t_b(:,:,jk) + zcoef * ( rnf_b(:,:) - rnf(:,:) ) * tmask(:,:,jk) & 236 & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) 237 END DO 238 ENDIF 239 240 IF ( ln_isf ) THEN 241 DO jk = 1, jpkm1 242 e3t_b(:,:,jk) = e3t_b(:,:,jk) - zcoef * ( fwfisf_b(:,:) - fwfisf(:,:) ) * tmask(:,:,jk) & 243 & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) 244 END DO 245 ENDIF 252 246 ! 253 247 IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DYN/dynspg_ts.F90
r12143 r12706 47 47 USE updtide ! tide potential 48 48 USE sbcwave ! surface wave 49 USE diatmb ! Top,middle,bottom output50 49 #if defined key_agrif 51 50 USE agrif_oce_interp ! agrif … … 62 61 USE iom ! IOM library 63 62 USE restart ! only for lrst_oce 64 USE diatmb ! Top,middle,bottom output65 63 66 64 USE iom ! to remove … … 152 150 REAL(wp) :: r1_2dt_b, z1_hu, z1_hv ! local scalars 153 151 REAL(wp) :: za0, za1, za2, za3 ! - - 154 REAL(wp) :: z mdi, zztmp, zldg ! - -152 REAL(wp) :: zztmp, zldg ! - - 155 153 REAL(wp) :: zhu_bck, zhv_bck, zhdiv ! - - 156 154 REAL(wp) :: zun_save, zvn_save ! - - … … 175 173 ! !* Allocate temporary arrays 176 174 IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj)) 177 !178 zmdi=1.e+20 ! missing data indicator for masking179 175 ! 180 176 zwdramp = r_rn_wdmin1 ! simplest ramp … … 856 852 IF( ln_wd_dl ) DEALLOCATE( ztwdmask, zuwdmask, zvwdmask, zuwdav2, zvwdav2 ) 857 853 ! 858 IF( ln_diatmb ) THEN 859 CALL iom_put( "baro_u" , un_b*ssumask(:,:)+zmdi*(1.-ssumask(:,:) ) ) ! Barotropic U Velocity 860 CALL iom_put( "baro_v" , vn_b*ssvmask(:,:)+zmdi*(1.-ssvmask(:,:) ) ) ! Barotropic V Velocity 861 ENDIF 854 CALL iom_put( "baro_u" , un_b ) ! Barotropic U Velocity 855 CALL iom_put( "baro_v" , vn_b ) ! Barotropic V Velocity 862 856 ! 863 857 END SUBROUTINE dyn_spg_ts -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/ICB/icbthm.F90
r10068 r12706 20 20 USE phycst ! NEMO physical constants 21 21 USE sbc_oce 22 USE lib_fortran, ONLY : DDPDD 22 23 23 24 USE icb_oce ! define iceberg arrays … … 55 56 TYPE(iceberg), POINTER :: this, next 56 57 TYPE(point) , POINTER :: pt 58 ! 59 COMPLEX(wp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx 57 60 !!---------------------------------------------------------------------- 61 ! 62 !! initialiaze cicb_melt and cicb_heat 63 cicb_melt = CMPLX( 0.e0, 0.e0, wp ) 64 cicb_hflx = CMPLX( 0.e0, 0.e0, wp ) 58 65 ! 59 66 z1_rday = 1._wp / rday … … 165 172 z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling 166 173 z1_dt_e1e2 = z1_dt * z1_e1e2 174 ! 175 ! iceberg melt 176 !! the use of DDPDD function for the cumulative sum is needed for reproducibility 167 177 zmelt = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt ! kg/s 168 berg_grid%floating_melt(ii,ij) = berg_grid%floating_melt(ii,ij) + zmelt * z1_e1e2 ! kg/m2/s 178 CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, wp ), cicb_melt(ii,ij) ) 179 ! 180 ! iceberg heat flux 181 !! the use of DDPDD function for the cumulative sum is needed for reproducibility 169 182 !! NB. The src_calving_hflx field is currently hardwired to zero in icb_stp, which means that the 170 183 !! heat density of the icebergs is zero and the heat content flux to the ocean from iceberg … … 172 185 zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s 173 186 zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s 174 berg_grid%calving_hflx (ii,ij) = berg_grid%calving_hflx (ii,ij) + ( zheat_hcflux + zheat_latent ) * z1_e1e2 ! W/m2 187 CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, wp ), cicb_hflx(ii,ij) ) 188 ! 189 ! diagnostics 175 190 CALL icb_dia_melt( ii, ij, zMnew, zheat_hcflux, zheat_latent, this%mass_scaling, & 176 191 & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, & … … 214 229 ! 215 230 END DO 216 231 ! 232 berg_grid%floating_melt = REAL(cicb_melt,wp) ! kg/m2/s 233 berg_grid%calving_hflx = REAL(cicb_hflx,wp) 234 ! 217 235 ! now use melt and associated heat flux in ocean (or not) 218 236 ! -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/IOM/iom.F90
r12143 r12706 56 56 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag 57 57 #endif 58 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 58 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_get_var 59 59 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 60 60 PUBLIC iom_use, iom_context_finalize, iom_miss_val … … 62 62 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 63 63 PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 64 PRIVATE iom_p1d, iom_p2d, iom_p3d 64 PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d 65 65 #if defined key_iomput 66 66 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr … … 83 83 END INTERFACE 84 84 INTERFACE iom_put 85 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d 85 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d 86 86 END INTERFACE iom_put 87 87 … … 108 108 TYPE(xios_date) :: start_date 109 109 CHARACTER(len=lc) :: clname 110 INTEGER :: irefyear, irefmonth, irefday 110 111 INTEGER :: ji, jkmin 111 112 LOGICAL :: llrst_context ! is context related to restart … … 139 140 140 141 ! Calendar type is now defined in xml file 142 IF (.NOT.(xios_getvar('ref_year' ,irefyear ))) irefyear = 1900 143 IF (.NOT.(xios_getvar('ref_month',irefmonth))) irefmonth = 01 144 IF (.NOT.(xios_getvar('ref_day' ,irefday ))) irefday = 01 145 141 146 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 142 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date( 1900,01,01,00,00,00), &147 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), & 143 148 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 144 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date( 1900,01,01,00,00,00), &149 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), & 145 150 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 146 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date( 1900,01,01,00,00,00), &151 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), & 147 152 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 148 153 END SELECT … … 223 228 CALL iom_set_axis_attr( "icbcla", class_num ) 224 229 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... 230 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 225 231 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 232 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 226 233 ENDIF 227 234 ! … … 795 802 CHARACTER(LEN=100) :: clinfo ! info character 796 803 !--------------------------------------------------------------------- 804 ! 805 IF( iom_open_init == 0 ) RETURN ! avoid to use iom_file(jf)%nfid that us not yet initialized 797 806 ! 798 807 clinfo = ' iom_close ~~~ ' … … 1329 1338 END SUBROUTINE iom_get_123d 1330 1339 1340 SUBROUTINE iom_get_var( cdname, z2d) 1341 CHARACTER(LEN=*), INTENT(in ) :: cdname 1342 REAL(wp), DIMENSION(jpi,jpj) :: z2d 1343 #if defined key_iomput 1344 IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 1345 z2d(:,:) = 0._wp 1346 CALL xios_recv_field( cdname, z2d) 1347 ENDIF 1348 #else 1349 IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings 1350 #endif 1351 END SUBROUTINE iom_get_var 1352 1331 1353 1332 1354 FUNCTION iom_getszuld ( kiomid ) … … 1698 1720 END SUBROUTINE iom_p3d 1699 1721 1722 SUBROUTINE iom_p4d( cdname, pfield4d ) 1723 CHARACTER(LEN=*) , INTENT(in) :: cdname 1724 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1725 #if defined key_iomput 1726 CALL xios_send_field(cdname, pfield4d) 1727 #else 1728 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 1729 #endif 1730 END SUBROUTINE iom_p4d 1731 1732 1700 1733 #if defined key_iomput 1701 1734 !!---------------------------------------------------------------------- … … 2040 2073 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2041 2074 ! 2042 CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)2043 !CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)2075 ! CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2076 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2044 2077 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 2045 2078 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2046 2079 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 2047 2080 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 2048 CALL iom_set_zoom_domain_attr("znl_T", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2049 CALL iom_set_zoom_domain_attr("znl_W", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2081 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2050 2082 ! 2051 2083 CALL iom_update_file_name('ptr') -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/LDF/ldfdyn.F90
r12143 r12706 115 115 !!---------------------------------------------------------------------- 116 116 ! 117 REWIND( numnam_ref ) ! Namelist namdyn_ldf in reference namelist : Lateral physics117 REWIND( numnam_ref ) 118 118 READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) 119 119 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) 120 120 121 REWIND( numnam_cfg ) ! Namelist namdyn_ldf in configuration namelist : Lateral physics121 REWIND( numnam_cfg ) 122 122 READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) 123 123 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) … … 417 417 ! 418 418 zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2 419 zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag )! lower limit stability factor scaling419 zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 12._wp * 12._wp * zcmsmag ) ! lower limit stability factor scaling 420 420 zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt ) ! upper limit stability factor scaling 421 421 IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo ! provide |U|L^3/12 lower limit instead -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/LDF/ldfslp.F90
r11987 r12706 208 208 zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u_n(ji,jj,jk)* ABS( zau ) ) 209 209 zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v_n(ji,jj,jk)* ABS( zav ) ) 210 ! ! Fred Dupont: add a correction for bottom partial steps: 211 ! ! max slope = 1/2 * e3 / e1 212 IF (ln_zps .AND. jk==mbku(ji,jj)) & 213 zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , - 2._wp * e1u(ji,jj) / e3u_n(ji,jj,jk)* ABS( zau ) ) 214 IF (ln_zps .AND. jk==mbkv(ji,jj)) & 215 zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , - 2._wp * e2v(ji,jj) / e3v_n(ji,jj,jk)* ABS( zav ) ) 210 216 ! ! uslp and vslp output in zwz and zww, resp. 211 217 zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) … … 403 409 REAL(wp) :: zbeta0, ze3_e1, ze3_e2 404 410 REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw 405 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zalbet406 411 REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients 407 412 REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only … … 459 464 zdks = 0._wp 460 465 ENDIF 461 zdzrho_raw = ( - rab_b(ji,jj,jk +kp,jp_tem) * zdkt &462 & + rab_b(ji,jj,jk +kp,jp_sal) * zdks &466 zdzrho_raw = ( - rab_b(ji,jj,jk ,jp_tem) * zdkt & 467 & + rab_b(ji,jj,jk ,jp_sal) * zdks & 463 468 & ) / e3w_n(ji,jj,jk+kp) 464 469 zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw ) ! force zdzrho >= repsln -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/LDF/ldftra.F90
r12143 r12706 152 152 ! ================================= 153 153 ! 154 REWIND( numnam_ref ) ! Namelist namtra_ldf in reference namelist : Lateral physics on tracers154 REWIND( numnam_ref ) 155 155 READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) 156 156 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) 157 REWIND( numnam_cfg ) ! Namelist namtra_ldf in configuration namelist : Lateral physics on tracers 157 158 REWIND( numnam_cfg ) 158 159 READ ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) 159 160 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) … … 510 511 ENDIF 511 512 ! 512 REWIND( numnam_ref ) ! Namelist namtra_eiv in reference namelist : eddy induced velocity param.513 REWIND( numnam_ref ) 513 514 READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) 514 515 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) 515 516 ! 516 REWIND( numnam_cfg ) ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param.517 REWIND( numnam_cfg ) 517 518 READ ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) 518 519 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) … … 770 771 DO ji = 1, fs_jpim1 ! vector opt. 771 772 zpsi_uw(ji,jj,jk) = - r1_4 * e2u(ji,jj) * ( wslpi(ji,jj,jk ) + wslpi(ji+1,jj,jk) ) & 772 & * ( aeiu (ji,jj,jk-1) + aeiu (ji ,jj,jk) ) * umask(ji,jj,jk)773 & * ( aeiu (ji,jj,jk-1) + aeiu (ji ,jj,jk) ) * wumask(ji,jj,jk) 773 774 zpsi_vw(ji,jj,jk) = - r1_4 * e1v(ji,jj) * ( wslpj(ji,jj,jk ) + wslpj(ji,jj+1,jk) ) & 774 & * ( aeiv (ji,jj,jk-1) + aeiv (ji,jj ,jk) ) * vmask(ji,jj,jk)775 & * ( aeiv (ji,jj,jk-1) + aeiv (ji,jj ,jk) ) * wvmask(ji,jj,jk) 775 776 END DO 776 777 END DO … … 851 852 CALL iom_put( "woce_eiv", zw3d ) 852 853 ! 854 IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value 855 zw2d(:,:) = rau0 * e1e2t(:,:) 856 DO jk = 1, jpk 857 zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) 858 END DO 859 CALL iom_put( "weiv_masstr" , zw3d ) 860 ENDIF 861 ! 862 IF( iom_use('ueiv_masstr') ) THEN 863 zw3d(:,:,:) = 0.e0 864 DO jk = 1, jpkm1 865 zw3d(:,:,jk) = rau0 * ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) 866 END DO 867 CALL iom_put( "ueiv_masstr", zw3d ) ! mass transport in i-direction 868 ENDIF 853 869 ! 854 870 zztmp = 0.5_wp * rau0 * rcp … … 870 886 CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction 871 887 ENDIF 888 ! 889 IF( iom_use('veiv_masstr') ) THEN 890 zw3d(:,:,:) = 0.e0 891 DO jk = 1, jpkm1 892 zw3d(:,:,jk) = rau0 * ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) 893 END DO 894 CALL iom_put( "veiv_masstr", zw3d ) ! mass transport in i-direction 895 ENDIF 896 ! 872 897 zw2d(:,:) = 0._wp 873 898 zw3d(:,:,:) = 0._wp … … 885 910 CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction 886 911 ! 887 IF( ln_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d )912 IF( ln_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) 888 913 ! 889 914 zztmp = 0.5_wp * 0.5 -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/cpl_oasis3.F90
r10582 r12706 306 306 ! End of definition phase 307 307 !------------------------------------------------------------------ 308 308 ! 309 #if defined key_agrif 310 IF( agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN 311 #endif 309 312 CALL oasis_enddef(nerror) 310 313 IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef') 314 #if defined key_agrif 315 ENDIF 316 #endif 311 317 ! 312 318 IF ( ltmp_wapatch ) THEN … … 357 363 WRITE(numout,*) 'oasis_put: kstep ', kstep 358 364 WRITE(numout,*) 'oasis_put: info ', kinfo 359 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata( :,:,jc))360 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata( :,:,jc))361 WRITE(numout,*) ' - Sum value is ', SUM(pdata( :,:,jc))365 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(nldi:nlei,nldj:nlej,jc)) 366 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(nldi:nlei,nldj:nlej,jc)) 367 WRITE(numout,*) ' - Sum value is ', SUM(pdata(nldi:nlei,nldj:nlej,jc)) 362 368 WRITE(numout,*) '****************' 363 369 ENDIF -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/fldread.F90
r12143 r12706 833 833 834 834 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file 835 REAL(wp), DIMENSION(:,:,:), INTENT(in out) :: pdta_read_z ! depth of the data read in bdy file836 REAL(wp), DIMENSION(:,:,:), INTENT(in out) :: pdta_read_dz ! thickness of the levels in bdy file835 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_z ! depth of the data read in bdy file 836 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_dz ! thickness of the levels in bdy file 837 837 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) 838 838 REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file … … 841 841 INTEGER , INTENT(in ) :: kbdy ! bdy number 842 842 !! 843 INTEGER :: ipi! length of boundary data on local process844 INTEGER :: ipkb! number of vertical levels in boundary data file845 INTEGER :: jb, ji, jj, jk, jkb ! loop counters846 REAL(wp) :: zcoef847 REAL(wp) :: zl, zi, zh ! tmp variable for current depth and interpolation factor848 REAL(wp) :: zfv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(pfv)849 REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf! level and half-level depth843 INTEGER :: ipi ! length of boundary data on local process 844 INTEGER :: ipkb ! number of vertical levels in boundary data file 845 INTEGER :: ipkmax ! number of vertical levels in boundary data file where no mask 846 INTEGER :: jb, ji, jj, jk, jkb ! loop counters 847 REAL(wp) :: zcoef, zi ! 848 REAL(wp) :: ztrans, ztrans_new ! transports 849 REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth 850 850 !!--------------------------------------------------------------------- 851 851 … … 853 853 ipkb = SIZE( pdta_read, 3 ) 854 854 855 zfv_alt = -ABS(pfv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later856 !857 WHERE( pdta_read == pfv )858 pdta_read_z = zfv_alt ! safety: put fillvalue into external depth field so consistent with data859 pdta_read_dz = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct860 ENDWHERE861 862 855 DO jb = 1, ipi 863 856 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 864 857 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 865 zh = SUM(pdta_read_dz(jb,1,:) ) 866 ! 867 ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 858 ! 859 ! --- max jk where input data /= FillValue --- ! 860 ipkmax = 1 861 DO jkb = 2, ipkb 862 IF( pdta_read(jb,1,jkb) /= pfv ) ipkmax = MAX( ipkmax, jkb ) 863 END DO 864 ! 865 ! --- calculate depth at t,u,v points --- ! 868 866 SELECT CASE( kgrd ) 869 CASE(1) 870 IF( ABS( (zh - ht_n(ji,jj)) / ht_n(ji,jj)) * tmask(ji,jj,1) > 0.01_wp ) THEN 871 WRITE(ctmp1,"(I10.10)") jb 872 CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 873 ! IF(lwp) WRITE(numout,*) 'DEPTHT', zh, sum(e3t_n(ji,jj,:), mask=tmask(ji,jj,:)==1), ht_n(ji,jj), jb, jb, ji, jj 874 ENDIF 875 CASE(2) 876 IF( ABS( (zh - hu_n(ji,jj)) * r1_hu_n(ji,jj)) * umask(ji,jj,1) > 0.01_wp ) THEN 877 WRITE(ctmp1,"(I10.10)") jb 878 CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 879 ! IF(lwp) WRITE(numout,*) 'DEPTHU', zh, SUM(e3u_n(ji,jj,:), mask=umask(ji,jj,:)==1), SUM(umask(ji,jj,:)), & 880 ! & hu_n(ji,jj), jb, jb, ji, jj, narea-1, pdta_read(jb,1,:) 881 ENDIF 882 CASE(3) 883 IF( ABS( (zh - hv_n(ji,jj)) * r1_hv_n(ji,jj)) * vmask(ji,jj,1) > 0.01_wp ) THEN 884 WRITE(ctmp1,"(I10.10)") jb 885 CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 886 ENDIF 887 END SELECT 888 ! 889 SELECT CASE( kgrd ) 890 CASE(1) 891 ! depth of T points: 867 CASE(1) ! depth of T points: 892 868 zdepth(:) = gdept_n(ji,jj,:) 893 CASE(2) 894 ! depth of U points: we must not use gdept_n as we don't want to do a communication 895 ! --> copy what is done for gdept_n in domvvl... 869 CASE(2) ! depth of U points: we must not use gdept_n as we don't want to do a communication 870 ! --> copy what is done for gdept_n in domvvl... 896 871 zdhalf(1) = 0.0_wp 897 872 zdepth(1) = 0.5_wp * e3uw_n(ji,jj,1) … … 903 878 zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 904 879 zdhalf(jk) = zdhalf(jk-1) + e3u_n(ji,jj,jk-1) 905 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3uw_n(ji,jj,jk)) &906 & + (1 -zcoef) * ( zdepth(jk-1) + e3uw_n(ji,jj,jk))880 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3uw_n(ji,jj,jk)) & 881 & + (1.-zcoef) * ( zdepth(jk-1) + e3uw_n(ji,jj,jk)) 907 882 END DO 908 CASE(3) 909 ! depth of V points: we must not use gdept_n as we don't want to do a communication 910 ! --> copy what is done for gdept_n in domvvl... 883 CASE(3) ! depth of V points: we must not use gdept_n as we don't want to do a communication 884 ! --> copy what is done for gdept_n in domvvl... 911 885 zdhalf(1) = 0.0_wp 912 886 zdepth(1) = 0.5_wp * e3vw_n(ji,jj,1) … … 918 892 zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 919 893 zdhalf(jk) = zdhalf(jk-1) + e3v_n(ji,jj,jk-1) 920 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3vw_n(ji,jj,jk)) &921 & + (1 -zcoef) * ( zdepth(jk-1) + e3vw_n(ji,jj,jk))894 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3vw_n(ji,jj,jk)) & 895 & + (1.-zcoef) * ( zdepth(jk-1) + e3vw_n(ji,jj,jk)) 922 896 END DO 923 897 END SELECT 924 ! 925 DO jk = 1, jpk926 IF( zdepth(jk) < pdta_read_z(jb,1, 1) ) THEN ! above the first level of external data927 pdta(jb,1,jk) = pdta_read(jb,1,1)928 ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkb) ) THEN ! below the last level of external data929 pdta(jb,1,jk) = pdta_read(jb,1,MAXLOC(pdta_read_z(jb,1,:),1))930 ELSE ! inbetween: vertical interpolation between jkb & jkb+1931 DO jkb = 1, ipkb-1 ! when gdept_n(jkb) < zdepth(jk) < gdept_n(jkb+1)932 IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) <= 0._wp ) &933 & .AND. ( pdta_read_z(jb,1,jkb+1) /= zfv_alt) ) THEN! linear interpolation between 2 levels898 ! 899 ! --- interpolate bdy data on the model grid --- ! 900 DO jk = 1, jpk 901 IF( zdepth(jk) <= pdta_read_z(jb,1,1) ) THEN ! above the first level of external data 902 pdta(jb,1,jk) = pdta_read(jb,1,1) 903 ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkmax) ) THEN ! below the last level of external data /= FillValue 904 pdta(jb,1,jk) = pdta_read(jb,1,ipkmax) 905 ELSE ! inbetween: vertical interpolation between jkb & jkb+1 906 DO jkb = 1, ipkmax-1 907 IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) ) <= 0._wp ) THEN ! linear interpolation between 2 levels 934 908 zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) 935 pdta(jb,1,jk) = pdta_read(jb,1,jkb) + ( pdta_read (jb,1,jkb+1) - pdta_read (jb,1,jkb) ) * zi909 pdta(jb,1,jk) = pdta_read(jb,1,jkb) + zi * ( pdta_read(jb,1,jkb+1) - pdta_read(jb,1,jkb) ) 936 910 ENDIF 937 911 END DO 938 912 ENDIF 939 END DO ! jpk913 END DO 940 914 ! 941 915 END DO ! ipi 942 943 IF(kgrd == 2) THEN ! do we need to adjust the transport term? 916 917 ! --- mask data and adjust transport --- ! 918 SELECT CASE( kgrd ) 919 920 CASE(1) ! mask data (probably unecessary) 944 921 DO jb = 1, ipi 945 922 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 946 923 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 947 zh = SUM(pdta_read_dz(jb,1,:) ) 924 DO jk = 1, jpk 925 pdta(jb,1,jk) = pdta(jb,1,jk) * tmask(ji,jj,jk) 926 END DO 927 END DO 928 929 CASE(2) ! adjust the U-transport term 930 DO jb = 1, ipi 931 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 932 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 948 933 ztrans = 0._wp 934 DO jkb = 1, ipkb ! calculate transport on input grid 935 IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) 936 ENDDO 949 937 ztrans_new = 0._wp 950 DO jkb = 1, ipkb ! calculate transport on input grid951 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb)952 ENDDO953 938 DO jk = 1, jpk ! calculate transport on model grid 954 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3u_n(ji,jj,jk) * umask(ji,jj,jk)939 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) 955 940 ENDDO 956 941 DO jk = 1, jpk ! make transport correction 957 942 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 958 943 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu_n(ji,jj) ) * umask(ji,jj,jk) 959 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero960 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hu_n(ji,jj)* umask(ji,jj,jk)944 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 945 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hu_n(ji,jj) ) * umask(ji,jj,jk) 961 946 ENDIF 962 947 ENDDO 963 948 ENDDO 964 ENDIF 965 966 IF(kgrd == 3) THEN ! do we need to adjust the transport term? 949 950 CASE(3) ! adjust the V-transport term 967 951 DO jb = 1, ipi 968 952 ji = idx_bdy(kbdy)%nbi(jb,kgrd) 969 953 jj = idx_bdy(kbdy)%nbj(jb,kgrd) 970 zh = SUM(pdta_read_dz(jb,1,:) )971 954 ztrans = 0._wp 955 DO jkb = 1, ipkb ! calculate transport on input grid 956 IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) 957 ENDDO 972 958 ztrans_new = 0._wp 973 DO jkb = 1, ipkb ! calculate transport on input grid974 ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb)975 ENDDO976 959 DO jk = 1, jpk ! calculate transport on model grid 977 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk)960 ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 978 961 ENDDO 979 962 DO jk = 1, jpk ! make transport correction 980 963 IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 981 964 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv_n(ji,jj) ) * vmask(ji,jj,jk) 982 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero983 pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hv_n(ji,jj)* vmask(ji,jj,jk)965 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 966 pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hv_n(ji,jj) ) * vmask(ji,jj,jk) 984 967 ENDIF 985 968 ENDDO 986 969 ENDDO 987 END IF988 970 END SELECT 971 989 972 END SUBROUTINE fld_bdy_interp 990 973 991 974 992 975 SUBROUTINE fld_rot( kt, sd ) 993 976 !!--------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbc_oce.F90
r11521 r12706 104 104 !! Ocean Surface Boundary Condition fields 105 105 !!---------------------------------------------------------------------- 106 INTEGER , PUBLIC :: ncpl_qsr_freq !: qsr coupling frequency per days from atmosphere106 INTEGER , PUBLIC :: ncpl_qsr_freq = 0 !: qsr coupling frequency per days from atmosphere (used by top) 107 107 ! 108 108 LOGICAL , PUBLIC :: lhftau = .FALSE. !: HF tau used in TKE: mean(stress module) - module(mean stress) -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcblk.F90
r12143 r12706 801 801 REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) 802 802 REAL(wp), DIMENSION(jpi,jpj) :: zrhoa 803 REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 803 804 !!--------------------------------------------------------------------- 804 805 ! … … 913 914 qtr_ice_top(:,:,:) = 0._wp 914 915 END WHERE 916 ! 917 918 IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN 919 ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) 920 CALL iom_put( 'evap_ao_cea' , ztmp(:,:) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 921 CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * sst_m(:,:) * rcp * tmask(:,:,1) ) ! heat flux from evap (cell average) 922 ENDIF 923 IF( iom_use('hflx_rain_cea') ) THEN 924 ztmp(:,:) = rcp * ( SUM( (ptsu-rt0) * a_i_b, dim=3 ) + sst_m(:,:) * ( 1._wp - at_i_b(:,:) ) ) 925 CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * ztmp(:,:) ) ! heat flux from rain (cell average) 926 ENDIF 927 IF( iom_use('hflx_snow_cea') .OR. iom_use('hflx_snow_ao_cea') .OR. iom_use('hflx_snow_ai_cea') ) THEN 928 WHERE( SUM( a_i_b, dim=3 ) > 1.e-10 ) ; ztmp(:,:) = rcpi * SUM( (ptsu-rt0) * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 929 ELSEWHERE ; ztmp(:,:) = rcp * sst_m(:,:) 930 ENDWHERE 931 ztmp2(:,:) = sprecip(:,:) * ( ztmp(:,:) - rLfus ) 932 CALL iom_put('hflx_snow_cea' , ztmp2(:,:) ) ! heat flux from snow (cell average) 933 CALL iom_put('hflx_snow_ao_cea', ztmp2(:,:) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) 934 CALL iom_put('hflx_snow_ai_cea', ztmp2(:,:) * zsnw(:,:) ) ! heat flux from snow (over ice) 935 ENDIF 915 936 ! 916 937 IF(ln_ctl) THEN -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbccpl.F90
r12143 r12706 574 574 IF ( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = nn_cats_cpl 575 575 576 #if defined key_si3 577 IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN 578 IF( .NOT.srcv(jpr_ts_ice)%laction ) & 579 & CALL ctl_stop( 'sbc_cpl_init: srcv(jpr_ts_ice)%laction should be set to true when ln_cndflx=T' ) 580 ENDIF 581 #endif 576 582 ! ! ------------------------- ! 577 583 ! ! Wave breaking ! … … 863 869 ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN 864 870 CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' ) 865 ssnd(jps_ocx1:jps_ivz1)%clgrid = 'T' ! all oce and ice components on the same unique grid866 871 ENDIF 867 872 ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send … … 1041 1046 ENDIF 1042 1047 xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 1043 !1044 ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' )1045 IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 ) &1046 & CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' )1047 IF( ln_dm2dc .AND. ln_cpl ) ncpl_qsr_freq = 86400 / ncpl_qsr_freq1048 1048 ! 1049 1049 END SUBROUTINE sbc_cpl_init … … 1111 1111 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr 1112 1112 !!---------------------------------------------------------------------- 1113 ! 1114 IF( kt == nit000 ) THEN 1115 ! cannot be done in the init phase when we use agrif as cpl_freq requires that oasis_enddef is done 1116 ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) 1117 IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 ) & 1118 & CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 1119 ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 1120 ENDIF 1113 1121 ! 1114 1122 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) … … 1244 1252 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 1245 1253 ! 1246 ! ! ================== !1247 ! ! ice skin temp. !1248 ! ! ================== !1249 #if defined key_si31250 ! needed by Met Office1251 IF( srcv(jpr_ts_ice)%laction ) THEN1252 WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; tsfc_ice(:,:,:) = 0.01253 ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. ) ; tsfc_ice(:,:,:) = -60.1254 ELSEWHERE ; tsfc_ice(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:)1255 END WHERE1256 ENDIF1257 #endif1258 1254 ! ! ========================= ! 1259 1255 ! ! Mean Sea Level Pressure ! (taum) … … 1635 1631 !! sprecip solid precipitation over the ocean 1636 1632 !!---------------------------------------------------------------------- 1637 REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1]1638 ! !! ! optional arguments, used only in 'mixed oce-ice' case1639 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo1640 REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius]1641 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin]1642 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m]1643 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m]1633 REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] 1634 ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling 1635 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1636 REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1637 REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office 1638 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] 1639 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] 1644 1640 ! 1645 1641 INTEGER :: ji, jj, jl ! dummy loop index … … 1648 1644 REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice 1649 1645 REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1650 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice !!gm , zfrqsr_tr_i1646 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu 1651 1647 !!---------------------------------------------------------------------- 1652 1648 ! … … 1774 1770 IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving 1775 1771 IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs 1776 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1777 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation 1778 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1779 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1780 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1781 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) 1782 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & 1772 CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1773 CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation 1774 IF ( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1775 IF ( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1776 IF ( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1777 IF ( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average) 1778 IF ( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) 1779 IF ( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & 1783 1780 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 1784 1781 ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf … … 1815 1812 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1816 1813 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1817 zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1818 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * ziceld(:,:) & 1819 & + pist(:,:,1) * picefr(:,:) ) ) 1814 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1815 DO jl = 1, jpl 1816 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) & 1817 & + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1818 & + pist(:,:,jl) * picefr(:,:) ) ) 1819 END DO 1820 ELSE 1821 DO jl = 1, jpl 1822 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) & 1823 & + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1824 & + pist(:,:,jl) * picefr(:,:) ) ) 1825 END DO 1826 ENDIF 1820 1827 END SELECT 1821 1828 ! … … 1902 1909 #endif 1903 1910 ! outputs 1904 IF ( srcv(jpr_cal)%laction ) CALL iom_put('hflx_cal_cea' , - frcv(jpr_cal)%z3(:,:,1) * rLfus )! latent heat from calving1905 IF ( srcv(jpr_icb)%laction ) CALL iom_put('hflx_icb_cea' , - frcv(jpr_icb)%z3(:,:,1) * rLfus )! latent heat from icebergs melting1906 IF ( iom_use( 'hflx_rain_cea') ) CALL iom_put('hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ! heat flux from rain (cell average)1907 IF ( iom_use( 'hflx_evap_cea') ) CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1)&1908 & * picefr(:,:) )* zcptn(:,:) * tmask(:,:,1) ) ! heat flux from evap (cell average)1909 IF ( iom_use( 'hflx_snow_cea') ) CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) ! heat flux from snow (cell average)1910 IF ( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) &1911 & * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean)1912 IF ( iom_use('hflx_snow_a i_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) &1913 & * zsnw(:,:) )! heat flux from snow (over ice)1911 IF ( srcv(jpr_cal)%laction ) CALL iom_put('hflx_cal_cea' , - frcv(jpr_cal)%z3(:,:,1) * rLfus ) ! latent heat from calving 1912 IF ( srcv(jpr_icb)%laction ) CALL iom_put('hflx_icb_cea' , - frcv(jpr_icb)%z3(:,:,1) * rLfus ) ! latent heat from icebergs melting 1913 IF ( iom_use( 'hflx_rain_cea') ) CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ! heat flux from rain (cell average) 1914 IF ( iom_use( 'hflx_evap_cea') ) CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) & 1915 & * zcptn(:,:) * tmask(:,:,1) ) ! heat flux from evap (cell average) 1916 IF ( iom_use( 'hflx_prec_cea') ) CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & ! heat flux from all precip (cell avg) 1917 & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) 1918 IF ( iom_use( 'hflx_snow_cea') ) CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) ! heat flux from snow (cell average) 1919 IF ( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) 1920 IF ( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) ! heat flux from snow (over ice) 1914 1921 ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. 1915 1922 ! … … 1929 1936 END DO 1930 1937 ENDIF 1931 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)1932 zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1)1933 1938 CASE( 'oce and ice' ) 1934 1939 zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) … … 1950 1955 ! Create solar heat flux over ice using incoming solar heat flux and albedos 1951 1956 ! ( see OASIS3 user guide, 5th edition, p39 ) 1952 zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) & 1953 & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & 1954 & + palbi (:,:,1) * picefr(:,:) ) ) 1957 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1958 DO jl = 1, jpl 1959 zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:,jl) * ( 1.- palbi(:,:,jl) ) & 1960 & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & 1961 & + palbi (:,:,jl) * picefr(:,:) ) ) 1962 END DO 1963 ELSE 1964 DO jl = 1, jpl 1965 zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:, 1) * ( 1.- palbi(:,:,jl) ) & 1966 & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & 1967 & + palbi (:,:,jl) * picefr(:,:) ) ) 1968 END DO 1969 ENDIF 1955 1970 CASE( 'none' ) ! Not available as for now: needs additional coding 1956 1971 ! ! since fields received, here zqsr_tot, are not defined with none option … … 2012 2027 ! ! ========================= ! 2013 2028 CASE ('coupled') 2014 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) 2015 qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) 2029 IF( ln_mixcpl ) THEN 2030 DO jl=1,jpl 2031 qml_ice(:,:,jl) = qml_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_topm)%z3(:,:,jl) * zmsk(:,:) 2032 qcn_ice(:,:,jl) = qcn_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_botm)%z3(:,:,jl) * zmsk(:,:) 2033 ENDDO 2034 ELSE 2035 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) 2036 qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) 2037 ENDIF 2016 2038 END SELECT 2017 !2018 2039 ! ! ========================= ! 2019 2040 ! ! Transmitted Qsr ! [W/m2] … … 2022 2043 ! 2023 2044 ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2024 ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ! surface transmission parameter(Grenfell Maykut 77)2045 ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ! surface transmission when hi>10cm (Grenfell Maykut 77) 2025 2046 ! 2026 qtr_ice_top(:,:,:) = ztri * qsr_ice(:,:,:) 2027 WHERE( phs(:,:,:) >= 0.0_wp ) qtr_ice_top(:,:,:) = 0._wp ! snow fully opaque 2028 WHERE( phi(:,:,:) <= 0.1_wp ) qtr_ice_top(:,:,:) = qsr_ice(:,:,:) ! thin ice transmits all solar radiation 2047 WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2048 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( ztri + ( 1._wp - ztri ) * ( 1._wp - phi(:,:,:) * 10._wp ) ) 2049 ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2050 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ztri 2051 ELSEWHERE ! zero when hs>0 2052 zqtr_ice_top(:,:,:) = 0._wp 2053 END WHERE 2029 2054 ! 2030 2055 ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! … … 2032 2057 ! ! ===> here we must receive the qtr_ice_top array from the coupler 2033 2058 ! for now just assume zero (fully opaque ice) 2034 qtr_ice_top(:,:,:) = 0._wp 2059 zqtr_ice_top(:,:,:) = 0._wp 2060 ! 2061 ENDIF 2062 ! 2063 IF( ln_mixcpl ) THEN 2064 DO jl=1,jpl 2065 qtr_ice_top(:,:,jl) = qtr_ice_top(:,:,jl) * xcplmask(:,:,0) + zqtr_ice_top(:,:,jl) * zmsk(:,:) 2066 ENDDO 2067 ELSE 2068 qtr_ice_top(:,:,:) = zqtr_ice_top(:,:,:) 2069 ENDIF 2070 ! ! ================== ! 2071 ! ! ice skin temp. ! 2072 ! ! ================== ! 2073 ! needed by Met Office 2074 IF( srcv(jpr_ts_ice)%laction ) THEN 2075 WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; ztsu(:,:,:) = 0. + rt0 2076 ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. ) ; ztsu(:,:,:) = -60. + rt0 2077 ELSEWHERE ; ztsu(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:) + rt0 2078 END WHERE 2079 ! 2080 IF( ln_mixcpl ) THEN 2081 DO jl=1,jpl 2082 pist(:,:,jl) = pist(:,:,jl) * xcplmask(:,:,0) + ztsu(:,:,jl) * zmsk(:,:) 2083 ENDDO 2084 ELSE 2085 pist(:,:,:) = ztsu(:,:,:) 2086 ENDIF 2035 2087 ! 2036 2088 ENDIF … … 2195 2247 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 2196 2248 END SELECT 2197 IF( ssnd(jps_fice)%laction )CALL cpl_snd( jps_fice, isec, ztmp3, info )2249 CALL cpl_snd( jps_fice, isec, ztmp3, info ) 2198 2250 ENDIF 2199 2251 … … 2255 2307 ! ! Ice melt ponds ! 2256 2308 ! ! ------------------------- ! 2257 ! needed by Met Office 2309 ! needed by Met Office: 1) fraction of ponded ice 2) local/actual pond depth 2258 2310 IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 2259 2311 SELECT CASE( sn_snd_mpnd%cldes) … … 2261 2313 SELECT CASE( sn_snd_mpnd%clcat ) 2262 2314 CASE( 'yes' ) 2263 ztmp3(:,:,1:jpl) = a_ip (:,:,1:jpl)2264 ztmp4(:,:,1:jpl) = v_ip(:,:,1:jpl)2315 ztmp3(:,:,1:jpl) = a_ip_frac(:,:,1:jpl) 2316 ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) 2265 2317 CASE( 'no' ) 2266 2318 ztmp3(:,:,:) = 0.0 2267 2319 ztmp4(:,:,:) = 0.0 2268 2320 DO jl=1,jpl 2269 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip (:,:,jpl)2270 ztmp4(:,:,1) = ztmp4(:,:,1) + v_ip(:,:,jpl)2321 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2322 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2271 2323 ENDDO 2272 2324 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) … … 2306 2358 ! ! CO2 flux from PISCES ! 2307 2359 ! ! ------------------------- ! 2308 IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) CALL cpl_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info ) 2360 IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN 2361 ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s 2362 CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info ) 2363 ENDIF 2309 2364 ! 2310 2365 ! ! ------------------------- ! -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcmod.F90
r12143 r12706 236 236 #endif 237 237 ! 238 ! 239 IF( sbc_ssr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_ssr arrays' ) 240 IF( .NOT.ln_ssr ) THEN !* Initialize qrp and erp if no restoring 241 qrp(:,:) = 0._wp 242 erp(:,:) = 0._wp 243 ENDIF 244 ! 245 238 246 IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero 239 247 IF( nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case … … 536 544 CALL iom_put( "taum" , taum ) ! wind stress module 537 545 CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice 546 CALL iom_put( "qrp", qrp ) ! heat flux damping 547 CALL iom_put( "erp", erp ) ! freshwater flux damping 538 548 ENDIF 539 549 ! -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcrnf.F90
r12143 r12706 20 20 USE sbc_oce ! surface boundary condition variables 21 21 USE eosbn2 ! Equation Of State 22 USE closea 22 USE closea, ONLY: l_clo_rnf, clo_rnf ! closed seas 23 23 ! 24 24 USE in_out_manager ! I/O manager … … 42 42 REAL(wp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) 43 43 INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) 44 LOGICAL :: ln_rnf_icb !: iceberg flux is specified in a file 44 45 LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file 45 46 LOGICAL , PUBLIC :: ln_rnf_sal !: salinity river runoffs attribute specified in a file 46 47 TYPE(FLD_N) , PUBLIC :: sn_rnf !: information about the runoff file to be read 47 48 TYPE(FLD_N) :: sn_cnf !: information about the runoff mouth file to be read 49 TYPE(FLD_N) :: sn_i_rnf !: information about the iceberg flux file to be read 48 50 TYPE(FLD_N) :: sn_s_rnf !: information about the salinities of runoff file to be read 49 51 TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read … … 64 66 65 67 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) 68 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) 66 69 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) 67 70 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) … … 111 114 ! !-------------------! 112 115 ! 113 IF( .NOT. l_rnfcpl ) CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt 116 ! 117 IF( .NOT. l_rnfcpl ) THEN 118 CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) 119 IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required 120 ENDIF 114 121 IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required 115 122 IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required … … 117 124 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 118 125 ! 119 IF( .NOT. l_rnfcpl ) rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt 126 IF( .NOT. l_rnfcpl ) THEN 127 rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt 128 IF( ln_rnf_icb ) THEN 129 fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt 130 CALL iom_put( 'iceberg_cea' , fwficb(:,:) ) ! output iceberg flux 131 CALL iom_put( 'hflx_icb_cea' , fwficb(:,:) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> 132 ENDIF 133 ENDIF 120 134 ! 121 135 ! ! set temperature & salinity content of runoffs … … 128 142 ELSE ! use SST as runoffs temperature 129 143 !CEOD River is fresh water so must at least be 0 unless we consider ice 130 rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:),0.0_wp) * rnf(:,:) * r1_rau0144 rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rau0 131 145 ENDIF 132 146 ! ! use runoffs salinity data 133 147 IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 134 148 ! ! else use S=0 for runoffs (done one for all in the init) 135 IF( iom_use('runoffs') )CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux149 CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux 136 150 IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rau0 * rcp ) ! output runoff sensible heat (W/m2) 137 151 ENDIF … … 238 252 REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl 239 253 !! 240 NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, &241 & sn_rnf, sn_cnf , sn_ s_rnf , sn_t_rnf , sn_dep_rnf, &254 NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & 255 & sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, & 242 256 & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact, & 243 257 & ln_rnf_depth_ini , rn_dep_max , rn_rnf_max, nn_rnf_depth_file … … 261 275 ! ! ============ 262 276 ! 263 REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs277 REWIND( numnam_ref ) 264 278 READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) 265 279 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) 266 280 267 REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs281 REWIND( numnam_cfg ) 268 282 READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) 269 283 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) … … 295 309 IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) 296 310 CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print ) 311 ! 312 IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure 313 IF(lwp) WRITE(numout,*) 314 IF(lwp) WRITE(numout,*) ' iceberg flux read in a file' 315 ALLOCATE( sf_i_rnf(1), STAT=ierror ) 316 IF( ierror > 0 ) THEN 317 CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN 318 ENDIF 319 ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) ) 320 IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) ) 321 CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' ) 322 ELSE 323 fwficb(:,:) = 0._wp 324 ENDIF 325 297 326 ENDIF 298 327 ! … … 337 366 IF( h_rnf(ji,jj) > 0._wp ) THEN 338 367 jk = 2 339 DO WHILE ( jk /=mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1368 DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 340 369 END DO 341 370 nk_rnf(ji,jj) = jk … … 394 423 IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 395 424 jk = 2 396 DO WHILE ( jk /=mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1425 DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 397 426 END DO 398 427 nk_rnf(ji,jj) = jk … … 435 464 ! ! - mixed upstream-centered (ln_traadv_cen2=T) 436 465 ! 437 IF 466 IF( ln_rnf_depth ) CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already', & 438 467 & 'be spread through depth by ln_rnf_depth' ) 439 468 ! -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/SBC/sbcssr.F90
r12143 r12706 30 30 PUBLIC sbc_ssr ! routine called in sbcmod 31 31 PUBLIC sbc_ssr_init ! routine called in sbcmod 32 PUBLIC sbc_ssr_alloc ! routine called in sbcmod 32 33 33 34 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] 34 35 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2] 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: coefice !: under ice relaxation coefficient 35 37 36 38 ! !!* Namelist namsbc_ssr * … … 41 43 LOGICAL :: ln_sssr_bnd ! flag to bound erp term 42 44 REAL(wp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day] 45 INTEGER :: nn_sssr_ice ! Control of restoring under ice 43 46 44 47 REAL(wp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange … … 97 100 END DO 98 101 END DO 99 CALL iom_put( "qrp", qrp ) ! heat flux damping 102 ENDIF 103 ! 104 IF( nn_sssr /= 0 .AND. nn_sssr_ice /= 1 ) THEN 105 ! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_sssr_ice .ne. 1 106 ! n.b. coefice is initialised and fixed to 1._wp if nn_sssr_ice = 1 107 DO jj = 1, jpj 108 DO ji = 1, jpi 109 SELECT CASE ( nn_sssr_ice ) 110 CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice 111 CASE DEFAULT ; coefice(ji,jj) = 1._wp + ( nn_sssr_ice - 1 ) * fr_i(ji,jj) ! reinforced damping (x nn_sssr_ice) under ice ) 112 END SELECT 113 END DO 114 END DO 100 115 ENDIF 101 116 ! … … 105 120 DO ji = 1, jpi 106 121 zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths 122 & * coefice(ji,jj) & ! Optional control of damping under sea-ice 107 123 & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) 108 124 sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux … … 110 126 END DO 111 127 END DO 112 CALL iom_put( "erp", erp ) ! freshwater flux damping113 128 ! 114 129 ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns) … … 118 133 DO ji = 1, jpi 119 134 zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths 135 & * coefice(ji,jj) & ! Optional control of damping under sea-ice 120 136 & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) & 121 137 & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1) … … 126 142 END DO 127 143 END DO 128 CALL iom_put( "erp", erp ) ! freshwater flux damping129 144 ENDIF 130 145 ! … … 154 169 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 155 170 TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read 156 NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd 171 NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, & 172 & sn_sss, ln_sssr_bnd, rn_sssr_bnd, nn_sssr_ice 157 173 INTEGER :: ios 158 174 !!---------------------------------------------------------------------- … … 182 198 WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd 183 199 WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day' 184 ENDIF185 !186 ! !* Allocate erp and qrp array187 ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )188 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )200 WRITE(numout,*) ' Cntrl of surface restoration under ice nn_sssr_ice = ', nn_sssr_ice 201 WRITE(numout,*) ' ( 0 = no restoration under ice)' 202 WRITE(numout,*) ' ( 1 = restoration everywhere )' 203 WRITE(numout,*) ' (>1 = enhanced restoration under ice )' 204 ENDIF 189 205 ! 190 206 IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays … … 216 232 ENDIF 217 233 ! 234 coefice(:,:) = 1._wp ! Initialise coefice to 1._wp ; will not need to be changed if nn_sssr_ice=1 218 235 ! !* Initialize qrp and erp if no restoring 219 236 IF( nn_sstr /= 1 ) qrp(:,:) = 0._wp … … 221 238 ! 222 239 END SUBROUTINE sbc_ssr_init 240 241 INTEGER FUNCTION sbc_ssr_alloc() 242 !!---------------------------------------------------------------------- 243 !! *** FUNCTION sbc_ssr_alloc *** 244 !!---------------------------------------------------------------------- 245 sbc_ssr_alloc = 0 ! set to zero if no array to be allocated 246 IF( .NOT. ALLOCATED( erp ) ) THEN 247 ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc ) 248 ! 249 IF( lk_mpp ) CALL mpp_sum ( 'sbcssr', sbc_ssr_alloc ) 250 IF( sbc_ssr_alloc /= 0 ) CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.') 251 ! 252 ENDIF 253 END FUNCTION 223 254 224 255 !!====================================================================== -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/TRA/trabbc.F90
r12143 r12706 100 100 ENDIF 101 101 ! 102 CALL iom_put ( "hfgeou" , rau0_rcp * qgh_trd0(:,:) ) 103 ! 102 104 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 103 105 ! … … 133 135 !!---------------------------------------------------------------------- 134 136 ! 135 REWIND( numnam_ref ) ! Namelist nambbc in reference namelist : Bottom momentum boundary condition137 REWIND( numnam_ref ) 136 138 READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 137 139 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 138 140 ! 139 REWIND( numnam_cfg ) ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition141 REWIND( numnam_cfg ) 140 142 READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 141 143 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/TRA/tranxt.F90
r12167 r12706 267 267 INTEGER :: ji, jj, jk, jn ! dummy loop indices 268 268 REAL(wp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar 269 REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d 269 REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - - 270 270 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf 271 271 !!---------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/nemogcm.F90
r12143 r12706 73 73 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) 74 74 USE crsini ! initialise grid coarsening utility 75 USE diatmb ! Top,middle,bottom output76 75 USE dia25h ! 25h mean output 77 76 USE sbc_oce , ONLY : lk_oasis … … 489 488 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends 490 489 CALL dia_obs_init ! Initialize observational data 491 CALL dia_tmb_init ! TMB outputs492 490 CALL dia_25h_init ! 25h mean outputs 493 491 CALL dia_harm_init ! tidal harmonics outputs -
NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/step.F90
r12143 r12706 155 155 IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp ) ! and/or eiv coeff. 156 156 IF( l_ldfdyn_time ) CALL ldf_dyn( kstp ) ! eddy viscosity coeff. 157 158 157 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 159 158 ! Ocean dynamics : hdiv, ssh, e3, u, v, w … … 189 188 IF(.NOT.ln_linssh) CALL dom_vvl_sf_nxt( kstp, kcall=2 ) ! after vertical scale factors (update depth average component) 190 189 ENDIF 191 CALL dyn_zdf ( kstp ) ! vertical diffusion 192 193 IF( ln_dynspg_ts ) THEN 190 CALL dyn_zdf ( kstp ) ! vertical diffusion 191 IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated 194 192 CALL wzv ( kstp ) ! now cross-level velocity 195 193 IF( ln_zad_Aimp ) CALL wAimp ( kstp ) ! Adaptive-implicit vertical advection partitioning 196 194 ENDIF 195 197 196 198 197 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 206 205 IF( ln_floats ) CALL flo_stp ( kstp ) ! drifting Floats 207 206 IF( ln_diacfl ) CALL dia_cfl ( kstp ) ! Courant number diagnostics 208 IF( lk_diahth )CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth)207 CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth) 209 208 IF( ln_diadct ) CALL dia_dct ( kstp ) ! Transports 210 209 CALL dia_ar5 ( kstp ) ! ar5 diag 210 IF( ln_diaptr ) CALL dia_ptr ! Poleward adv/ldf TRansports diagnostics 211 211 IF( ln_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 212 212 CALL dia_wri ( kstp ) ! ocean model: outputs … … 245 245 CALL tra_ldf ( kstp ) ! lateral mixing 246 246 247 !!gm : why CALL to dia_ptr has been moved here??? (use trends info?)248 IF( ln_diaptr ) CALL dia_ptr ! Poleward adv/ldf TRansports diagnostics249 !!gm250 247 CALL tra_zdf ( kstp ) ! vertical mixing and after tracer fields 251 248 IF( ln_zdfnpc ) CALL tra_npc ( kstp ) ! update after fields by non-penetrative convection
Note: See TracChangeset
for help on using the changeset viewer.