Changeset 13097 for branches/UKMO/dev_r5518_GO6_package_FOAMv14_phytobal3d/NEMOGCM/NEMO/OPA_SRC/ASM/asmphytobal_medusa.F90
- Timestamp:
- 2020-06-11T19:32:37+02:00 (4 years ago)
- File:
-
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package_FOAMv14_phytobal3d/NEMOGCM/NEMO/OPA_SRC/ASM/asmphytobal_medusa.F90
r13096 r13097 1 MODULE asmphyto 2dbal_medusa1 MODULE asmphytobal_medusa 2 2 !!====================================================================== 3 3 !! *** MODULE asmphyto2dbal_medusa *** … … 33 33 PRIVATE 34 34 35 PUBLIC asm_phyto 2d_bal_medusa35 PUBLIC asm_phyto_bal_medusa 36 36 37 37 ! Default values for biological assimilation parameters … … 68 68 CONTAINS 69 69 70 SUBROUTINE asm_phyto2d_bal_medusa( ld_chltot, & 71 & pinc_chltot, & 72 & ld_chldia, & 73 & pinc_chldia, & 74 & ld_chlnon, & 75 & pinc_chlnon, & 76 & ld_phytot, & 77 & pinc_phytot, & 78 & ld_phydia, & 79 & pinc_phydia, & 80 & ld_phynon, & 81 & pinc_phynon, & 82 & pincper, & 83 & p_maxchlinc, ld_phytobal, pmld, & 84 & pgrow_avg_bkg, ploss_avg_bkg, & 85 & phyt_avg_bkg, mld_max_bkg, & 86 & tracer_bkg, phyto2d_balinc ) 70 SUBROUTINE asm_phyto_bal_medusa( kdeps, & 71 & ld_chltot, & 72 & pinc_chltot_3d, & 73 & ld_chldia, & 74 & pinc_chldia_3d, & 75 & ld_chlnon, & 76 & pinc_chlnon_3d, & 77 & ld_phytot, & 78 & pinc_phytot_3d, & 79 & ld_phydia, & 80 & pinc_phydia_3d, & 81 & ld_phynon, & 82 & pinc_phynon_3d, & 83 & pincper, & 84 & p_maxchlinc, ld_phytobal, pmld, & 85 & pgrow_avg_bkg_3d, ploss_avg_bkg_3d, & 86 & phyt_avg_bkg_3d, mld_max_bkg, & 87 & tracer_bkg, phyto_balinc ) 87 88 !!--------------------------------------------------------------------------- 88 !! *** ROUTINE asm_phyto 2d_bal_medusa ***89 !! *** ROUTINE asm_phyto_bal_medusa *** 89 90 !! 90 !! ** Purpose : calculate increments to MEDUSA from 2dphytoplankton increments91 !! ** Purpose : calculate increments to MEDUSA from phytoplankton increments 91 92 !! 92 93 !! ** Method : average up MEDUSA to look like HadOCC … … 94 95 !! separate back out to MEDUSA 95 96 !! 96 !! ** Action : populate phyto 2d_balinc97 !! ** Action : populate phyto_balinc 97 98 !! 98 99 !! References : Hemmings et al., 2008, J. Mar. Res. … … 100 101 !!--------------------------------------------------------------------------- 101 102 !! 102 LOGICAL, INTENT(in ) :: ld_chltot ! Assim chltot y/n 103 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_chltot ! chltot increments 104 LOGICAL, INTENT(in ) :: ld_chldia ! Assim chldia y/n 105 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_chldia ! chldia increments 106 LOGICAL, INTENT(in ) :: ld_chlnon ! Assim chlnon y/n 107 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_chlnon ! chlnon increments 108 LOGICAL, INTENT(in ) :: ld_phytot ! Assim phytot y/n 109 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_phytot ! phytot increments 110 LOGICAL, INTENT(in ) :: ld_phydia ! Assim phydia y/n 111 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_phydia ! phydia increments 112 LOGICAL, INTENT(in ) :: ld_phynon ! Assim phynon y/n 113 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pinc_phynon ! phynon increments 114 REAL(wp), INTENT(in ) :: pincper ! Assimilation period 115 REAL(wp), INTENT(in ) :: p_maxchlinc ! Max chl increment 116 LOGICAL, INTENT(in ) :: ld_phytobal ! Balancing y/n 117 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pmld ! Mixed layer depth 118 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: pgrow_avg_bkg ! Avg phyto growth 119 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ploss_avg_bkg ! Avg phyto loss 120 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: phyt_avg_bkg ! Avg phyto 121 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: mld_max_bkg ! Max MLD 122 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk,jptra) :: tracer_bkg ! State variables 123 REAL(wp), INTENT( out), DIMENSION(jpi,jpj,jpk,jptra) :: phyto2d_balinc ! Balancing increments 103 INTEGER, INTENT(in ) :: kdeps ! No. inc deps 1 or jpk 104 LOGICAL, INTENT(in ) :: ld_chltot ! Assim chltot y/n 105 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_chltot_3d ! chltot increments (3D) 106 LOGICAL, INTENT(in ) :: ld_chldia ! Assim chldia y/n 107 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_chldia_3d ! chldia increments (3D) 108 LOGICAL, INTENT(in ) :: ld_chlnon ! Assim chlnon y/n 109 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_chlnon_3d ! chlnon increments (3D) 110 LOGICAL, INTENT(in ) :: ld_phytot ! Assim phytot y/n 111 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_phytot_3d ! phytot increments (3D) 112 LOGICAL, INTENT(in ) :: ld_phydia ! Assim phydia y/n 113 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_phydia_3d ! phydia increments (3D) 114 LOGICAL, INTENT(in ) :: ld_phynon ! Assim phynon y/n 115 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kdeps) :: pinc_phynon_3d ! phynon increments (3D) 116 REAL(wp), INTENT(in ) :: pincper ! Assimilation period 117 REAL(wp), INTENT(in ) :: p_maxchlinc ! Max chl increment 118 LOGICAL, INTENT(in ) :: ld_phytobal ! Balancing y/n 119 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pmld ! Mixed layer depth 120 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,kdeps) :: pgrow_avg_bkg_3d ! Avg phyto growth (3D) 121 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,kdeps) :: ploss_avg_bkg_3d ! Avg phyto loss (3D) 122 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,kdeps) :: phyt_avg_bkg_3d ! Avg phyto (3D) 123 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: mld_max_bkg ! Max MLD 124 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk,jptra) :: tracer_bkg ! State variables 125 REAL(wp), INTENT( out), DIMENSION(jpi,jpj,jpk,jptra) :: phyto_balinc ! Balancing increments 124 126 !! 125 127 INTEGER :: ji, jj, jk, jn ! Loop counters 126 128 INTEGER :: jkmax ! Loop index 129 INTEGER :: jkinc ! Loop index 127 130 INTEGER, DIMENSION(6) :: i_tracer ! Tracer indices 128 131 REAL(wp) :: n2be_p ! N:biomass for total phy … … 143 146 REAL(wp) :: zrat_pds_chd ! Ratio of jppds:jpchd 144 147 REAL(wp) :: zrat_dtc_det ! Ratio of jpdtc:jpdet 145 REAL(wp), DIMENSION(jpi,jpj) :: cchl_p ! C:Chl for total phy 148 REAL(wp), DIMENSION(jpi,jpj) :: cchl_p_2d ! C:Chl for total phy (2D) 149 REAL(wp), DIMENSION(jpi,jpj,jpk) :: cchl_p_3d ! C:Chl for total phy (3D) 146 150 REAL(wp), DIMENSION(16) :: modparm ! Model parameters 147 151 REAL(wp), DIMENSION(20) :: assimparm ! Assimilation parameters 148 REAL(wp), DIMENSION(jpi,jpj,jpk,6) :: bstate ! Background state 149 REAL(wp), DIMENSION(jpi,jpj,jpk,6) :: outincs ! Balancing increments 150 REAL(wp), DIMENSION(jpi,jpj,22) :: diag ! Depth-indep diagnostics 151 REAL(wp), DIMENSION(jpi,jpj,jpk,22) :: diag_fulldepth ! Full-depth diagnostics 152 REAL(wp), DIMENSION(jpi,jpj,1,6) :: bstate_2d ! Background state (2D) 153 REAL(wp), DIMENSION(jpi,jpj,jpk,6) :: bstate_3d ! Background state (3D) 154 REAL(wp), DIMENSION(jpi,jpj,1,6) :: outincs_2d ! Balancing increments (2D) 155 REAL(wp), DIMENSION(jpi,jpj,jpk,6) :: outincs_3d ! Balancing increments (3D) 156 REAL(wp), DIMENSION(jpi,jpj,22) :: diag ! Depth-indep diagnostics 157 REAL(wp), DIMENSION(jpi,jpj,1,22) :: diag_fulldepth_2d ! Full-depth diagnostics (2D) 158 REAL(wp), DIMENSION(jpi,jpj,jpk,22) :: diag_fulldepth_3d ! Full-depth diagnostics (3D) 159 REAL(wp), DIMENSION(jpi,jpj,1) :: tmask_2d ! Single-level tmask 160 REAL(wp), DIMENSION(jpi,jpj) :: pinc_chltot_2d ! chltot increments (2D) 161 REAL(wp), DIMENSION(jpi,jpj) :: pinc_chldia_2d ! chldia increments (2D) 162 REAL(wp), DIMENSION(jpi,jpj) :: pinc_chlnon_2d ! chlnon increments (2D) 163 REAL(wp), DIMENSION(jpi,jpj) :: pinc_phytot_2d ! phytot increments (2D) 164 REAL(wp), DIMENSION(jpi,jpj) :: pinc_phydia_2d ! phydia increments (2D) 165 REAL(wp), DIMENSION(jpi,jpj) :: pinc_phynon_2d ! phynon increments (2D) 166 REAL(wp), DIMENSION(jpi,jpj) :: pgrow_avg_bkg_2d ! Avg phyto growth (2D) 167 REAL(wp), DIMENSION(jpi,jpj) :: ploss_avg_bkg_2d ! Avg phyto loss (2D) 168 REAL(wp), DIMENSION(jpi,jpj) :: phyt_avg_bkg_2d ! Avg phyto (2D) 152 169 !!--------------------------------------------------------------------------- 153 170 154 171 ! If p_maxchlinc > 0 then cap total absolute chlorophyll increment at that value 155 172 IF ( p_maxchlinc > 0.0 ) THEN 156 IF ( ld_chltot ) THEN173 DO jk = 1, kdeps 157 174 DO jj = 1, jpj 158 175 DO ji = 1, jpi 159 pinc_chltot(ji,jj) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chltot(ji,jj), p_maxchlinc ) ) 176 IF ( ld_chltot ) THEN 177 pinc_chltot_3d(ji,jj,jk) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chltot_3d(ji,jj,jk), p_maxchlinc ) ) 178 ELSE IF ( ld_chldia .AND. ld_chlnon ) THEN 179 pinc_chltot_3d(ji,jj,jk) = pinc_chldia_3d(ji,jj,jk) + pinc_chlnon_3d(ji,jj,jk) 180 pinc_chltot_3d(ji,jj,jk) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chltot_3d(ji,jj,jk), p_maxchlinc ) ) 181 IF ( pinc_chltot_3d(ji,jj,jk) .NE. ( pinc_chldia_3d(ji,jj,jk) + pinc_chlnon_3d(ji,jj,jk) ) ) THEN 182 zfrac = pinc_chltot_3d(ji,jj,jk) / ( pinc_chldia_3d(ji,jj,jk) + pinc_chlnon_3d(ji,jj,jk) ) 183 pinc_chldia_3d(ji,jj,jk) = pinc_chldia_3d(ji,jj,jk) * zfrac 184 pinc_chlnon_3d(ji,jj,jk) = pinc_chlnon_3d(ji,jj,jk) * zfrac 185 ENDIF 186 ELSE IF ( ld_chldia ) THEN 187 pinc_chldia_3d(ji,jj,jk) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chldia_3d(ji,jj,jk), p_maxchlinc ) ) 188 pinc_chltot_3d(ji,jj,jk) = pinc_chldia_3d(ji,jj,jk) 189 ELSE IF ( ld_chlnon ) THEN 190 pinc_chlnon_3d(ji,jj,jk) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chlnon_3d(ji,jj,jk), p_maxchlinc ) ) 191 pinc_chltot_3d(ji,jj,jk) = pinc_chlnon_3d(ji,jj,jk) 192 ENDIF 160 193 END DO 161 194 END DO 162 ELSE IF ( ld_chldia .AND. ld_chlnon ) THEN 163 DO jj = 1, jpj 164 DO ji = 1, jpi 165 pinc_chltot(ji,jj) = pinc_chldia(ji,jj) + pinc_chlnon(ji,jj) 166 pinc_chltot(ji,jj) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chltot(ji,jj), p_maxchlinc ) ) 167 IF ( pinc_chltot(ji,jj) .NE. ( pinc_chldia(ji,jj) + pinc_chlnon(ji,jj) ) ) THEN 168 zfrac = pinc_chltot(ji,jj) / ( pinc_chldia(ji,jj) + pinc_chlnon(ji,jj) ) 169 pinc_chldia(ji,jj) = pinc_chldia(ji,jj) * zfrac 170 pinc_chlnon(ji,jj) = pinc_chlnon(ji,jj) * zfrac 171 ENDIF 172 END DO 173 END DO 174 ELSE IF ( ld_chldia ) THEN 175 DO jj = 1, jpj 176 DO ji = 1, jpi 177 pinc_chldia(ji,jj) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chldia(ji,jj), p_maxchlinc ) ) 178 pinc_chltot(ji,jj) = pinc_chldia(ji,jj) 179 END DO 180 END DO 181 ELSE IF ( ld_chlnon ) THEN 182 DO jj = 1, jpj 183 DO ji = 1, jpi 184 pinc_chlnon(ji,jj) = MAX( -1.0 * p_maxchlinc, MIN( pinc_chlnon(ji,jj), p_maxchlinc ) ) 185 pinc_chltot(ji,jj) = pinc_chlnon(ji,jj) 186 END DO 187 END DO 188 ENDIF 195 END DO 189 196 ENDIF 190 197 … … 250 257 251 258 ! Set background state 252 bstate (:,:,:,i_tracer(1)) = tracer_bkg(:,:,:,jpdin)253 bstate (:,:,:,i_tracer(2)) = tracer_bkg(:,:,:,jpphn) + tracer_bkg(:,:,:,jpphd)254 bstate (:,:,:,i_tracer(3)) = tracer_bkg(:,:,:,jpzmi) + tracer_bkg(:,:,:,jpzme)255 bstate (:,:,:,i_tracer(4)) = tracer_bkg(:,:,:,jpdet)256 bstate (:,:,:,i_tracer(5)) = tracer_bkg(:,:,:,jpdic)257 bstate (:,:,:,i_tracer(6)) = tracer_bkg(:,:,:,jpalk)259 bstate_3d(:,:,:,i_tracer(1)) = tracer_bkg(:,:,:,jpdin) 260 bstate_3d(:,:,:,i_tracer(2)) = tracer_bkg(:,:,:,jpphn) + tracer_bkg(:,:,:,jpphd) 261 bstate_3d(:,:,:,i_tracer(3)) = tracer_bkg(:,:,:,jpzmi) + tracer_bkg(:,:,:,jpzme) 262 bstate_3d(:,:,:,i_tracer(4)) = tracer_bkg(:,:,:,jpdet) 263 bstate_3d(:,:,:,i_tracer(5)) = tracer_bkg(:,:,:,jpdic) 264 bstate_3d(:,:,:,i_tracer(6)) = tracer_bkg(:,:,:,jpalk) 258 265 259 266 ! Calculate carbon to chlorophyll ratio for combined phytoplankton 260 267 ! and nitrogen to biomass equivalent for PZD 261 268 ! Hardwire nitrogen mass to 14.01 for now as it doesn't seem to be set in MEDUSA 262 cchl_p(:,:) = 0.0 263 DO jj = 1, jpj 264 DO ji = 1, jpi 265 IF ( ( tracer_bkg(ji,jj,1,jpchn) + tracer_bkg(ji,jj,1,jpchd ) ) .GT. 0.0 ) THEN 266 cchl_p(ji,jj) = xmassc * ( ( tracer_bkg(ji,jj,1,jpphn) * xthetapn ) + & 267 & ( tracer_bkg(ji,jj,1,jpphd) * xthetapd ) ) / & 268 & ( tracer_bkg(ji,jj,1,jpchn) + tracer_bkg(ji,jj,1,jpchd ) ) 269 ENDIF 269 cchl_p_3d(:,:,:) = 0.0 270 DO jk = 1, jpk 271 DO jj = 1, jpj 272 DO ji = 1, jpi 273 IF ( ( tracer_bkg(ji,jj,jk,jpchn) + tracer_bkg(ji,jj,jk,jpchd ) ) .GT. 0.0 ) THEN 274 cchl_p_3d(ji,jj,jk) = xmassc * ( ( tracer_bkg(ji,jj,jk,jpphn) * xthetapn ) + & 275 & ( tracer_bkg(ji,jj,jk,jpphd) * xthetapd ) ) / & 276 & ( tracer_bkg(ji,jj,jk,jpchn) + tracer_bkg(ji,jj,jk,jpchd ) ) 277 ENDIF 278 END DO 270 279 END DO 271 280 END DO … … 275 284 276 285 ! Call nitrogen balancing routine 277 CALL bio_analysis( jpi, jpj, jpk, gdepw_n(:,:,2:jpk), i_tracer, modparm, & 278 & n2be_p, n2be_z, n2be_d, assimparm, & 279 & INT(pincper), 1, INT(SUM(tmask,3)), tmask(:,:,:), & 280 & pmld(:,:), mld_max_bkg(:,:), pinc_chltot(:,:), cchl_p(:,:), & 281 & nbal_active, phyt_avg_bkg(:,:), & 282 & gl_active, pgrow_avg_bkg(:,:), ploss_avg_bkg(:,:), & 283 & subsurf_active, deepneg_active, & 284 & deeppos_active, nutprof_active, & 285 & bstate, outincs, & 286 & diag_active, diag, & 287 & diag_fulldepth_active, diag_fulldepth ) 286 IF (kdeps == 1) THEN 287 pinc_chltot_2d(:,:) = pinc_chltot_3d(:,:,1) 288 cchl_p_2d(:,:) = cchl_p_3d(:,:,1) 289 phyt_avg_bkg_2d(:,:) = phyt_avg_bkg_3d(:,:,1) 290 pgrow_avg_bkg_2d(:,:) = pgrow_avg_bkg_3d(:,:,1) 291 ploss_avg_bkg_2d(:,:) = ploss_avg_bkg_3d(:,:,1) 292 293 CALL bio_analysis( jpi, jpj, jpk, gdepw_n(:,:,2:jpk), i_tracer, modparm, & 294 & n2be_p, n2be_z, n2be_d, assimparm, & 295 & INT(pincper), 1, INT(SUM(tmask,3)), tmask(:,:,:), & 296 & pmld(:,:), mld_max_bkg(:,:), pinc_chltot_2d(:,:), cchl_p_2d(:,:), & 297 & nbal_active, phyt_avg_bkg_2d(:,:), & 298 & gl_active, pgrow_avg_bkg_2d(:,:), ploss_avg_bkg_2d(:,:), & 299 & subsurf_active, deepneg_active, & 300 & deeppos_active, nutprof_active, & 301 & bstate_3d, outincs_3d, & 302 & diag_active, diag, & 303 & diag_fulldepth_active, diag_fulldepth_3d ) 304 ELSE 305 pmld(:,:) = 0.5 306 307 DO jk = 1, kdeps 308 pinc_chltot_2d(:,:) = pinc_chltot_3d(:,:,jk) 309 cchl_p_2d(:,:) = cchl_p_3d(:,:,jk) 310 phyt_avg_bkg_2d(:,:) = phyt_avg_bkg_3d(:,:,jk) 311 pgrow_avg_bkg_2d(:,:) = pgrow_avg_bkg_3d(:,:,jk) 312 ploss_avg_bkg_2d(:,:) = ploss_avg_bkg_3d(:,:,jk) 313 tmask_2d(:,:,1) = tmask(:,:,jk) 314 bstate_2d(:,:,1,:) = bstate_3d(:,:,jk,:) 315 outincs_2d(:,:,:,:) = 0.0 316 317 CALL bio_analysis( jpi, jpj, 1, gdepw_n(:,:,2), i_tracer, modparm, & 318 & n2be_p, n2be_z, n2be_d, assimparm, & 319 & INT(pincper), 1, INT(SUM(tmask_2d,3)), tmask_2d(:,:,:), & 320 & pmld(:,:), pmld(:,:), pinc_chltot_2d(:,:), cchl_p_2d(:,:), & 321 & nbal_active, phyt_avg_bkg_2d(:,:), & 322 & gl_active, pgrow_avg_bkg_2d(:,:), ploss_avg_bkg_2d(:,:), & 323 & subsurf_active, deepneg_active, & 324 & deeppos_active, nutprof_active, & 325 & bstate_2d, outincs_2d, & 326 & diag_active, diag, & 327 & diag_fulldepth_active, diag_fulldepth_2d ) 328 329 outincs_3d(:,:,jk,:) = outincs_2d(:,:,1,:) 330 END DO 331 ENDIF 288 332 289 333 ! Loop over each grid point partioning the increments 290 phyto 2d_balinc(:,:,:,:) = 0.0334 phyto_balinc(:,:,:,:) = 0.0 291 335 DO jk = 1, jpk 336 IF (kdeps == 1) THEN 337 jkinc = 1 338 ELSE 339 IF (jk > kdeps) THEN 340 EXIT 341 ENDIF 342 jkinc = jk 343 ENDIF 292 344 DO jj = 1, jpj 293 345 DO ji = 1, jpi … … 296 348 IF ( ( tracer_bkg(ji,jj,jk,jpphn) > 0.0 ) .AND. & 297 349 & ( tracer_bkg(ji,jj,jk,jpphd) > 0.0 ) .AND. & 298 & ( pinc_chltot (ji,jj) /= 0.0 ) ) THEN350 & ( pinc_chltot_3d(ji,jj,jkinc) /= 0.0 ) ) THEN 299 351 IF ( ld_chltot ) THEN 300 352 ! Phytoplankton nitrogen split up based on existing ratios … … 305 357 ELSE IF ( ld_chldia .AND. ld_chlnon ) THEN 306 358 ! Phytoplankton nitrogen split up based on assimilation increments 307 zfrac_phn = pinc_chlnon (ji,jj) / pinc_chltot(ji,jj)308 zfrac_phd = pinc_chldia (ji,jj) / pinc_chltot(ji,jj)359 zfrac_phn = pinc_chlnon_3d(ji,jj,jkinc) / pinc_chltot_3d(ji,jj,jkinc) 360 zfrac_phd = pinc_chldia_3d(ji,jj,jkinc) / pinc_chltot_3d(ji,jj,jkinc) 309 361 ENDIF 310 362 … … 318 370 zrat_chd_phd = tracer_bkg(ji,jj,jk,jpchd) / tracer_bkg(ji,jj,jk,jpphd) 319 371 320 phyto 2d_balinc(ji,jj,jk,jpphn) = outincs(ji,jj,jk,i_tracer(2)) * zfrac_phn321 phyto 2d_balinc(ji,jj,jk,jpphd) = outincs(ji,jj,jk,i_tracer(2)) * zfrac_phd322 phyto 2d_balinc(ji,jj,jk,jppds) = phyto2d_balinc(ji,jj,jk,jpphd) * zrat_pds_phd323 phyto 2d_balinc(ji,jj,jk,jpchn) = phyto2d_balinc(ji,jj,jk,jpphn) * zrat_chn_phn324 phyto 2d_balinc(ji,jj,jk,jpchd) = phyto2d_balinc(ji,jj,jk,jpphd) * zrat_chd_phd372 phyto_balinc(ji,jj,jk,jpphn) = outincs_3d(ji,jj,jk,i_tracer(2)) * zfrac_phn 373 phyto_balinc(ji,jj,jk,jpphd) = outincs_3d(ji,jj,jk,i_tracer(2)) * zfrac_phd 374 phyto_balinc(ji,jj,jk,jppds) = phyto_balinc(ji,jj,jk,jpphd) * zrat_pds_phd 375 phyto_balinc(ji,jj,jk,jpchn) = phyto_balinc(ji,jj,jk,jpphn) * zrat_chn_phn 376 phyto_balinc(ji,jj,jk,jpchd) = phyto_balinc(ji,jj,jk,jpphd) * zrat_chd_phd 325 377 ENDIF 326 378 … … 331 383 zfrac_zme = tracer_bkg(ji,jj,jk,jpzme) / & 332 384 & (tracer_bkg(ji,jj,jk,jpzmi) + tracer_bkg(ji,jj,jk,jpzme)) 333 phyto 2d_balinc(ji,jj,jk,jpzmi) = outincs(ji,jj,jk,i_tracer(3)) * zfrac_zmi334 phyto 2d_balinc(ji,jj,jk,jpzme) = outincs(ji,jj,jk,i_tracer(3)) * zfrac_zme385 phyto_balinc(ji,jj,jk,jpzmi) = outincs_3d(ji,jj,jk,i_tracer(3)) * zfrac_zmi 386 phyto_balinc(ji,jj,jk,jpzme) = outincs_3d(ji,jj,jk,i_tracer(3)) * zfrac_zme 335 387 ENDIF 336 388 337 389 ! Nitrogen nutrient straight from balancing scheme 338 phyto 2d_balinc(ji,jj,jk,jpdin) = outincs(ji,jj,jk,i_tracer(1))390 phyto_balinc(ji,jj,jk,jpdin) = outincs_3d(ji,jj,jk,i_tracer(1)) 339 391 340 392 ! Nitrogen detritus straight from balancing scheme 341 phyto 2d_balinc(ji,jj,jk,jpdet) = outincs(ji,jj,jk,i_tracer(4))393 phyto_balinc(ji,jj,jk,jpdet) = outincs_3d(ji,jj,jk,i_tracer(4)) 342 394 343 395 ! DIC straight from balancing scheme 344 phyto 2d_balinc(ji,jj,jk,jpdic) = outincs(ji,jj,jk,i_tracer(5))396 phyto_balinc(ji,jj,jk,jpdic) = outincs_3d(ji,jj,jk,i_tracer(5)) 345 397 346 398 ! Alkalinity straight from balancing scheme 347 phyto 2d_balinc(ji,jj,jk,jpalk) = outincs(ji,jj,jk,i_tracer(6))399 phyto_balinc(ji,jj,jk,jpalk) = outincs_3d(ji,jj,jk,i_tracer(6)) 348 400 349 401 ! Remove diatom silicate increment from nutrient silicate to conserve mass 350 IF ( ( tracer_bkg(ji,jj,jk,jpsil) - phyto 2d_balinc(ji,jj,jk,jppds) ) > 0.0 ) THEN351 phyto 2d_balinc(ji,jj,jk,jpsil) = phyto2d_balinc(ji,jj,jk,jppds) * (-1.0)402 IF ( ( tracer_bkg(ji,jj,jk,jpsil) - phyto_balinc(ji,jj,jk,jppds) ) > 0.0 ) THEN 403 phyto_balinc(ji,jj,jk,jpsil) = phyto_balinc(ji,jj,jk,jppds) * (-1.0) 352 404 ENDIF 353 405 … … 355 407 IF ( ( tracer_bkg(ji,jj,jk,jpdet) > 0.0 ) .AND. ( tracer_bkg(ji,jj,jk,jpdtc) > 0.0 ) ) THEN 356 408 zrat_dtc_det = tracer_bkg(ji,jj,jk,jpdtc) / tracer_bkg(ji,jj,jk,jpdet) 357 phyto 2d_balinc(ji,jj,jk,jpdtc) = phyto2d_balinc(ji,jj,jk,jpdet) * zrat_dtc_det409 phyto_balinc(ji,jj,jk,jpdtc) = phyto_balinc(ji,jj,jk,jpdet) * zrat_dtc_det 358 410 ENDIF 359 411 360 412 ! Do nothing with iron or oxygen for the time being 361 phyto 2d_balinc(ji,jj,jk,jpfer) = 0.0362 phyto 2d_balinc(ji,jj,jk,jpoxy) = 0.0413 phyto_balinc(ji,jj,jk,jpfer) = 0.0 414 phyto_balinc(ji,jj,jk,jpoxy) = 0.0 363 415 364 416 END DO … … 369 421 370 422 ! Initialise individual chlorophyll increments to zero 371 phyto 2d_balinc(:,:,:,jpchn) = 0.0372 phyto 2d_balinc(:,:,:,jpchd) = 0.0423 phyto_balinc(:,:,:,jpchn) = 0.0 424 phyto_balinc(:,:,:,jpchd) = 0.0 373 425 374 426 ! Split up total surface chlorophyll increments 375 DO jj = 1, jpj 376 DO ji = 1, jpi 377 IF ( ( tracer_bkg(ji,jj,1,jpchn) > 0.0 ) .AND. & 378 & ( tracer_bkg(ji,jj,1,jpchd) > 0.0 ) ) THEN 379 IF ( ld_chltot ) THEN 380 ! Chlorophyll split up based on existing ratios 381 zfrac_chn = tracer_bkg(ji,jj,1,jpchn) / & 382 & ( tracer_bkg(ji,jj,1,jpchn) + tracer_bkg(ji,jj,1,jpchd) ) 383 zfrac_chd = tracer_bkg(ji,jj,1,jpchd) / & 384 & ( tracer_bkg(ji,jj,1,jpchn) + tracer_bkg(ji,jj,1,jpchd) ) 385 phyto2d_balinc(ji,jj,1,jpchn) = pinc_chltot(ji,jj) * zfrac_chn 386 phyto2d_balinc(ji,jj,1,jpchd) = pinc_chltot(ji,jj) * zfrac_chd 387 ENDIF 388 IF( ld_chldia ) THEN 389 phyto2d_balinc(ji,jj,1,jpchd) = pinc_chldia(ji,jj) 390 ENDIF 391 IF( ld_chlnon ) THEN 392 phyto2d_balinc(ji,jj,1,jpchn) = pinc_chlnon(ji,jj) 393 ENDIF 394 395 ! Maintain stoichiometric ratios of nitrogen and silicate 396 IF ( ld_chltot .OR. ld_chlnon ) THEN 397 zrat_phn_chn = tracer_bkg(ji,jj,1,jpphn) / tracer_bkg(ji,jj,1,jpchn) 398 phyto2d_balinc(ji,jj,1,jpphn) = phyto2d_balinc(ji,jj,1,jpchn) * zrat_phn_chn 399 ENDIF 400 IF ( ld_chltot .OR. ld_chldia ) THEN 401 zrat_phd_chd = tracer_bkg(ji,jj,1,jpphd) / tracer_bkg(ji,jj,1,jpchd) 402 phyto2d_balinc(ji,jj,1,jpphd) = phyto2d_balinc(ji,jj,1,jpchd) * zrat_phd_chd 403 zrat_pds_chd = tracer_bkg(ji,jj,1,jppds) / tracer_bkg(ji,jj,1,jpchd) 404 phyto2d_balinc(ji,jj,1,jppds) = phyto2d_balinc(ji,jj,1,jpchd) * zrat_pds_chd 405 ENDIF 406 ENDIF 427 DO jk = 1, kdeps 428 DO jj = 1, jpj 429 DO ji = 1, jpi 430 IF ( ( tracer_bkg(ji,jj,jk,jpchn) > 0.0 ) .AND. & 431 & ( tracer_bkg(ji,jj,jk,jpchd) > 0.0 ) ) THEN 432 IF ( ld_chltot ) THEN 433 ! Chlorophyll split up based on existing ratios 434 zfrac_chn = tracer_bkg(ji,jj,jk,jpchn) / & 435 & ( tracer_bkg(ji,jj,jk,jpchn) + tracer_bkg(ji,jj,jk,jpchd) ) 436 zfrac_chd = tracer_bkg(ji,jj,jk,jpchd) / & 437 & ( tracer_bkg(ji,jj,jk,jpchn) + tracer_bkg(ji,jj,jk,jpchd) ) 438 phyto_balinc(ji,jj,jk,jpchn) = pinc_chltot_3d(ji,jj,jk) * zfrac_chn 439 phyto_balinc(ji,jj,jk,jpchd) = pinc_chltot_3d(ji,jj,jk) * zfrac_chd 440 ENDIF 441 IF( ld_chldia ) THEN 442 phyto_balinc(ji,jj,jk,jpchd) = pinc_chldia_3d(ji,jj,jk) 443 ENDIF 444 IF( ld_chlnon ) THEN 445 phyto_balinc(ji,jj,jk,jpchn) = pinc_chlnon_3d(ji,jj,jk) 446 ENDIF 447 448 ! Maintain stoichiometric ratios of nitrogen and silicate 449 IF ( ld_chltot .OR. ld_chlnon ) THEN 450 zrat_phn_chn = tracer_bkg(ji,jj,jk,jpphn) / tracer_bkg(ji,jj,jk,jpchn) 451 phyto_balinc(ji,jj,jk,jpphn) = phyto_balinc(ji,jj,jk,jpchn) * zrat_phn_chn 452 ENDIF 453 IF ( ld_chltot .OR. ld_chldia ) THEN 454 zrat_phd_chd = tracer_bkg(ji,jj,jk,jpphd) / tracer_bkg(ji,jj,jk,jpchd) 455 phyto_balinc(ji,jj,jk,jpphd) = phyto_balinc(ji,jj,jk,jpchd) * zrat_phd_chd 456 zrat_pds_chd = tracer_bkg(ji,jj,jk,jppds) / tracer_bkg(ji,jj,jk,jpchd) 457 phyto_balinc(ji,jj,jk,jppds) = phyto_balinc(ji,jj,jk,jpchd) * zrat_pds_chd 458 ENDIF 459 ENDIF 460 END DO 407 461 END DO 408 462 END DO 409 463 410 ! Propagate through mixed layer 411 DO jj = 1, jpj 412 DO ji = 1, jpi 413 ! 414 jkmax = jpk-1 415 DO jk = jpk-1, 1, -1 416 IF ( ( pmld(ji,jj) > gdepw_n(ji,jj,jk) ) .AND. & 417 & ( pmld(ji,jj) <= gdepw_n(ji,jj,jk+1) ) ) THEN 418 pmld(ji,jj) = gdepw_n(ji,jj,jk+1) 419 jkmax = jk 420 ENDIF 464 IF (kdeps == 1) THEN 465 ! Propagate through mixed layer 466 DO jj = 1, jpj 467 DO ji = 1, jpi 468 ! 469 jkmax = jpk-1 470 DO jk = jpk-1, 1, -1 471 IF ( ( pmld(ji,jj) > gdepw_n(ji,jj,jk) ) .AND. & 472 & ( pmld(ji,jj) <= gdepw_n(ji,jj,jk+1) ) ) THEN 473 pmld(ji,jj) = gdepw_n(ji,jj,jk+1) 474 jkmax = jk 475 ENDIF 476 END DO 477 ! 478 DO jk = 2, jkmax 479 phyto_balinc(ji,jj,jk,jpchn) = phyto_balinc(ji,jj,1,jpchn) 480 phyto_balinc(ji,jj,jk,jpchd) = phyto_balinc(ji,jj,1,jpchd) 481 phyto_balinc(ji,jj,jk,jpphn) = phyto_balinc(ji,jj,1,jpphn) 482 phyto_balinc(ji,jj,jk,jpphd) = phyto_balinc(ji,jj,1,jpphd) 483 phyto_balinc(ji,jj,jk,jppds) = phyto_balinc(ji,jj,1,jppds) 484 END DO 485 ! 421 486 END DO 422 ! 423 DO jk = 2, jkmax 424 phyto2d_balinc(ji,jj,jk,jpchn) = phyto2d_balinc(ji,jj,1,jpchn) 425 phyto2d_balinc(ji,jj,jk,jpchd) = phyto2d_balinc(ji,jj,1,jpchd) 426 phyto2d_balinc(ji,jj,jk,jpphn) = phyto2d_balinc(ji,jj,1,jpphn) 427 phyto2d_balinc(ji,jj,jk,jpphd) = phyto2d_balinc(ji,jj,1,jpphd) 428 phyto2d_balinc(ji,jj,jk,jppds) = phyto2d_balinc(ji,jj,1,jppds) 429 END DO 430 ! 431 END DO 432 END DO 487 END DO 488 ENDIF 433 489 434 490 ! Set other balancing increments to zero 435 phyto 2d_balinc(:,:,:,jpzmi) = 0.0436 phyto 2d_balinc(:,:,:,jpzme) = 0.0437 phyto 2d_balinc(:,:,:,jpdin) = 0.0438 phyto 2d_balinc(:,:,:,jpsil) = 0.0439 phyto 2d_balinc(:,:,:,jpfer) = 0.0440 phyto 2d_balinc(:,:,:,jpdet) = 0.0441 phyto 2d_balinc(:,:,:,jpdtc) = 0.0442 phyto 2d_balinc(:,:,:,jpdic) = 0.0443 phyto 2d_balinc(:,:,:,jpalk) = 0.0444 phyto 2d_balinc(:,:,:,jpoxy) = 0.0491 phyto_balinc(:,:,:,jpzmi) = 0.0 492 phyto_balinc(:,:,:,jpzme) = 0.0 493 phyto_balinc(:,:,:,jpdin) = 0.0 494 phyto_balinc(:,:,:,jpsil) = 0.0 495 phyto_balinc(:,:,:,jpfer) = 0.0 496 phyto_balinc(:,:,:,jpdet) = 0.0 497 phyto_balinc(:,:,:,jpdtc) = 0.0 498 phyto_balinc(:,:,:,jpdic) = 0.0 499 phyto_balinc(:,:,:,jpalk) = 0.0 500 phyto_balinc(:,:,:,jpoxy) = 0.0 445 501 446 502 ENDIF … … 452 508 DO jn = 1, jptra 453 509 DO jk = 1, jpk 454 phyto 2d_balinc(:,:,jk,jn) = phyto2d_balinc(:,:,jk,jn) * ( 1.0 - mask_itf(:,:) )510 phyto_balinc(:,:,jk,jn) = phyto_balinc(:,:,jk,jn) * ( 1.0 - mask_itf(:,:) ) 455 511 END DO 456 512 END DO 457 513 ENDIF 458 514 459 END SUBROUTINE asm_phyto 2d_bal_medusa515 END SUBROUTINE asm_phyto_bal_medusa 460 516 461 517 #else … … 464 520 !!---------------------------------------------------------------------- 465 521 CONTAINS 466 SUBROUTINE asm_phyto2d_bal_medusa( ld_chltot, & 467 & pinc_chltot, & 468 & ld_chldia, & 469 & pinc_chldia, & 470 & ld_chlnon, & 471 & pinc_chlnon, & 472 & ld_phytot, & 473 & pinc_phytot, & 474 & ld_phydia, & 475 & pinc_phydia, & 476 & ld_phynon, & 477 & pinc_phynon, & 478 & pincper, & 479 & p_maxchlinc, ld_phytobal, pmld, & 480 & pgrow_avg_bkg, ploss_avg_bkg, & 481 & phyt_avg_bkg, mld_max_bkg, & 482 & tracer_bkg, phyto2d_balinc ) 522 SUBROUTINE asm_phyto_bal_medusa( kdeps, & 523 & ld_chltot, & 524 & pinc_chltot_3d, & 525 & ld_chldia, & 526 & pinc_chldia_3d, & 527 & ld_chlnon, & 528 & pinc_chlnon_3d, & 529 & ld_phytot, & 530 & pinc_phytot_3d, & 531 & ld_phydia, & 532 & pinc_phydia_3d, & 533 & ld_phynon, & 534 & pinc_phynon_3d, & 535 & pincper, & 536 & p_maxchlinc, ld_phytobal, pmld, & 537 & pgrow_avg_bkg_3d, ploss_avg_bkg_3d, & 538 & phyt_avg_bkg_3d, mld_max_bkg, & 539 & tracer_bkg, phyto_balinc ) 540 INTEGER :: kdeps 483 541 LOGICAL :: ld_chltot 484 REAL :: pinc_chltot (:,:)542 REAL :: pinc_chltot_3d(:,:,:) 485 543 LOGICAL :: ld_chldia 486 REAL :: pinc_chldia (:,:)544 REAL :: pinc_chldia_3d(:,:,:) 487 545 LOGICAL :: ld_chlnon 488 REAL :: pinc_chlnon (:,:)546 REAL :: pinc_chlnon_3d(:,:,:) 489 547 LOGICAL :: ld_phytot 490 REAL :: pinc_phytot (:,:)548 REAL :: pinc_phytot_3d(:,:,:) 491 549 LOGICAL :: ld_phydia 492 REAL :: pinc_phydia (:,:)550 REAL :: pinc_phydia_3d(:,:,:) 493 551 LOGICAL :: ld_phynon 494 REAL :: pinc_phynon (:,:)552 REAL :: pinc_phynon_3d(:,:,:) 495 553 REAL :: pincper 496 554 REAL :: p_maxchlinc 497 555 LOGICAL :: ld_phytobal 498 556 REAL :: pmld(:,:) 499 REAL :: pgrow_avg_bkg (:,:)500 REAL :: ploss_avg_bkg (:,:)501 REAL :: phyt_avg_bkg (:,:)557 REAL :: pgrow_avg_bkg_3d(:,:,:) 558 REAL :: ploss_avg_bkg_3d(:,:,:) 559 REAL :: phyt_avg_bkg_3d(:,:,:) 502 560 REAL :: mld_max_bkg(:,:) 503 561 REAL :: tracer_bkg(:,:,:,:) 504 REAL :: phyto 2d_balinc(:,:,:,:)505 WRITE(*,*) 'asm_phyto 2d_bal_medusa: You should not have seen this print! error?'506 END SUBROUTINE asm_phyto 2d_bal_medusa562 REAL :: phyto_balinc(:,:,:,:) 563 WRITE(*,*) 'asm_phyto_bal_medusa: You should not have seen this print! error?' 564 END SUBROUTINE asm_phyto_bal_medusa 507 565 #endif 508 566 509 567 !!====================================================================== 510 END MODULE asmphyto 2dbal_medusa568 END MODULE asmphytobal_medusa
Note: See TracChangeset
for help on using the changeset viewer.