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 |
---|
71 | |
---|
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 |
---|
84 | |
---|
85 | #if defined key_passivetrc && defined key_trc_lobster1 |
---|
86 | C |
---|
87 | INTEGER ji,jj,jk,jn,in |
---|
88 | |
---|
89 | REAL zpig,zkr,zkg |
---|
90 | |
---|
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 |
---|
114 | END DO |
---|
115 | IF (in.eq.0) THEN |
---|
116 | IF (lwp) THEN |
---|
117 | WRITE (numout,*) |
---|
118 | $ ' Problem trcopt : PHY or PHYTO not found ' |
---|
119 | CALL FLUSH(numout) |
---|
120 | ENDIF |
---|
121 | ENDIF |
---|
122 | C |
---|
123 | C vertical slab |
---|
124 | C =============== |
---|
125 | C |
---|
126 | DO 1000 jj = 1,jpj |
---|
127 | C |
---|
128 | C |
---|
129 | C 1. determination of surface irradiance |
---|
130 | C -------------------------------------- |
---|
131 | C |
---|
132 | C |
---|
133 | DO ji = 1,jpi |
---|
134 | zpar0m(ji) = qsr(ji,jj)*0.43 |
---|
135 | zpar100(ji) = zpar0m(ji)*0.01 |
---|
136 | xpar(ji,jj,1) = zpar0m(ji) |
---|
137 | zparr(ji,1) = 0.5* zpar0m(ji) |
---|
138 | zparg(ji,1) = 0.5* zpar0m(ji) |
---|
139 | END DO |
---|
140 | |
---|
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 |
---|
157 | |
---|
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 |
---|
208 | #else |
---|
209 | C |
---|
210 | C no passive tracers |
---|
211 | C |
---|
212 | #endif |
---|
213 | C |
---|
214 | RETURN |
---|
215 | END |
---|