Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • nemo/nemo
  • sparonuz/nemo
  • hatfield/nemo
  • extdevs/nemo
4 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 249 additions and 232 deletions
src/TOP/PISCES/sms_pisces.F90
View file @ c2b6c44e
......@@ -124,6 +124,8 @@ MODULE sms_pisces
LOGICAL, SAVE :: lk_sed
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
!! $Id: sms_pisces.F90 15459 2021-10-29 08:19:18Z cetlod $
......@@ -140,52 +142,52 @@ CONTAINS
!!----------------------------------------------------------------------
ierr(:) = 0
!* Biological fluxes for light : shared variables for pisces & lobster
ALLOCATE( xksi(jpi,jpj), strn(jpi,jpj), STAT=ierr(1) )
ALLOCATE( xksi(A2D(0)), strn(A2D(0)), STAT=ierr(1) )
IF( ln_p4z .OR. ln_p5z ) THEN
!* Optics
ALLOCATE( enano(jpi,jpj,jpk) , ediat(jpi,jpj,jpk) , &
& enanom(jpi,jpj,jpk), ediatm(jpi,jpj,jpk), &
& emoy(jpi,jpj,jpk) , etotm(jpi,jpj,jpk), STAT=ierr(2) )
ALLOCATE( enano(A2D(0),jpk) , ediat(A2D(0),jpk) , &
& enanom(A2D(0),jpk), ediatm(A2D(0),jpk), &
& emoy(A2D(0),jpk) , etotm(A2D(0),jpk), STAT=ierr(2) )
!* Biological SMS
ALLOCATE( xksimax(jpi,jpj) , biron(jpi,jpj,jpk) , STAT=ierr(3) )
ALLOCATE( xksimax(A2D(0)) , biron(A2D(0),jpk) , STAT=ierr(3) )
! Biological SMS
ALLOCATE( xfracal (jpi,jpj,jpk), orem (jpi,jpj,jpk), &
& nitrfac (jpi,jpj,jpk), nitrfac2(jpi,jpj,jpk), &
& prodcal (jpi,jpj,jpk), xdiss (jpi,jpj,jpk), &
& prodpoc (jpi,jpj,jpk), conspoc (jpi,jpj,jpk), &
& prodgoc (jpi,jpj,jpk), consgoc (jpi,jpj,jpk), &
& blim (jpi,jpj,jpk), consfe3 (jpi,jpj,jpk), &
& xfecolagg(jpi,jpj,jpk), xcoagfe (jpi,jpj,jpk), STAT=ierr(4) )
ALLOCATE( xfracal (A2D(0),jpk), orem (A2D(0),jpk), &
& nitrfac (A2D(0),jpk), nitrfac2(A2D(0),jpk), &
& prodcal (A2D(0),jpk), xdiss (A2D(0),jpk), &
& prodpoc (A2D(0),jpk), conspoc (A2D(0),jpk), &
& prodgoc (A2D(0),jpk), consgoc (A2D(0),jpk), &
& blim (A2D(0),jpk), consfe3 (A2D(0),jpk), &
& xfecolagg(A2D(0),jpk), xcoagfe (A2D(0),jpk), STAT=ierr(4) )
!* Carbonate chemistry
ALLOCATE( ak13 (jpi,jpj,jpk) , &
& ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , &
& hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , &
& aphscale(jpi,jpj,jpk), STAT=ierr(5) )
ALLOCATE( ak13(A2D(0),jpk), &
& ak23(A2D(0),jpk), aksp (A2D(0),jpk) , &
& hi (A2D(0),jpk), excess(A2D(0),jpk) , &
& aphscale(A2D(0),jpk), STAT=ierr(5) )
!
!* Temperature dependency of SMS terms
ALLOCATE( tgfunc (jpi,jpj,jpk) , tgfunc2(jpi,jpj,jpk), STAT=ierr(6) )
ALLOCATE( tgfunc (A2D(0),jpk) , tgfunc2(A2D(0),jpk), STAT=ierr(6) )
!
!* Sinking speed
ALLOCATE( wsbio3 (jpi,jpj,jpk) , wsbio4 (jpi,jpj,jpk), STAT=ierr(7) )
ALLOCATE( wsbio3 (A2D(0),jpk) , wsbio4 (A2D(0),jpk), STAT=ierr(7) )
!* Size of phytoplankton cells
ALLOCATE( sizen (jpi,jpj,jpk), sized (jpi,jpj,jpk), &
& sizena(jpi,jpj,jpk), sizeda(jpi,jpj,jpk), STAT=ierr(8) )
ALLOCATE( sizen (A2D(0),jpk), sized (A2D(0),jpk), &
& sizena(A2D(0),jpk), sizeda(A2D(0),jpk), STAT=ierr(8) )
!
ALLOCATE( plig(jpi,jpj,jpk) , STAT=ierr(9) )
ALLOCATE( plig(A2D(0),jpk) , STAT=ierr(9) )
ENDIF
!
IF( ln_p5z ) THEN
! PISCES-QUOTA specific part
ALLOCATE( epico(jpi,jpj,jpk) , epicom(jpi,jpj,jpk) , STAT=ierr(10) )
ALLOCATE( epico(A2D(0),jpk) , epicom(A2D(0),jpk) , STAT=ierr(10) )
!* Size of phytoplankton cells
ALLOCATE( sizep(jpi,jpj,jpk), sizepa(jpi,jpj,jpk), STAT=ierr(11) )
ALLOCATE( sizep(A2D(0),jpk), sizepa(A2D(0),jpk), STAT=ierr(11) )
ENDIF
!
sms_pisces_alloc = MAXVAL( ierr )
......
src/TOP/PISCES/trcice_pisces.F90
View file @ c2b6c44e
......@@ -19,6 +19,8 @@ MODULE trcice_pisces
PUBLIC trc_ice_ini_pisces ! called by trcini.F90 module
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
!! $Id: trcice_pisces.F90 10794 2019-03-22 09:25:28Z cetlod $
......@@ -283,15 +285,15 @@ CONTAINS
ENDIF
!
DO jn = jp_pcs0, jp_pcs1
IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1) ! Global case
IF( cn_trc_o(jn) == 'GL ' ) trc_o(A2D(0),jn) = zpisc(jn,1) ! Global case
IF( cn_trc_o(jn) == 'AA ' ) THEN
WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic
WHERE( gphit(:,:) < 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic
WHERE( gphit(A2D(0)) >= 0._wp ) ; trc_o(A2D(0),jn) = zpisc(jn,2) ; END WHERE ! Arctic
WHERE( gphit(A2D(0)) < 0._wp ) ; trc_o(A2D(0),jn) = zpisc(jn,3) ; END WHERE ! Antarctic
ENDIF
IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN ! Baltic Sea particular case for ORCA configurations
WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. &
54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp )
trc_o(:,:,jn) = zpisc(jn,4)
WHERE( 14._wp <= glamt(A2D(0)) .AND. glamt(A2D(0)) <= 32._wp .AND. &
54._wp <= gphit(A2D(0)) .AND. gphit(A2D(0)) <= 66._wp )
trc_o(A2D(0),jn) = zpisc(jn,4)
END WHERE
ENDIF
ENDDO
......@@ -321,16 +323,16 @@ CONTAINS
DO jn = jp_pcs0, jp_pcs1
!-- Everywhere but in the Baltic
IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron)
trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn)
trc_i(A2D(0),jn) = zratio(jn,1) * trc_o(A2D(0),jn)
ELSE ! prescribed concentration
trc_i(:,:,jn) = trc_ice_prescr(jn)
trc_i(A2D(0),jn) = trc_ice_prescr(jn)
ENDIF
!-- Baltic
IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN
IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron)
WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. &
54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp )
trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn)
WHERE( 14._wp <= glamt(A2D(0)) .AND. glamt(A2D(0)) <= 32._wp .AND. &
54._wp <= gphit(A2D(0)) .AND. gphit(A2D(0)) <= 66._wp )
trc_i(A2D(0),jn) = zratio(jn,2) * trc_o(A2D(0),jn)
END WHERE
ENDIF
ENDIF
......
src/TOP/PISCES/trcini_pisces.F90
View file @ c2b6c44e
......@@ -123,7 +123,6 @@ CONTAINS
ELSE
! PISCES-QUOTA part
ierr = ierr + p5z_lim_alloc()
ierr = ierr + p5z_prod_alloc()
ierr = ierr + p5z_meso_alloc()
ENDIF
ierr = ierr + p4z_rem_alloc()
......
src/TOP/PISCES/trcwri_pisces.F90
View file @ c2b6c44e
......@@ -38,7 +38,7 @@ CONTAINS
CHARACTER (len=20) :: cltra
REAL(wp) :: zfact
INTEGER :: ji, jj, jk, jn
REAL(wp), DIMENSION(jpi,jpj) :: zdic, zo2min, zdepo2min
REAL(wp), DIMENSION(A2D(0)) :: zdic, zo2min, zdepo2min
!!---------------------------------------------------------------------
! write the tracer concentrations in the file
......@@ -60,15 +60,19 @@ CONTAINS
IF( iom_use( "INTDIC" ) ) THEN ! DIC content in kg/m2
zdic(:,:) = 0.
DO jk = 1, jpkm1
zdic(:,:) = zdic(:,:) + tr(:,:,jk,jpdic,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) * 12.
DO_2D( 0, 0, 0, 0 )
zdic(ji,jj) = zdic(ji,jj) + tr(ji,jj,jk,jpdic,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * 12.
END_2D
ENDDO
CALL iom_put( 'INTDIC', zdic )
CALL iom_put( 'INTDIC', zdic )
ENDIF
!
IF( iom_use( "O2MIN" ) .OR. iom_use ( "ZO2MIN" ) ) THEN ! Oxygen minimum concentration and depth
zo2min (:,:) = tr(:,:,1,jpoxy,Kmm) * tmask(:,:,1)
zdepo2min(:,:) = gdepw(:,:,1,Kmm) * tmask(:,:,1)
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
IF( iom_use( "O2MIN" ) .OR. iom_use ( "ZO2MIN" ) ) THEN ! Oxygen minimum concentration and depth
DO_2D( 0, 0, 0, 0 )
zo2min (ji,jj) = tr(ji,jj,1,jpoxy,Kmm) * tmask(ji,jj,1)
zdepo2min(ji,jj) = gdepw(ji,jj,1,Kmm) * tmask(ji,jj,1)
END_2D
DO_3D( 0, 0, 0, 0, 2, jpkm1 )
IF( tmask(ji,jj,jk) == 1 ) then
IF( tr(ji,jj,jk,jpoxy,Kmm) < zo2min(ji,jj) ) then
zo2min (ji,jj) = tr(ji,jj,jk,jpoxy,Kmm)
......
src/TOP/TRP/trcadv.F90
View file @ c2b6c44e
......@@ -8,6 +8,7 @@ MODULE trcadv
!! 3.7 ! 2014-05 (G. Madec, C. Ethe) Add 2nd/4th order cases for CEN and FCT schemes
!! 4.0 ! 2017-09 (G. Madec) remove vertical time-splitting option
!! 4.5 ! 2021-08 (G. Madec, S. Techene) add advective velocities as optional arguments
!! - ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
#if defined key_top
!!----------------------------------------------------------------------
......@@ -123,19 +124,19 @@ CONTAINS
!
IF( ln_wave .AND. ln_sdw ) THEN
DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! eulerian transport + Stokes Drift
zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( zptu(ji,jj,jk) + usd(ji,jj,jk) )
zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( zptv(ji,jj,jk) + vsd(ji,jj,jk) )
zuu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * ( zptu(ji,jj,jk) + usd(ji,jj,jk) )
zvv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * ( zptv(ji,jj,jk) + vsd(ji,jj,jk) )
END_3D
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
zww(ji,jj,jk) = e1e2t(ji,jj) * ( zptw(ji,jj,jk) + wsd(ji,jj,jk) )
zww(ji,jj,jk) = e1e2t(ji,jj) * ( zptw(ji,jj,jk) + wsd(ji,jj,jk) )
END_3D
ELSE
DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * zptu(ji,jj,jk) ! eulerian transport
zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * zptv(ji,jj,jk)
zuu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zptu(ji,jj,jk) ! eulerian transport
zvv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zptv(ji,jj,jk)
END_3D
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
zww(ji,jj,jk) = e1e2t(ji,jj) * zptw(ji,jj,jk)
zww(ji,jj,jk) = e1e2t(ji,jj) * zptw(ji,jj,jk)
END_3D
ENDIF
!
......@@ -156,11 +157,19 @@ CONTAINS
SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==!
!
CASE ( np_CEN ) ! Centered : 2nd / 4th order
CALL tra_adv_cen ( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v )
IF( nn_hls == 1 ) THEN
CALL tra_adv_cen_hls1( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v )
ELSE
CALL tra_adv_cen ( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v )
ENDIF
CASE ( np_FCT ) ! FCT : 2nd / 4th order
CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v )
CASE ( np_MUS ) ! MUSCL
IF( nn_hls == 1 ) THEN
CALL tra_adv_mus_hls1( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )
ELSE
CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )
ENDIF
CASE ( np_UBS ) ! UBS
CALL tra_adv_ubs ( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v )
CASE ( np_QCK ) ! QUICKEST
......
src/TOP/TRP/trcdmp.F90
View file @ c2b6c44e
......@@ -57,7 +57,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE trc_dmp_alloc ***
!!----------------------------------------------------------------------
ALLOCATE( restotr(jpi,jpj,jpk) , STAT=trc_dmp_alloc )
ALLOCATE( restotr(A2D(0),jpk) , STAT=trc_dmp_alloc )
!
IF( trc_dmp_alloc /= 0 ) CALL ctl_warn('trc_dmp_alloc: failed to allocate array')
!
......@@ -329,11 +329,11 @@ CONTAINS
! convert the position in local domain indices
! --------------------------------------------
DO jc = 1, npncts
nctsi1(jc) = mi0( nctsi1(jc) )
nctsj1(jc) = mj0( nctsj1(jc) )
nctsi1(jc) = mi0( nctsi1(jc), nn_hls )
nctsj1(jc) = mj0( nctsj1(jc), nn_hls )
!
nctsi2(jc) = mi1( nctsi2(jc) )
nctsj2(jc) = mj1( nctsj2(jc) )
nctsi2(jc) = mi1( nctsi2(jc), nn_hls )
nctsj2(jc) = mj1( nctsj2(jc), nn_hls )
END DO
!
ENDIF
......
src/TOP/TRP/trcsbc.F90
View file @ c2b6c44e
......@@ -115,14 +115,14 @@ CONTAINS
CASE ( -1 ) ! ! No tracers in sea ice ( trc_i = 0 )
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = 0._wp
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
......@@ -131,14 +131,14 @@ CONTAINS
CASE ( 0 ) ! Same concentration in sea ice and in the ocean ( trc_i = ptr(...,Kmm) )
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = - fmmflx(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
......@@ -147,21 +147,21 @@ CONTAINS
CASE ( 1 ) ! Specific treatment of sea ice fluxes with an imposed concentration in sea ice
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = - fmmflx(ji,jj) * r1_rho0 * trc_i(ji,jj,jn)
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
ENDIF
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
zse3t = rDt_trc / e3t(ji,jj,1,Kmm)
zdtra = ptr(ji,jj,1,jn,Kmm) + sbc_trc(ji,jj,jn) * zse3t
IF( zdtra < 0. ) sbc_trc(ji,jj,jn) = MAX( zdtra, -ptr(ji,jj,1,jn,Kmm) / zse3t ) ! avoid negative concentration that can occurs if trc_i > ptr
......@@ -176,7 +176,7 @@ CONTAINS
!
IF( l_trdtrc ) ztrtrd(:,:,:) = ptr(:,:,:,jn,Krhs) ! save trends
!
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
zse3t = zfact / e3t(ji,jj,1,Kmm)
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + ( sbc_trc_b(ji,jj,jn) + sbc_trc(ji,jj,jn) ) * zse3t
END_2D
......@@ -295,7 +295,7 @@ CONTAINS
CASE ( 0 ) ! Same concentration in sea ice and in the ocean fmm contribution to concentration/dilution effect has to be removed
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
z1_rho0_e3t = r1_rho0 / e3t(ji,jj,1,Kmm)
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + ( emp(ji,jj) - fmmflx(ji,jj) ) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
......@@ -331,7 +331,7 @@ CONTAINS
CASE ( 0 ) ! Same concentration in sea ice and in the ocean : correct concentration/dilution effect due to "freezing - melting"
!
DO jn = 1, jptra
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
z1_rho0_e3t = r1_rho0 / e3t(ji,jj,1,Kmm)
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) - fmmflx(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
......
src/TOP/TRP/trcsink.F90
View file @ c2b6c44e
......@@ -50,12 +50,12 @@ CONTAINS
INTEGER , INTENT(in) :: Kbb, Kmm
INTEGER , INTENT(in) :: jp_tra ! tracer index index
REAL(wp), INTENT(in) :: rsfact ! time step duration
REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pwsink
REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx
REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpk) :: pwsink
REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpk) :: psinkflx
INTEGER :: ji, jj, jk
INTEGER, DIMENSION(jpi, jpj) :: iiter
INTEGER, DIMENSION(A2D(0)) :: iiter
REAL(wp) :: zfact, zwsmax, zmax
REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwsink
REAL(wp), DIMENSION(A2D(0),jpk) :: zwsink
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_sink')
......@@ -73,7 +73,7 @@ CONTAINS
IF( nitermax == 1 ) THEN
iiter(:,:) = 1
ELSE
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
iiter(ji,jj) = 1
DO jk = 1, jpkm1
IF( tmask(ji,jj,jk) == 1.0 ) THEN
......@@ -85,7 +85,7 @@ CONTAINS
iiter(:,:) = MIN( iiter(:,:), nitermax )
ENDIF
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( tmask(ji,jj,jk) == 1.0 ) THEN
zwsmax = 0.5 * e3t(ji,jj,jk,Kmm) * rday / rsfact
zwsink(ji,jj,jk) = MIN( pwsink(ji,jj,jk), zwsmax * REAL( iiter(ji,jj), wp ) )
......@@ -121,23 +121,25 @@ CONTAINS
INTEGER, INTENT(in ) :: Kbb, Kmm ! time level indices
INTEGER, INTENT(in ) :: jp_tra ! tracer index index
REAL(wp), INTENT(in ) :: rsfact ! duration of time step
INTEGER, INTENT(in ), DIMENSION(jpi,jpj) :: kiter ! number of iterations for time-splitting
REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pwsink ! sinking speed
REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx ! sinking fluxe
INTEGER, INTENT(in ), DIMENSION(A2D(0)) :: kiter ! number of iterations for time-splitting
REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpk) :: pwsink ! sinking speed
REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpk) :: psinkflx ! sinking fluxe
!
INTEGER :: ji, jj, jk, jn, jt
REAL(wp) :: zigma,zew,zign, zflx, zstep
REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztraz, zakz, zwsink2, ztrb, psinking
REAL(wp), DIMENSION(A2D(0),jpk) :: ztraz, zakz, zwsink2, ztrb, psinking
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_sink2')
!
DO jk = 1, jpkm1
zwsink2(:,:,jk+1) = -pwsink(:,:,jk) / rday * tmask(:,:,jk+1)
END DO
zwsink2(:,:,1) = 0.e0
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zwsink2(ji,jj,jk+1) = -pwsink(ji,jj,jk) / rday * tmask(ji,jj,jk+1)
END_3D
DO_2D( 0, 0, 0, 0 )
zwsink2(ji,jj,1) = 0.e0
END_2D
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
! Vertical advective flux
zstep = rsfact / REAL( kiter(ji,jj), wp ) / 2.
DO jt = 1, kiter(ji,jj)
......
src/TOP/TRP/trczdf.F90
View file @ c2b6c44e
......@@ -53,7 +53,7 @@ CONTAINS
!
IF( l_trdtrc ) ztrtrd(:,:,:,:) = ptr(:,:,:,:,Krhs)
!
CALL tra_zdf_imp( kt, nittrc000, 'TRC', rDt_trc, Kbb, Kmm, Krhs, ptr, Kaa, jptra ) ! implicit scheme
CALL tra_zdf_imp( 'TRC', Kbb, Kmm, Krhs, ptr, Kaa, jptra ) ! implicit scheme
!
IF( l_trdtrc ) THEN ! save the vertical diffusive trends for further diagnostics
DO jn = 1, jptra
......
src/TOP/trc.F90
View file @ c2b6c44e
......@@ -158,19 +158,19 @@ CONTAINS
!!-------------------------------------------------------------------
ierr(:) = 0
!
ALLOCATE( tr(jpi,jpj,jpk,jptra,jpt) , &
& trc_i(jpi,jpj,jptra) , trc_o(jpi,jpj,jptra) , &
& gtru (jpi,jpj,jptra) , gtrv (jpi,jpj,jptra) , &
& gtrui(jpi,jpj,jptra) , gtrvi(jpi,jpj,jptra) , &
& trc_ice_ratio(jptra) , trc_ice_prescr(jptra) , cn_trc_o(jptra) , &
& neln(jpi,jpj) , heup(jpi,jpj) , heup_01(jpi,jpj) , &
& etot(jpi,jpj,jpk) , etot_ndcy(jpi,jpj,jpk) , &
& sbc_trc_b(jpi,jpj,jptra), sbc_trc(jpi,jpj,jptra) , &
& cvol(jpi,jpj,jpk) , trai(jptra) , &
& ctrcnm(jptra) , ctrcln(jptra) , ctrcun(jptra) , &
& ln_trc_ini(jptra) , &
& ln_trc_sbc(jptra) , ln_trc_cbc(jptra) , ln_trc_obc(jptra) , &
& ln_trc_ais(jptra) , &
ALLOCATE( tr(jpi,jpj,jpk,jptra,jpt) , &
& gtru (jpi,jpj,jptra) , gtrv (jpi,jpj,jptra) , &
& gtrui(jpi,jpj,jptra) , gtrvi(jpi,jpj,jptra) , &
& trc_i(A2D(0),jptra) , trc_o(A2D(0),jptra) , &
& trc_ice_ratio(jptra) , trc_ice_prescr(jptra) , cn_trc_o(jptra) , &
& neln(A2D(0)) , heup(A2D(0)) , heup_01(A2D(0)) , &
& etot(A2D(0),jpk) , etot_ndcy(A2D(0),jpk) , &
& sbc_trc_b(A2D(0),jptra), sbc_trc(A2D(0),jptra) , &
& cvol(jpi,jpj,jpk) , trai(jptra) , &
& ctrcnm(jptra) , ctrcln(jptra) , ctrcun(jptra) , &
& ln_trc_ini(jptra) , &
& ln_trc_sbc(jptra) , ln_trc_cbc(jptra) , ln_trc_obc(jptra) , &
& ln_trc_ais(jptra) , &
& STAT = ierr(1) )
!
IF( ln_bdy ) ALLOCATE( trcdta_bdy(jptra, jp_bdy) , STAT = ierr(2) )
......
src/TOP/trcais.F90
View file @ c2b6c44e
......@@ -169,7 +169,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
zfact = 1. / e3t(ji,jj,1,Kmm)
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + fwficb(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm) * zfact
END_2D
......@@ -181,7 +181,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
IF( ln_isfpar_mlt ) THEN
zcalv = fwfisf_par(ji,jj) * r1_rho0 / rhisf_tbl_par(ji,jj)
ikt = misfkt_par(ji,jj)
......@@ -213,7 +213,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
DO jk = 1, icblev
zcalv = fwficb(ji,jj) * r1_rho0
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + rf_trafac(jl) * zcalv / gdepw(ji,jj,icblev+1,Kmm)
......@@ -228,7 +228,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
DO_2D( 0, 0, 0, 0 )
IF( ln_isfpar_mlt ) THEN
zcalv = - fwfisf_par(ji,jj) * r1_rho0 / rhisf_tbl_par(ji,jj)
ikt = misfkt_par(ji,jj)
......
src/TOP/trcbc.F90
View file @ c2b6c44e
......@@ -414,7 +414,7 @@ CONTAINS
!
! Remove river dilution for tracers with absent river load
IF( ln_rnf_ctl .AND. .NOT.ln_trc_cbc(jn) ) THEN
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
#if defined key_RK3
zrnf = rnf(ji,jj) * r1_rho0 / h_rnf(ji,jj)
......@@ -432,7 +432,7 @@ CONTAINS
IF( ln_trc_sbc(jn) ) THEN
jl = n_trc_indsbc(jn)
sf_trcsbc(jl)%fnow(:,:,1) = MAX( rtrn, sf_trcsbc(jl)%fnow(:,:,1) ) ! avoid nedgative value due to interpolation
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
zfact = 1. / ( e3t(ji,jj,1,Kmm) * rn_sbc_time )
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + rf_trsfac(jl) * sf_trcsbc(jl)%fnow(ji,jj,1) * zfact
END_2D
......@@ -443,7 +443,7 @@ CONTAINS
IF( l_offline ) rn_rfact = 1._wp
jl = n_trc_indcbc(jn)
sf_trccbc(jl)%fnow(:,:,1) = MAX( rtrn, sf_trccbc(jl)%fnow(:,:,1) ) ! avoid nedgative value due to interpolation
DO_2D( 0, 0, 0, 1 )
DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
zfact = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_cbc_time )
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + rf_trcfac(jl) * sf_trccbc(jl)%fnow(ji,jj,1) * zfact
......
src/TOP/trcini.F90
View file @ c2b6c44e
......@@ -32,6 +32,8 @@ MODULE trcini
PUBLIC trc_init ! called by opa
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
......@@ -93,9 +95,8 @@ CONTAINS
!! ** Purpose : passive tracers inventories at initialsation phase
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: Kmm ! time level index
INTEGER :: jk, jn ! dummy loop indices
INTEGER :: ji, jj, jk, jn ! dummy loop indices
CHARACTER (len=25) :: charout
REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: zzmsk
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
......
src/TOP/trcnam.F90
View file @ c2b6c44e
......@@ -254,7 +254,12 @@ CONTAINS
WRITE(numout,*) ' Namelist : namtrc_dcy '
WRITE(numout,*) ' Diurnal cycle for TOP ln_trcdc2dm = ', ln_trcdc2dm
ENDIF
! ! Define logical parameter ton control dirunal cycle in TOP
l_trcdm2dc = ( ln_trcdc2dm .AND. .NOT. ln_dm2dc )
!
IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
& 'Computation of a daily mean shortwave for some biogeochemical models ' )
!
END SUBROUTINE trc_nam_dcy
SUBROUTINE trc_nam_trd
......
src/TOP/trcopt.F90
View file @ c2b6c44e
......@@ -58,12 +58,14 @@ CONTAINS
INTEGER, INTENT(in) :: kt, knt ! ocean time step
INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: zchl ! chlorophyll field
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: ze1, ze2, ze3 ! PAR for individual wavelength
REAL(wp), DIMENSION(A2D(0),jpk), INTENT(out) :: ze1, ze2, ze3 ! PAR for individual wavelength
!
INTEGER :: ji, jj, jk, irgb
REAL(wp) :: ztmp
REAL(wp), DIMENSION(jpi,jpj ) :: parsw, zqsr100, zqsr_corr
REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze0
REAL(wp), DIMENSION(A2D(0) ) :: parsw, zqsr100, zqsr_corr
REAL(wp), DIMENSION(A2D(0),jpk) :: ze0
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_opt')
......@@ -85,7 +87,7 @@ CONTAINS
! Attenuation coef. function of Chlorophyll and wavelength (RGB)
! --------------------------------------------------------------
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
DO_3D( 0, 0, 0, 0, 1, jpkm1)
ztmp = ( zchl(ji,jj,jk) + rtrn ) * 1.e6
ztmp = MIN( 10. , MAX( 0.05, ztmp ) )
irgb = NINT( 41 + 20.* LOG10( ztmp ) + rtrn )
......@@ -99,54 +101,63 @@ CONTAINS
! -----------------------------------------------
IF( ln_qsr_bio ) THEN
!
zqsr_corr(:,:) = parsw(:,:) * qsr(:,:)
DO_2D( 0, 0, 0, 0 )
zqsr_corr(ji,jj) = parsw(ji,jj) * qsr(ji,jj)
END_2D
!
ze0(:,:,1) = (1._wp - 3._wp * parsw(:,:)) * qsr(:,:) ! ( 1 - 3 * alpha ) * q
DO_2D( 0, 0, 0, 0 )
ze0(ji,jj,1) = (1._wp - 3._wp * parsw(ji,jj)) * qsr(ji,jj) ! ( 1 - 3 * alpha ) * q
END_2D
ze1(:,:,1) = zqsr_corr(:,:)
ze2(:,:,1) = zqsr_corr(:,:)
ze3(:,:,1) = zqsr_corr(:,:)
!
DO jk = 2, nksrp + 1
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
ze0(ji,jj,jk) = ze0(ji,jj,jk-1) * EXP( -e3t(ji,jj,jk-1,Kmm) * (1. / rn_si0) )
ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) )
ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) )
ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP( -ekr (ji,jj,jk-1 ) )
END_2D
END DO
DO_3D( 0, 0, 0, 0, 2, nksrp + 1 )
ze0(ji,jj,jk) = ze0(ji,jj,jk-1) * EXP( -e3t(ji,jj,jk-1,Kmm) * (1. / rn_si0) )
ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) )
ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) )
ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP( -ekr (ji,jj,jk-1 ) )
END_3D
!
etot3(:,:,1) = qsr(:,:) * tmask(:,:,1)
DO jk = 2, nksrp + 1
etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk)
END DO
DO_2D( 0, 0, 0, 0 )
etot3(ji,jj,1) = qsr(ji,jj) * tmask(ji,jj,1)
END_2D
DO_3D( 0, 0, 0, 0, 2, nksrp+1 )
etot3(ji,jj,jk) = ( ze0(ji,jj,jk) + ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk) ) * tmask(ji,jj,jk)
END_3D
! ! ------------------------
ENDIF
! Photosynthetically Available Radiation (PAR)
! --------------------------------------------
zqsr_corr(:,:) = parsw(:,:) * qsr(:,:) / ( 1.-fr_i(:,:) + rtrn )
DO_2D( 0, 0, 0, 0 )
zqsr_corr(ji,jj) = parsw(ji,jj) * qsr(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
END_2D
!
CALL trc_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )
!
DO jk = 1, nksrp
etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
ENDDO
DO_3D( 0, 0, 0, 0, 1, nksr )
etot(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
END_3D
! No Diurnal cycle PAR
IF( l_trcdm2dc ) THEN
zqsr_corr(:,:) = parsw(:,:) * qsr_mean(:,:) / ( 1.-fr_i(:,:) + rtrn )
DO_2D( 0, 0, 0, 0 )
zqsr_corr(ji,jj) = parsw(ji,jj) * qsr_mean(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
END_2D
!
CALL trc_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )
DO jk = 1, nksrp
etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
END DO
!
DO_3D( 0, 0, 0, 0, 1, nksr )
etot_ndcy(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
END_3D
ELSE
etot_ndcy(:,:,:) = etot(:,:,:)
ENDIF
! Weighted broadband attenuation coefficient
! ------------------------------------------
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ztmp = ze1(ji,jj,jk)* ekb(ji,jj,jk) + ze2(ji,jj,jk) * ekg(ji,jj,jk) + ze3(ji,jj,jk) * ekr(ji,jj,jk)
zeps(ji,jj,jk) = ztmp / e3t(ji,jj,jk,Kmm) / (etot(ji,jj,jk) + rtrn)
END_3D
......@@ -154,26 +165,24 @@ CONTAINS
! Light at the euphotic depth
! ---------------------------
zqsr100 = 0.01 * 3. * zqsr_corr(:,:)
zqsr100(:,:) = 0.01 * 3. * zqsr_corr(:,:)
! Euphotic depth and level
! ------------------------
neln (:,:) = 1
heup (:,:) = gdepw(:,:,2,Kmm)
heup_01(:,:) = gdepw(:,:,2,Kmm)
!
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksrp )
DO_2D( 0, 0, 0, 0 )
neln (ji,jj) = 1
heup (ji,jj) = gdepw(ji,jj,2,Kmm)
heup_01(ji,jj) = gdepw(ji,jj,2,Kmm)
END_2D
DO_3D( 0, 0, 0, 0, 2, nksr)
IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN
! Euphotic level (1st T-level strictly below Euphotic layer)
! NOTE: ensure compatibility with nmld_trc definition in trdmxl_trc
neln(ji,jj) = jk+1
!
! Euphotic layer depth
heup(ji,jj) = gdepw(ji,jj,jk+1,Kmm)
neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer
! ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint
heup(ji,jj) = gdepw(ji,jj,jk+1,Kmm) ! Euphotic layer depth
ENDIF
! Euphotic layer depth (light level definition)
IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.50 ) THEN
heup_01(ji,jj) = gdepw(ji,jj,jk+1,Kmm)
IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.10 ) THEN
heup_01(ji,jj) = gdepw(ji,jj,jk+1,Kmm) ! Euphotic layer depth (light level definition)
ENDIF
END_3D
!
......@@ -181,8 +190,18 @@ CONTAINS
heup_01(:,:) = MIN( 300., heup_01(:,:) )
!
IF( lk_iomput ) THEN
CALL iom_put( "xbla" , zeps(:,:,:) * tmask(:,:,:) )
CALL iom_put( "Heup" , heup(:,: ) * tmask(:,:,1) )
IF( iom_use( "Heup" ) ) THEN
ALLOCATE( zw2d(A2D(0)) )
zw2d(A2D(0)) = heup(A2D(0)) * tmask(A2D(0),1)
CALL iom_put( "Heup", zw2d ) ! Euphotic layer depth
DEALLOCATE( zw2d )
ENDIF
IF( iom_use( "xbla" ) ) THEN
ALLOCATE( zw3d(A2D(0),jpk)) ; zw3d(A2D(0),jpk) = 0._wp
zw3d(A2D(0),1:jpkm1) = zeps(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
CALL iom_put( "xbla", zw3d ) ! Euphotic layer depth
DEALLOCATE( zw3d )
ENDIF
ENDIF
!
IF( ln_timing ) CALL timing_stop('trc_opt')
......@@ -199,11 +218,11 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER , INTENT(in) :: kt ! ocean time-step
REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: zqsr ! real shortwave
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: pe1 , pe2 , pe3 ! PAR (R-G-B)
REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: zqsr ! real shortwave
REAL(wp), DIMENSION(A2D(0),jpk), INTENT(out) :: pe1 , pe2 , pe3 ! PAR (R-G-B)
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp), DIMENSION(jpi,jpj) :: we1, we2, we3 ! PAR (R-G-B) at w-level
REAL(wp), DIMENSION(A2D(0)) :: we1, we2, we3 ! PAR (R-G-B) at w-level
!!----------------------------------------------------------------------
pe1(:,:,:) = 0. ; pe2(:,:,:) = 0. ; pe3(:,:,:) = 0.
!
......@@ -213,7 +232,7 @@ CONTAINS
pe2(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekg(:,:,1) )
pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) )
!
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksrp )
DO_3D( 0, 0, 0, 0, 2, nksrp )
pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) )
pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) )
pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -0.5 * ( ekr(ji,jj,jk-1) + ekr(ji,jj,jk) ) )
......@@ -225,7 +244,7 @@ CONTAINS
we2(:,:) = zqsr(:,:)
we3(:,:) = zqsr(:,:)
!
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksrp )
DO_3D( 0, 0, 0, 0, 1, nksrp )
! integrate PAR over current t-level
pe1(ji,jj,jk) = we1(ji,jj) / (ekb(ji,jj,jk) + rtrn) * (1. - EXP( -ekb(ji,jj,jk) ))
pe2(ji,jj,jk) = we2(ji,jj) / (ekg(ji,jj,jk) + rtrn) * (1. - EXP( -ekg(ji,jj,jk) ))
......@@ -266,7 +285,9 @@ CONTAINS
IF( ln_varpar ) THEN
IF( kt == nittrc000 .OR. ( kt /= nittrc000 .AND. ntimes_par > 1 ) ) THEN
CALL fld_read( kt, 1, sf_par )
par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) ) / 3.0
DO_2D( 0, 0, 0, 0 )
par_varsw(ji,jj) = ( sf_par(1)%fnow(ji,jj,1) ) / 3.0
END_2D
ENDIF
ENDIF
!
......@@ -348,8 +369,8 @@ CONTAINS
!! *** ROUTINE trc_opt_alloc ***
!!----------------------------------------------------------------------
!
ALLOCATE( ekb(jpi,jpj,jpk), ekr(jpi,jpj,jpk), &
ekg(jpi,jpj,jpk),zeps(jpi,jpj,jpk), STAT= trc_opt_alloc )
ALLOCATE( ekb(A2D(0),jpk),ekr(A2D(0),jpk), &
ekg(A2D(0),jpk),zeps(A2D(0),jpk), STAT= trc_opt_alloc )
!
IF( trc_opt_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_opt_alloc : failed to allocate arrays.' )
!
......
src/TOP/trcstp.F90
View file @ c2b6c44e
......@@ -37,6 +37,8 @@ MODULE trcstp
REAL(wp) :: rsecfst, rseclast ! ???
REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
......@@ -74,17 +76,13 @@ CONTAINS
ll_trcstat = ( sn_cfctl%l_trcstat ) .AND. &
& ( ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) )
IF( kt == nittrc000 ) CALL trc_stp_ctl ! control
IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer
!
IF( .NOT.ln_linssh ) THEN ! update ocean volume due to ssh temporal evolution
DO jk = 1, jpk
cvol(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
END DO
IF ( ll_trcstat .OR. kt == nitrst .OR. ( ln_check_mass .AND. kt == nitend ) &
& .OR. iom_use( "pno3tot" ) .OR. iom_use( "ppo4tot" ) .OR. iom_use( "psiltot" ) &
& .OR. iom_use( "palktot" ) .OR. iom_use( "pfertot" ) ) &
& areatot = glob_sum( 'trcstp', cvol(:,:,:) )
IF ( ll_trcstat .OR. kt == nitrst ) areatot = glob_sum( 'trcstp', cvol(:,:,:) )
ENDIF
!
IF( l_trcdm2dc ) CALL trc_mean_qsr( kt )
......@@ -141,20 +139,6 @@ CONTAINS
END SUBROUTINE trc_stp
SUBROUTINE trc_stp_ctl
!!----------------------------------------------------------------------
!! *** ROUTINE trc_stp_ctl ***
!!----------------------------------------------------------------------
!
! Define logical parameter ton control dirunal cycle in TOP
l_trcdm2dc = ( ln_trcdc2dm .AND. .NOT. ln_dm2dc )
!
IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
& 'Computation of a daily mean shortwave for some biogeochemical models ' )
!
END SUBROUTINE trc_stp_ctl
SUBROUTINE trc_mean_qsr( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE trc_mean_qsr ***
......@@ -169,7 +153,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!
INTEGER :: jn ! dummy loop indices
INTEGER :: ji,jj,jn ! dummy loop indices
REAL(wp) :: zkt, zrec ! local scalars
CHARACTER(len=1) :: cl1 ! 1 character
CHARACTER(len=2) :: cl2 ! 2 characters
......@@ -188,7 +172,7 @@ CONTAINS
WRITE(numout,*)
ENDIF
!
ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) )
ALLOCATE( qsr_arr(A2D(0),nb_rec_per_day ) )
!
! !* Restart: read in restart file
IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 &
......@@ -219,7 +203,9 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values'
rsecfst = kt * rn_Dt
!
qsr_mean(:,:) = qsr(:,:)
DO_2D( 0, 0, 0, 0 )
qsr_mean(ji,jj) = qsr(ji,jj)
END_2D
DO jn = 1, nb_rec_per_day
qsr_arr(:,:,jn) = qsr_mean(:,:)
END DO
......@@ -239,7 +225,7 @@ CONTAINS
qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1)
ENDDO
qsr_arr (:,:,nb_rec_per_day) = qsr(:,:)
qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
qsr_mean(:,:) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
ENDIF
!
IF( lrst_trc ) THEN !* Write the mean of qsr in restart file
......
src/TOP/trcstp_rk3.F90
View file @ c2b6c44e
......@@ -41,6 +41,8 @@ MODULE trcstp_rk3
REAL(wp) :: rsecfst, rseclast ! ???
REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
......@@ -71,15 +73,14 @@ CONTAINS
l_trcstat = ( sn_cfctl%l_trcstat ) .AND. &
& ( ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) )
!
IF( kt == nittrc000 ) CALL trc_stp_ctl ! control
IF( kt == nittrc000 ) CALL trc_stpsctl ! control
IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer
!
IF( .NOT.ln_linssh ) THEN ! update ocean volume due to ssh temporal evolution
DO jk = 1, jpk
cvol(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
END DO
IF( l_trcstat .OR. kt == nitrst .OR. ( ln_check_mass .AND. kt == nitend ) ) &
& areatot = glob_sum( 'trcstp', cvol(:,:,:) )
IF( l_trcstat .OR. kt == nitrst ) areatot = glob_sum( 'trcstp', cvol(:,:,:) )
ENDIF
!
IF( l_trcdm2dc ) CALL trc_mean_qsr( kt )
......@@ -146,22 +147,6 @@ CONTAINS
END SUBROUTINE trc_stp_end
SUBROUTINE trc_stp_ctl
!!----------------------------------------------------------------------
!! *** ROUTINE trc_stp_ctl ***
!! ** Purpose : Control + ocean volume
!!----------------------------------------------------------------------
!
! Define logical parameter ton control dirunal cycle in TOP
l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 .AND. ncpl_qsr_freq /= 0 )
l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline
!
IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
& 'Computation of a daily mean shortwave for some biogeochemical models ' )
!
END SUBROUTINE trc_stp_ctl
SUBROUTINE trc_mean_qsr( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE trc_mean_qsr ***
......@@ -176,7 +161,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!
INTEGER :: jn ! dummy loop indices
INTEGER :: ji,jj,jn ! dummy loop indices
REAL(wp) :: zkt, zrec ! local scalars
CHARACTER(len=1) :: cl1 ! 1 character
CHARACTER(len=2) :: cl2 ! 2 characters
......@@ -185,13 +170,9 @@ CONTAINS
IF( ln_timing ) CALL timing_start('trc_mean_qsr')
!
IF( kt == nittrc000 ) THEN
IF( ln_cpl ) THEN
rdt_sampl = rday / ncpl_qsr_freq
nb_rec_per_day = ncpl_qsr_freq
ELSE
rdt_sampl = MAX( 3600., rn_Dt )
nb_rec_per_day = INT( rday / rdt_sampl )
ENDIF
!
rdt_sampl = REAL( ncpl_qsr_freq )
nb_rec_per_day = INT( rday / ncpl_qsr_freq )
!
IF(lwp) THEN
WRITE(numout,*)
......@@ -199,7 +180,7 @@ CONTAINS
WRITE(numout,*)
ENDIF
!
ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) )
ALLOCATE( qsr_arr(A2D(0),nb_rec_per_day ) )
!
! !* Restart: read in restart file
IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 &
......@@ -230,7 +211,9 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values'
rsecfst = kt * rn_Dt
!
qsr_mean(:,:) = qsr(:,:)
DO_2D( 0, 0, 0, 0 )
qsr_mean(ji,jj) = qsr(ji,jj)
END_2D
DO jn = 1, nb_rec_per_day
qsr_arr(:,:,jn) = qsr_mean(:,:)
END DO
......@@ -250,7 +233,7 @@ CONTAINS
qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1)
END DO
qsr_arr (:,:,nb_rec_per_day) = qsr(:,:)
qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
qsr_mean(:,:) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
ENDIF
!
IF( lrst_trc ) THEN !* Write the mean of qsr in restart file
......
src/TOP/trcwri.F90
View file @ c2b6c44e
......@@ -42,12 +42,12 @@ CONTAINS
INTEGER, INTENT( in ) :: kt
INTEGER, INTENT( in ) :: Kmm ! time level indices
!
INTEGER :: jk, jn
INTEGER :: ji,jj,jk,jn
CHARACTER (len=20) :: cltra
CHARACTER (len=40) :: clhstnam
INTEGER :: inum = 11 ! temporary logical unit
REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
!!---------------------------------------------------------------------
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_wri')
!
......@@ -59,6 +59,8 @@ CONTAINS
CLOSE(inum)
ENDIF
ALLOCATE( z3d(jpi,jpj,jpk) ) ; z3d(:,:,:) = 0._wp
! Output of initial vertical scale factor
CALL iom_put( "e3t_0", e3t_0(:,:,:) )
CALL iom_put( "e3u_0", e3u_0(:,:,:) )
......@@ -66,25 +68,27 @@ CONTAINS
!
IF( .NOT.ln_linssh ) CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height
!
IF ( iom_use("e3t") ) THEN ! time-varying e3t
DO jk = 1, jpk
z3d(:,:,jk) = e3t(:,:,jk,Kmm)
END DO
CALL iom_put( "e3t", z3d(:,:,:) )
! --- vertical scale factors --- !
IF( iom_use("e3t") ) THEN ! time-varying e3t
DO_3D( 0, 0, 0, 0, 1, jpk )
z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
END_3D
CALL iom_put( "e3t", z3d )
ENDIF
IF ( iom_use("e3u") ) THEN ! time-varying e3u
DO jk = 1, jpk
z3d(:,:,jk) = e3u(:,:,jk,Kmm)
END DO
CALL iom_put( "e3u", z3d(:,:,:) )
DO_3D( 0, 0, 0, 0, 1, jpk )
z3d(ji,jj,jk) = e3u(ji,jj,jk,Kmm)
END_3D
CALL iom_put( "e3u" , z3d )
ENDIF
IF ( iom_use("e3v") ) THEN ! time-varying e3v
DO jk = 1, jpk
z3d(:,:,jk) = e3v(:,:,jk,Kmm)
END DO
CALL iom_put( "e3v", z3d(:,:,:) )
DO_3D( 0, 0, 0, 0, 1, jpk )
z3d(ji,jj,jk) = e3v(ji,jj,jk,Kmm)
END_3D
CALL iom_put( "e3v" , z3d )
ENDIF
!
DEALLOCATE( z3d )
ENDIF
!
! write the tracer concentrations in the file
......
tests/ADIAB_WAVE/MY_SRC/usrdef_hgr.F90
View file @ c2b6c44e
......@@ -80,14 +80,14 @@ CONTAINS
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! DO_2D( 1, 1, 1, 1 )
! ! longitude
plamt(ji,jj) = zfact * ( REAL( mig0(ji)-1 , wp ) )
plamu(ji,jj) = zfact * ( 0.5 + REAL( mig0(ji)-1 , wp ) )
plamt(ji,jj) = zfact * ( REAL( mig(ji,0)-1 , wp ) )
plamu(ji,jj) = zfact * ( 0.5 + REAL( mig(ji,0)-1 , wp ) )
plamv(ji,jj) = plamt(ji,jj)
plamf(ji,jj) = plamu(ji,jj)
! ! latitude
pphit(ji,jj) = zfact2 * ( REAL( mjg0(jj)-1 , wp ) )
pphit(ji,jj) = zfact2 * ( REAL( mjg(jj,0)-1 , wp ) )
pphiu(ji,jj) = pphit(ji,jj)
pphiv(ji,jj) = zfact2 * ( 0.5 + REAL( mjg0(jj)-1 , wp ) )
pphiv(ji,jj) = zfact2 * ( 0.5 + REAL( mjg(jj,0)-1 , wp ) )
pphif(ji,jj) = pphiv(ji,jj)
END_2D
!
......
tests/ADIAB_WAVE/MY_SRC/usrdef_zgr.F90
View file @ c2b6c44e
......@@ -14,8 +14,7 @@ MODULE usrdef_zgr
!! zgr_z1d : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain
USE dom_oce , ONLY: glamt ! ocean space and time domain
USE dom_oce ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
......@@ -105,10 +104,10 @@ CONTAINS
END_2D
CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrouding grid-points
! ! ==>>> set by hand non-zero value on first/last columns & rows
DO ji = mi0(1), mi1(1) ! first row of global domain only
DO ji = mi0(1,nn_hls), mi1(1,nn_hls) ! first row of global domain only
zhu(ji,2) = zht(ji,2)
END DO
DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only
DO ji = mi0(jpiglo,nn_hls), mi1(jpiglo,nn_hls) ! last row of global domain only
zhu(ji,2) = zht(ji,2)
END DO
zhu(:,1) = zhu(:,2)
......