Changeset 777 for branches/dev_001_GM/NEMO/TOP_SRC/LOBSTER/trcopt.F90
- Timestamp:
- 2007-12-19T19:40:57+01:00 (16 years ago)
- File:
-
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_001_GM/NEMO/TOP_SRC/LOBSTER/trcopt.F90
r774 r777 1 CC $Header$ 2 CDIR$ LIST 3 SUBROUTINE trcopt(kt) 4 CCC--------------------------------------------------------------------- 5 CCC 6 CCC ROUTINE trcopt 7 CCC ******************* 8 CCC 9 CCC PURPOSE : 10 CCC --------- 11 CCC computes the light propagation in the water column 12 CCC and the euphotic layer depth 13 CCC 14 CCC 15 CC METHOD : 16 CC ------- 17 CC 18 CC multitasked on vertical slab (jj-loop) 19 CC local par is computed in w layers using light propagation 20 CC mean par in t layers are computed by integration 21 CC 22 CC 23 CC INPUT : 24 CC ----- 25 CC argument 26 CC ktask : task identificator 27 CC kt : time step 28 CC COMMON 29 CC /comcoo/ : orthogonal curvilinear coordinates 30 CC and scale factors 31 CC depths 32 CC /comzdf/ : avt vertical eddy diffusivity 33 CC /comqsr/ : solar radiation 34 CC /comtsk/ : multitasking 35 CC /cotopt/ : optical parameters 36 CC /cotbio/ : biological parameters 37 CC 38 CC OUTPUT : 39 CC ------ 40 CC COMMON 41 CC /cotopt/ : optical parameters 42 CC 43 CC WORKSPACE : 44 CC --------- 45 CC local zparr : red compound of par 46 CC zparg : green compound of par 47 CC zpar0m : irradiance just below the surface 48 CC zpar100 : irradiance at euphotic layer depth 49 CC zkr : total absorption coefficient in red 50 CC zkg : total absorption coefficient in green 51 CC zpig : total pigment 52 CC imaske : euphotic layer mask 53 CC itabe : euphotic layer last k index 54 CC 55 CC COMMON 56 CC 57 CC EXTERNAL : no 58 CC -------- 59 CC 60 CC REFERENCES : no 61 CC ---------- 62 CC 63 CC MODIFICATIONS: 64 CC -------------- 65 CC original : 95-05 (M. Levy) 66 CC 99-09 (J-M Andre & M. Levy) 67 CC modifications : 99-11 (C. Menkes M.A. Foujols) itabe initial. 68 CC modifications : 00-02 (M.A. Foujols) change x**y par exp(y*log(x)) 69 CC---------------------------------------------------------------------- 70 CDIR$ NOLIST 1 MODULE trcopt 2 !!====================================================================== 3 !! *** MODULE trcopt *** 4 !! TOP : LOBSTER Compute the light availability in the water column 5 !!====================================================================== 6 !! History : - ! 1995-05 (M. Levy) Original code 7 !! - ! 1999-09 (J.-M. Andre, M. Levy) 8 !! - ! 1999-11 (C. Menkes, M.-A. Foujols) itabe initial 9 !! - ! 2000-02 (M.A. Foujols) change x**y par exp(y*log(x)) 10 !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 11 !!---------------------------------------------------------------------- 12 #if defined key_lobster 13 !!---------------------------------------------------------------------- 14 !! 'key_lobster' LOBSTER bio-model 15 !!---------------------------------------------------------------------- 16 !! trc_opt : Compute the light availability in the water column 17 !!---------------------------------------------------------------------- 18 USE oce_trc ! 19 USE trp_trc 20 USE sms 71 21 72 USE oce_trc 73 USE trp_trc 74 USE sms 75 IMPLICIT NONE 76 CDIR$ LIST 77 CCC--------------------------------------------------------------------- 78 CCC OPA8, LODYC (11/96) 79 CCC--------------------------------------------------------------------- 80 CC---------------------------------------------------------------------- 81 CC local declarations 82 CC ================== 83 INTEGER kt 22 IMPLICIT NONE 23 PRIVATE 84 24 85 #if defined key_top && defined key_lobster 86 C 87 INTEGER ji,jj,jk,jn,in 25 PUBLIC trc_opt ! called in trcprg.F90 88 26 89 REAL zpig,zkr,zkg 27 !!* Substitution 28 # include "domzgr_substitute.h90" 29 !!---------------------------------------------------------------------- 30 !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007) 31 !! $Id:$ 32 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 33 !!---------------------------------------------------------------------- 90 34 91 REAL zparr(jpi,jpk),zparg(jpi,jpk) 92 REAL zpar0m(jpi),zpar100(jpi) 93 INTEGER itabe(jpi),imaske(jpi,jpk) 94 CC---------------------------------------------------------------------- 95 CC statement functions 96 CC =================== 97 CDIR$ NOLIST 98 #include "domzgr_substitute.h90" 99 CDIR$ LIST 100 CCC--------------------------------------------------------------------- 101 CCC OPA8, LODYC (15/11/96) 102 CCC--------------------------------------------------------------------- 103 C 104 C 105 C find Phytoplancton index - test CTRCNM 106 C 107 in=0 108 DO jn = 1,jptra 109 IF ((ctrcnm(jn) .EQ. 'PHY') .OR. 110 $ (ctrcnm(jn) .EQ. 'PHYTO') ) THEN 111 112 in = jn 113 END IF 35 CONTAINS 36 37 SUBROUTINE trc_opt( kt ) 38 !!--------------------------------------------------------------------- 39 !! *** ROUTINE trc_opt *** 40 !! 41 !! ** Purpose : computes the light propagation in the water column 42 !! and the euphotic layer depth 43 !! 44 !! ** Method : local par is computed in w layers using light propagation 45 !! mean par in t layers are computed by integration 46 !!--------------------------------------------------------------------- 47 INTEGER, INTENT( in ) :: kt ! index of the time stepping 48 INTEGER :: ji, jj, jk 49 INTEGER , DIMENSION(jpi,jpj) :: itabe ! euphotic layer last k index 50 INTEGER , DIMENSION(jpi,jpj,jpk) :: imaske ! euphotic layer mask 51 REAL(wp) :: zpig ! total pigment 52 REAL(wp) :: zkr ! total absorption coefficient in red 53 REAL(wp) :: zkg ! total absorption coefficient in green 54 REAL(wp), DIMENSION(jpi,jpj) :: zpar100 ! irradiance at euphotic layer depth 55 REAL(wp), DIMENSION(jpi,jpj) :: zpar0m ! irradiance just below the surface 56 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zparr, zparg ! red and green compound of par 57 !!--------------------------------------------------------------------- 58 59 IF( kt == nit000 ) THEN 60 IF(lwp) WRITE(numout,*) 61 IF(lwp) WRITE(numout,*) ' trc_opt: LOBSTER optic-model' 62 IF(lwp) WRITE(numout,*) ' ~~~~~~~' 63 ENDIF 64 65 ! determination of surface irradiance 66 ! ----------------------------------- 67 zpar0m (:,:) = qsr (:,:) * 0.43 68 zpar100(:,:) = zpar0m(:,:) * 0.01 69 xpar (:,:,1) = zpar0m(:,:) 70 zparr (:,:,1) = 0.5 * zpar0m(:,:) 71 zparg (:,:,1) = 0.5 * zpar0m(:,:) 72 73 74 ! determination of xpar 75 ! --------------------- 76 77 DO jk = 2, jpk ! determination of local par in w levels 78 DO jj = 1, jpj 79 DO ji = 1, jpi 80 zpig = MAX( TINY(0.), trn(ji,jj,jk-1,jpphy) ) * 12 * redf / rcchl / rpig 81 zkr = xkr0 + xkrp * EXP( xlr * LOG( zpig ) ) 82 zkg = xkg0 + xkgp * EXP( xlg * LOG( zpig ) ) 83 zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) ) 84 zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) ) 85 END DO 86 END DO 114 87 END DO 115 IF (in.eq.0) THEN116 IF (lwp) THEN117 WRITE (numout,*)118 $ ' Problem trcopt : PHY or PHYTO not found '119 CALL FLUSH(numout)120 ENDIF121 ENDIF122 C123 C vertical slab124 C ===============125 C126 DO 1000 jj = 1,jpj127 C128 C129 C 1. determination of surface irradiance130 C --------------------------------------131 C132 C133 DO ji = 1,jpi134 zpar0m(ji) = qsr(ji,jj)*0.43135 zpar100(ji) = zpar0m(ji)*0.01136 xpar(ji,jj,1) = zpar0m(ji)137 zparr(ji,1) = 0.5* zpar0m(ji)138 zparg(ji,1) = 0.5* zpar0m(ji)139 END DO140 88 141 C 142 C 2. determination of xpar 143 C ------------------------ 144 C 145 C determination of local par in w levels 146 DO jk = 2,jpk 147 DO ji = 1,jpi 148 zpig = max(tiny(0.),trn(ji,jj,jk - 1,in))*12*redf/rcchl/rpig 149 zkr = xkr0 + xkrp*exp(xlr*log(zpig)) 150 zkg = xkg0 + xkgp*exp(xlg*log(zpig)) 151 zparr(ji,jk) = zparr(ji,jk - 1) 152 $ *exp( -zkr*fse3t(ji,jj,jk - 1) ) 153 zparg(ji,jk) = zparg(ji,jk - 1) 154 $ *exp( -zkg*fse3t(ji,jj,jk - 1) ) 155 END DO 156 END DO 89 DO jk = 1, jpkm1 ! mean par in t levels 90 DO jj = 1, jpj 91 DO ji = 1, jpi 92 zpig = MAX( TINY(0.), trn(ji,jj,jk,jpphy) ) * 12 * redf / rcchl / rpig 93 zkr = xkr0 + xkrp * EXP( xlr * LOG( zpig ) ) 94 zkg = xkg0 + xkgp * EXP( xlg * LOG( zpig ) ) 95 zparr(ji,jj,jk) = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) ) 96 zparg(ji,jj,jk) = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) ) 97 xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 ) 98 END DO 99 END DO 100 END DO 157 101 158 C 159 C mean par in t levels 160 DO jk = 1,jpkm1 161 DO ji = 1,jpi 162 zpig = max(tiny(0.),trn(ji,jj,jk ,in))*12*redf/rcchl/rpig 163 zkr = xkr0 + xkrp*exp(xlr*log(zpig)) 164 zkg = xkg0 + xkgp*exp(xlg*log(zpig)) 165 zparr(ji,jk) = zparr(ji,jk) / zkr / fse3t(ji,jj,jk) 166 $ * ( 1 - exp( -zkr*fse3t(ji,jj,jk) ) ) 167 zparg(ji,jk) = zparg(ji,jk) / zkg / fse3t(ji,jj,jk) 168 $ * ( 1 - exp( -zkg*fse3t(ji,jj,jk) ) ) 169 xpar(ji,jj,jk) = max(zparr(ji,jk) 170 $ + zparg(ji,jk),1.e-15) 171 END DO 172 END DO 173 C 174 C 175 C 4. determination of euphotic layer depth 176 C ---------------------------------------- 177 C 178 C imaske equal 1 in the euphotic layer, and 0 without 179 C 180 DO jk = 1,jpk 181 DO ji = 1,jpi 182 imaske(ji,jk) = 0 183 IF (xpar(ji,jj,jk) .GE. zpar100(ji)) imaske(ji,jk) = 1 184 END DO 185 END DO 186 C 187 DO ji = 1,jpi 188 itabe(ji) = 0 189 END DO 190 C 191 DO jk = 1,jpk 192 DO ji = 1,jpi 193 itabe(ji) = itabe(ji) + imaske(ji,jk) 194 END DO 195 END DO 196 C 197 DO ji = 1,jpi 198 itabe(ji) = max(1,itabe(ji)) 199 xze(ji,jj) = fsdepw(ji,jj,itabe(ji) + 1) 200 END DO 201 C 202 C 203 C END of slab 204 C =========== 205 C 206 1000 CONTINUE 207 C 102 ! determination of euphotic layer depth (xze) 103 ! ------------------------------------- 104 105 DO jk = 1, jpk ! imaske equal 1 in the euphotic layer, and 0 without 106 DO jj = 1, jpj 107 DO ji = 1,jpi 108 IF( xpar(ji,jj,jk) >= zpar100(ji,jj) ) THEN 109 imaske(ji,jj,jk) = 1 110 ELSE 111 imaske(ji,jj,jk) = 0 112 ENDIF 113 END DO 114 END DO 115 END DO 116 ! ! sum of imaske Cover the vertical with a minimim value of 1 117 itabe(:,:) = 1 ! surface value setto 1 <=> set a ninimum value to 1 118 DO jk = 2, jpk 119 DO jj = 1, jpj 120 DO ji = 1,jpi 121 itabe(ji,jj) = itabe(ji,jj) + imaske(ji,jj,jk) 122 END DO 123 END DO 124 END DO 125 DO jj = 1, jpj ! converte the number of level into depth 126 DO ji = 1,jpi 127 xze(ji,jj) = fsdepw(ji,jj,itabe(ji,jj)+1) 128 END DO 129 END DO 130 ! 131 END SUBROUTINE trc_opt 132 208 133 #else 209 C 210 C no passive tracers 211 C 212 #endif 213 C 214 RETURN 215 END 134 !!====================================================================== 135 !! Dummy module : No PISCES bio-model 136 !!====================================================================== 137 CONTAINS 138 SUBROUTINE trc_opt( kt ) ! Empty routine 139 INTEGER, INTENT( in ) :: kt 140 WRITE(*,*) 'trc_opt: You should not have seen this print! error?', kt 141 END SUBROUTINE trc_opt 142 #endif 143 144 !!====================================================================== 145 END MODULE trcopt
Note: See TracChangeset
for help on using the changeset viewer.
