Changeset 13677 for branches/UKMO/dev_r5518_GO6_package_FOAMv14_biophys/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90

Timestamp:

2020-10-26T18:37:31+01:00 (4 years ago)

Author:

dford

Message:

Add option for MEDUSA to use RGB light scheme.

File:

• branches/UKMO/dev_r5518_GO6_package_FOAMv14_biophys/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90 (modified) (4 diffs)

branches/UKMO/dev_r5518_GO6_package_FOAMv14_biophys/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90

@@ -28 +28 @@
 
    PUBLIC   trc_opt_medusa   ! called in trcprg.F90
+
+   REAL(wp), DIMENSION(3,61) :: okrgb   !: tabulated attenuation coefficients for RGB absorption
 
    !!* Substitution
@@ -50 +52 @@
       !!---------------------------------------------------------------------
       INTEGER, INTENT( in ) ::   kt   ! index of the time stepping
-      INTEGER  ::   ji, jj, jk
+      INTEGER  ::   ji, jj, jk, irgb
       REAL(wp) ::   zpig                                    ! total pigment
       REAL(wp) ::   zkr                                     ! total absorption coefficient in red
@@ -58 +60 @@
       REAL(wp), DIMENSION(jpi,jpj)     ::   zpar0m          ! irradiance just below the surface
       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zparr, zparg    ! red and green compound of par
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zekb, zekg, zekr
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze1, ze2, ze3
 
       CHARACTER (len=25) :: charout
@@ -113 +117 @@
       ! ---------------------
 
-      DO jk = 2, jpk                     ! determination of local par in w levels
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               totchl =trn(ji,jj,jk-1,jpchn)+trn(ji,jj,jk-1,jpchd)
-               zpig = MAX( TINY(0.), totchl/rpig) 
-               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
-               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
-               zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) )
-               zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) )
+      IF ( ln_rgb ) THEN
+         ! Mean PAR in T levels using RGB scheme
+         ! Should be same as in traqsr, but T rather than W levels
+         IF( kt == nittrc000 ) THEN
+            CALL trc_oce_rgb( okrgb )
+         ENDIF
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  totchl = trn(ji,jj,jk,jpchn) + trn(ji,jj,jk,jpchd)
+                  totchl = MIN( 10. , MAX( 0.05, totchl ) )
+                  irgb = NINT( 41 + 20.* LOG10( totchl ) + 1.e-15 )
+                  !                                                         
+                  zekb(ji,jj,jk) = okrgb(1,irgb) * fse3t(ji,jj,jk)
+                  zekg(ji,jj,jk) = okrgb(2,irgb) * fse3t(ji,jj,jk)
+                  zekr(ji,jj,jk) = okrgb(3,irgb) * fse3t(ji,jj,jk)
+               END DO
             END DO
-        END DO
-      END DO
-
-      DO jk = 1, jpkm1                   ! mean par in t levels
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               totchl =trn(ji,jj,jk  ,jpchn)+trn(ji,jj,jk  ,jpchd)
-               zpig = MAX( TINY(0.), totchl/rpig) 
-               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
-               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
-               zparr(ji,jj,jk)    = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) )
-               zparg(ji,jj,jk)    = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) )
-               xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
+         END DO
+         ze1(:,:,1) = zpar0m(:,:) * EXP( -0.5 * zekb(:,:,1) ) / 3.0
+         ze2(:,:,1) = zpar0m(:,:) * EXP( -0.5 * zekg(:,:,1) ) / 3.0
+         ze3(:,:,1) = zpar0m(:,:) * EXP( -0.5 * zekr(:,:,1) ) / 3.0
+         !
+         DO jk = 2, jpk
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP( -0.5 * ( zekb(ji,jj,jk-1) + zekb(ji,jj,jk) ) )
+                  ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP( -0.5 * ( zekg(ji,jj,jk-1) + zekg(ji,jj,jk) ) )
+                  ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP( -0.5 * ( zekr(ji,jj,jk-1) + zekr(ji,jj,jk) ) )
+                  xpar(ji,jj,jk) = MAX( ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk), 1.e-15 )
+               END DO
             END DO
          END DO
-      END DO
+      ELSE
+         DO jk = 2, jpk                     ! determination of local par in w levels
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  totchl =trn(ji,jj,jk-1,jpchn)+trn(ji,jj,jk-1,jpchd)
+                  zpig = MAX( TINY(0.), totchl/rpig) 
+                  zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
+                  zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
+                  zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) )
+                  zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) )
+               END DO
+           END DO
+         END DO
+
+         DO jk = 1, jpkm1                   ! mean par in t levels
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  totchl =trn(ji,jj,jk  ,jpchn)+trn(ji,jj,jk  ,jpchd)
+                  zpig = MAX( TINY(0.), totchl/rpig) 
+                  zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
+                  zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
+                  zparr(ji,jj,jk)    = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) )
+                  zparg(ji,jj,jk)    = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) )
+                  xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
+               END DO
+            END DO
+         END DO
+      ENDIF
 
       ! 3. Determination of euphotic layer depth