- Timestamp:
- 2016-11-28T17:04:10+01:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r5836 r7351 51 51 REAL(wp), DIMENSION(3,61), PUBLIC :: xkrgb !: tabulated attenuation coefficients for RGB absorption 52 52 53 !! * Substitutions54 # include "domzgr_substitute.h90"55 53 !!---------------------------------------------------------------------- 56 54 !! NEMO/TOP 3.3 , NEMO Consortium (2010) … … 76 74 REAL(wp) :: zchl 77 75 REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep 78 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 77 REAL(wp), POINTER, DIMENSION(:,: ) :: zqsr100, zqsr_corr 79 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 80 79 !!--------------------------------------------------------------------- … … 83 82 ! 84 83 ! Allocate temporary workspace 85 CALL wrk_alloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 86 CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 84 CALL wrk_alloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 85 CALL wrk_alloc( jpi, jpj, zqsr100, zqsr_corr ) 86 CALL wrk_alloc( jpi, jpj, jpk, zpar , ze0, ze1, ze2, ze3 ) 87 87 88 88 IF( knt == 1 .AND. ln_varpar ) CALL p4z_opt_sbc( kt ) … … 101 101 irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn ) 102 102 ! 103 ekb(ji,jj,jk) = xkrgb(1,irgb) * fse3t(ji,jj,jk)104 ekg(ji,jj,jk) = xkrgb(2,irgb) * fse3t(ji,jj,jk)105 ekr(ji,jj,jk) = xkrgb(3,irgb) * fse3t(ji,jj,jk)103 ekb(ji,jj,jk) = xkrgb(1,irgb) * e3t_n(ji,jj,jk) 104 ekg(ji,jj,jk) = xkrgb(2,irgb) * e3t_n(ji,jj,jk) 105 ekr(ji,jj,jk) = xkrgb(3,irgb) * e3t_n(ji,jj,jk) 106 106 END DO 107 107 END DO … … 110 110 ! ! -------------------------------------- 111 111 IF( l_trcdm2dc ) THEN ! diurnal cycle 112 ! 1% of qsr to compute euphotic layer113 zqsr 100(:,:) = 0.01 * qsr_mean(:,:) ! daily mean qsr114 ! 115 CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3)112 ! 113 zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 114 ! 115 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) 116 116 ! 117 117 DO jk = 1, nksrp … … 121 121 END DO 122 122 ! 123 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 123 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 124 ! 125 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 124 126 ! 125 127 DO jk = 1, nksrp … … 128 130 ! 129 131 ELSE 130 ! 1% of qsr to compute euphotic layer131 zqsr 100(:,:) = 0.01 * qsr(:,:)132 ! 133 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3)132 ! 133 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 134 ! 135 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) 134 136 ! 135 137 DO jk = 1, nksrp … … 159 161 DO jj = 1, jpj 160 162 DO ji = 1, jpi 161 IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.43 *zqsr100(ji,jj) ) THEN163 IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN 162 164 neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer 163 165 ! ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint 164 heup(ji,jj) = fsdepw(ji,jj,jk+1)! Euphotic layer depth166 heup(ji,jj) = gdepw_n(ji,jj,jk+1) ! Euphotic layer depth 165 167 ENDIF 166 168 END DO … … 179 181 DO jj = 1, jpj 180 182 DO ji = 1, jpi 181 IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN182 zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot (ji,jj,jk) * fse3t(ji,jj,jk) ! remineralisation183 zetmp2 (ji,jj) = zetmp2 (ji,jj) + etot_ndcy(ji,jj,jk) * fse3t(ji,jj,jk) ! production184 zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano (ji,jj,jk) * fse3t(ji,jj,jk) ! production185 zetmp4 (ji,jj) = zetmp4 (ji,jj) + ediat (ji,jj,jk) * fse3t(ji,jj,jk) ! production186 zdepmoy(ji,jj) = zdepmoy(ji,jj) + fse3t(ji,jj,jk)183 IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 184 zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot (ji,jj,jk) * e3t_n(ji,jj,jk) ! remineralisation 185 zetmp2 (ji,jj) = zetmp2 (ji,jj) + etot_ndcy(ji,jj,jk) * e3t_n(ji,jj,jk) ! production 186 zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano (ji,jj,jk) * e3t_n(ji,jj,jk) ! production 187 zetmp4 (ji,jj) = zetmp4 (ji,jj) + ediat (ji,jj,jk) * e3t_n(ji,jj,jk) ! production 188 zdepmoy(ji,jj) = zdepmoy(ji,jj) + e3t_n(ji,jj,jk) 187 189 ENDIF 188 190 END DO … … 196 198 DO jj = 1, jpj 197 199 DO ji = 1, jpi 198 IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN200 IF( gdepw_n(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 199 201 z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) 200 202 emoy (ji,jj,jk) = zetmp1(ji,jj) * z1_dep … … 220 222 ENDIF 221 223 ! 222 CALL wrk_dealloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 223 CALL wrk_dealloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 224 CALL wrk_dealloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 225 CALL wrk_dealloc( jpi, jpj, zqsr100, zqsr_corr ) 226 CALL wrk_dealloc( jpi, jpj, jpk, zpar , ze0, ze1, ze2, ze3 ) 224 227 ! 225 228 IF( nn_timing == 1 ) CALL timing_stop('p4z_opt') … … 227 230 END SUBROUTINE p4z_opt 228 231 229 SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0 )232 SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0, pqsr100 ) 230 233 !!---------------------------------------------------------------------- 231 234 !! *** routine p4z_opt_par *** … … 240 243 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe1 , pe2 , pe3 ! PAR ( R-G-B) 241 244 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL :: pe0 245 REAL(wp), DIMENSION(jpi,jpj) , INTENT(out) , OPTIONAL :: pqsr100 242 246 !! * local variables 243 247 INTEGER :: ji, jj, jk ! dummy loop indices … … 249 253 ELSE ; zqsr(:,:) = xparsw * pqsr(:,:) 250 254 ENDIF 251 ! 255 256 ! Light at the euphotic depth 257 IF( PRESENT( pqsr100 ) ) pqsr100(:,:) = 0.01 * 3. * zqsr(:,:) 258 252 259 IF( PRESENT( pe0 ) ) THEN ! W-level 253 260 ! … … 260 267 DO jj = 1, jpj 261 268 DO ji = 1, jpi 262 pe0(ji,jj,jk) = pe0(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * xsi0r )269 pe0(ji,jj,jk) = pe0(ji,jj,jk-1) * EXP( -e3t_n(ji,jj,jk-1) * xsi0r ) 263 270 pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -ekb(ji,jj,jk-1 ) ) 264 271 pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -ekg(ji,jj,jk-1 ) )
Note: See TracChangeset
for help on using the changeset viewer.
