The TELEMAC-MASCARET system  trunk
source_waq.F
Go to the documentation of this file.
1 ! **********************
2  SUBROUTINE source_waq
3 ! **********************
4 !
5  &(npoin3,npoin2,texp,timp,tn,hprop,u,v,cf,
6  & t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12, t2_1,t2_2,t2_3,
7  & patmos,dimm,nplan,
8  & latit,longit,at,mardat,martim,zprop,rho)
9 !
10 !***********************************************************************
11 ! WAQTEL V8P2
12 !***********************************************************************
13 !
14 !brief GIVES CONTRIBUTION OF WAQ PROCESSES TO SOURCE TERMS
15 !+ FOR THE TRACER.
16 !
17 !history R. ATA
18 !+ 21/09/2014
19 !+ V7P0
20 !+ CREATION
21 !
22 !history M. JODEAU (LNHE)
23 !+ 18/05/2016
24 !+ V7P3
25 !+ + AED2 source terms
26 !
27 !history S.E. BOURBAN (HRW)
28 !+ 21/09/2017
29 !+ V7P3
30 !+ WAQPROCESS is now a prime number, so that multiple processes
31 !+ can be called by multiplication of the prime numbers.
32 !
33 !history C.-T. PHAM (LNHE)
34 !+ 31/07/2019
35 !+ V8P1
36 !+ Density RHO computed in drsurr in TELEMAC-3D and given to
37 !+ WAQTEL as optional (none in 2D) rather than computed again
38 !
39 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
40 !| AT |-->| TIME IN SECONDS
41 !| DIMM |-->| 2D OR 3D
42 !| HPROP |-->| PROPAGATION DEPTH (2D)
43 !| LONGIT |-->| LONGITUTE OF ORIGIN POINT
44 !| LATIT |-->| LATITUDE OF ORIGIN POINT
45 !| MAXSCE |-->| MAXIMUM NUMBER OF SOURCES
46 !| MAXTRA |-->| MAXIMUM NUMBER OF TRACERS
47 !| NPLAN |-->| NUMBER OF VERTICAL PLANES
48 !| RHO |-->| WATER DENSITY
49 !| T1,..,T12 |<->| WORKING STRUCTURES
50 !| T2_1,T2_2 |<->| 2D WORKING STRUCTURES
51 !| TETAT |-->| COEFFICIENT OF IMPLICITATION FOR TRACERS.
52 !| TEXP |-->| EXPLICIT SOURCE TERM.
53 !| TIMP |-->| IMPLICIT SOURCE TERM.
54 !| TN |-->| TRACERS AT TIME N
55 !| TSCE |-->| PRESCRIBED VALUES OF TRACERS AT POINT SOURCES
56 !| TSCEXP |<--| EXPLICIT SOURCE TERM OF POINT SOURCES
57 !| | | IN TRACER EQUATION, EQUAL TO:
58 !| | | TSCE - ( 1 - TETAT ) TN
59 !| YASMI |<--| IF YES, THERE ARE IMPLICIT SOURCE TERMS
60 !| ZPROP |-->| Z COORDINATES FOR 3D NODES
61 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
62 !
63  USE bief
66  USE interface_waqtel, ex_source_waq => source_waq
67 !
68  IMPLICIT NONE
69 !
70 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
71 !
72  INTEGER , INTENT(IN) :: NPOIN3,DIMM
73  INTEGER , INTENT(IN) :: NPLAN,NPOIN2
74  INTEGER , INTENT(IN) :: MARDAT(3),MARTIM(3)
75  DOUBLE PRECISION,INTENT(IN ) :: LATIT,LONGIT,AT
76  TYPE(bief_obj), INTENT(IN) :: TN,HPROP,CF,U,V
77  TYPE(bief_obj), INTENT(IN) :: PATMOS,ZPROP
78  TYPE(bief_obj), INTENT(INOUT) :: TEXP,TIMP
79  TYPE(bief_obj), INTENT(INOUT) :: T1,T2,T3,T4,T5,T6
80  TYPE(bief_obj), INTENT(INOUT) :: T7,T8,T9,T10,T11,T12
81  TYPE(bief_obj), INTENT(INOUT) :: T2_1,T2_2,T2_3
82 ! OPTIONAL
83  TYPE(bief_obj), INTENT(IN),OPTIONAL :: RHO
84 !
85 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
86 !
87  INTEGER :: J,ITRAC,IERR
88  LOGICAL :: FOUND
89 !
90  found = .false.
91 !
92 !-----------------------------------------------------------------------
93 !
94 ! O2 MODULE
95 !
96  IF( 2*int(waqprocess/2).EQ.waqprocess ) THEN
97  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS~D_O2'
98 !
99  IF(dimm.EQ.2)THEN
100  CALL calcs2d_o2
101  & (npoin2,wattemp,o2satu,demben,formk2,k1,k44,k22,
102  & photo,resp,tn,texp,timp,t2,t3,t4,hprop,u,v,debug)
103 !
104 ! YASMI(IND_O2) = YASMI(IND_O2) .OR. .FALSE.
105 ! YASMI(IND_OL) = .TRUE.
106 ! YASMI(IND_NH4) = .TRUE.
107 !
108  ELSEIF(dimm.EQ.3)THEN
109  CALL calcs3d_o2
110  & (npoin3,npoin2,nplan,wattemp,o2satu,demben,
111  & formk2,k1,k44,k22,photo,resp,tn,texp,timp,
112  & t1,t2,t2_1,hprop,zprop,u,v)
113 !
114  texp%ADR(ind_o2)%P%TYPR='Q'
115  timp%ADR(ind_ol)%P%TYPR='Q'
116  timp%ADR(ind_nh4)%P%TYPR='Q'
117 !
118  ENDIF
119  found = .true.
120  IF(debug.GT.0) WRITE(lu,*) 'BACK FROMCALCS~D_O2'
121  ENDIF
122 !
123 !-----------------------------------------------------------------------
124 !
125 ! BIOMASS MODULE
126 !
127  IF( 3*int(waqprocess/3).EQ.waqprocess ) THEN
128  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS~D_BIOMASS'
129 !
130  IF(dimm.EQ.2)THEN
131  CALL calcs2d_biomass(npoin2,wattemp,tn,texp,rayeff,
132  & hprop,t1,t2,t3,t4,t5,t6,debug)
133 !
134 ! YASMI(IND_PHY) = YASMI(IND_PHY) .OR. .FALSE.
135 ! YASMI(IND_PO4) = YASMI(IND_PO4) .OR. .FALSE.
136 ! YASMI(IND_POR) = YASMI(IND_POR) .OR. .FALSE.
137 ! YASMI(IND_NO3) = YASMI(IND_NO3) .OR. .FALSE.
138 ! YASMI(IND_NOR) = YASMI(IND_NOR) .OR. .FALSE.
139 !
140  ELSEIF(dimm.EQ.3)THEN
141  CALL calcs3d_biomass(npoin3,npoin2,nplan,wattemp,tn,texp,
142  & rayeff,zprop,t1,t2,t3,t4,t5,t6)
143 !
144  texp%ADR(ind_phy)%P%TYPR='Q'
145  texp%ADR(ind_po4)%P%TYPR='Q'
146  texp%ADR(ind_por)%P%TYPR='Q'
147  texp%ADR(ind_no3)%P%TYPR='Q'
148  texp%ADR(ind_nor)%P%TYPR='Q'
149 !
150  ENDIF
151  found = .true.
152  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS~D_BIOMASS'
153  ENDIF
154 !
155 !-----------------------------------------------------------------------
156 !
157 ! EUTRO MODULE
158 !
159  IF( 5*int(waqprocess/5).EQ.waqprocess ) THEN
160  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS~D_EUTRO'
161 !
162  IF(dimm.EQ.2)THEN
163  CALL calcs2d_eutro(npoin2,wattemp,tn,texp,timp,rayeff,
164  & hprop,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,
165  & t11,t12,debug,u,v)
166 !
167 ! YASMI(IND_PHY) = YASMI(IND_PHY) .OR. .FALSE.
168 ! YASMI(IND_PO4) = YASMI(IND_PO4) .OR. .FALSE.
169 ! YASMI(IND_POR) = YASMI(IND_POR) .OR. .FALSE.
170 ! YASMI(IND_NO3) = YASMI(IND_NO3) .OR. .FALSE.
171 ! YASMI(IND_NOR) = YASMI(IND_NOR) .OR. .FALSE.
172 ! YASMI(IND_NH4) = .TRUE.
173 ! YASMI(IND_OL) = .TRUE.
174 ! YASMI(IND_O2) = YASMI(IND_O2) .OR. .FALSE.
175 !
176  ELSEIF(dimm.EQ.3)THEN
177  CALL calcs3d_eutro(npoin3,npoin2,nplan,wattemp,tn,texp,
178  & timp,rayeff,hprop,zprop,t1,t2_1,t3,t4,
179  & t5,t6,t7,t8,t9,t10,t11,t12,debug,u,v)
180 !
181  texp%ADR(ind_phy)%P%TYPR='Q'
182  texp%ADR(ind_po4)%P%TYPR='Q'
183  texp%ADR(ind_por)%P%TYPR='Q'
184  texp%ADR(ind_no3)%P%TYPR='Q'
185  texp%ADR(ind_nor)%P%TYPR='Q'
186  texp%ADR(ind_nh4)%P%TYPR='Q'
187  timp%ADR(ind_nh4)%P%TYPR='Q'
188  texp%ADR(ind_ol)%P%TYPR='Q'
189  timp%ADR(ind_ol)%P%TYPR='Q'
190  texp%ADR(ind_o2)%P%TYPR='Q'
191 !
192  ENDIF
193  found = .true.
194  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS~D_EUTRO'
195  ENDIF
196 !
197 !-----------------------------------------------------------------------
198 !
199 ! MICROPOL MODULE
200 !
201  IF( 7*int(waqprocess/7).EQ.waqprocess ) THEN
202  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS~D_MICROPOL'
203 !
204  IF(dimm.EQ.2)THEN
205  CALL calcs2d_micropol(npoin2,tn,texp,timp,hprop,
206  & cf,u,v,t1,t2,t3,t4)
207 !
208 ! YASMI(IND_SS) = YASMI(IND_SS) .OR. .FALSE.
209 ! YASMI(IND_SF) = YASMI(IND_SF) .OR. .FALSE.
210 ! YASMI(IND_C) = .TRUE.
211 ! YASMI(IND_CSS) = .TRUE.
212 ! YASMI(IND_CSF) = YASMI(IND_CSF) .OR. .FALSE.
213 !
214  ELSEIF(dimm.EQ.3)THEN
215  CALL calcs3d_micropol(npoin2,tn,texp,
216  & timp,zprop,cf,u,v,t2_1,t2_2,t2_3,t1,t2,
217  & debug)
218 !
219  texp%ADR(ind_ss)%P%TYPR='Q'
220  texp%ADR(ind_sf)%P%TYPR='Q'
221  timp%ADR(ind_c)%P%TYPR='Q'
222  texp%ADR(ind_c)%P%TYPR='Q'
223  timp%ADR(ind_css)%P%TYPR='Q'
224  texp%ADR(ind_css)%P%TYPR='Q'
225  texp%ADR(ind_csf)%P%TYPR='Q'
226 !
227  ENDIF
228  found = .true.
229  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS~D_MICROPOL'
230  ENDIF
231 !
232 !-----------------------------------------------------------------------
233 !
234 ! THERMIC MODULE
235 !
236  IF( 11*int(waqprocess/11).EQ.waqprocess ) THEN
237 !
238  IF(dimm.EQ.2)THEN
239  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS2D_THERMIC'
240  CALL calcs2d_thermic(npoin2,tn,texp,hprop,patmos)
241  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS2D_THERMIC'
242 !
243 ! YASMI(IND_T) = YASMI(IND_T) .OR. .FALSE.
244 !
245  ELSEIF(dimm.EQ.3)THEN
246 ! SOURCE TERMS (VOLUME)
247  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS3D_THERMICV'
248  IF(atmosexch.EQ.2) THEN
249  CALL calcs3d_thermicv(npoin3,npoin2,nplan,zprop%R,rho%R,
250  & tn,texp,longit,latit,
251  & at,mardat,martim)
252 !
253  texp%ADR(ind_t)%P%TYPR='Q'
254  ENDIF
255 !
256  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS3D_THERMICV'
257 !
258  ENDIF
259  found = .true.
260  ENDIF
261 !
262 !-----------------------------------------------------------------------
263 !
264 ! AED2 COUPLING
265 !
266  IF( 13*int(waqprocess/13).EQ.waqprocess ) THEN
267 #if defined HAVE_AED2
268  IF(.NOT.deja_sw) THEN
269  ALLOCATE(extcaed2(npoin2,nplan),stat=ierr)
270  deja_sw = .true.
271  ENDIF
272  IF(dimm.EQ.3)THEN
273  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS3D_AED2'
274  CALL calcs3d_aed2(npoin3,npoin2,nplan,zprop%R,rho%R,
275  & tn,texp,timp,longit,latit,at,
276  & mardat,martim,extcaed2,rayaed2)
277  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS3D_AED2'
278  ENDIF
279  found = .true.
280 #else
281  WRITE(lu,*) 'ERROR: AED2 LIBRARY NOT COMPILED'
282  CALL plante(1)
283 #endif
284  ENDIF
285 !
286 !-----------------------------------------------------------------------
287 !
288 ! DEGRADATION LAW
289 !
290  IF( 17*int(waqprocess/17).EQ.waqprocess ) THEN
291 !
292  IF(dimm.EQ.2) THEN
293  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS2D_DEGRADATION'
294  CALL calcs2d_degradation(npoin2,tn,texp,timp,hprop,nwaq_degra,
296  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS2D_DEGRADATION'
297 ! DO J = 1,NWAQ_DEGRA
298 ! ITRAC = RANK_DEGRA(J)
299 ! YASMI(ITRAC) = .TRUE.
300 ! ENDDO
301  ELSEIF(dimm.EQ.3) THEN
302  IF(debug.GT.0) WRITE(lu,*) 'CALL OF CALCS3D_DEGRADATION'
303  CALL calcs3d_degradation(npoin3,npoin2,nplan,tn,texp,timp,
304  & zprop,nwaq_degra,rank_degra,
305  & loitrac,coef1trac)
306  IF(debug.GT.0) WRITE(lu,*) 'BACK FROM CALCS3D_DEGRADATION'
307 !
308  DO j = 1,nwaq_degra
309  itrac = rank_degra(j)
310  timp%ADR(itrac)%P%TYPR='Q'
311  ENDDO
312  ENDIF
313  found = .true.
314 !
315  ENDIF
316 !
317 !-----------------------------------------------------------------------
318 !
319 ! GHOST PROCESS IN WAITING FOR THE MERGE WITH ICE PROCESS
320 !
321  IF( 19*int(waqprocess/19).EQ.waqprocess ) THEN
322  found = .true.
323  ENDIF
324 !
325 !-----------------------------------------------------------------------
326 !
327 ! UNKNOWN PROCESS
328 !
329  IF( .NOT.found ) THEN
330  WRITE(lu,20) waqprocess
331 20 FORMAT(1x,'SOURCE_WAQ: UNKNOWN WAQ MODULE: ',i4)
332  CALL plante(1)
333  stop
334  ENDIF
335 !
336 !
337 !-----------------------------------------------------------------------
338 !
339  RETURN
340  END
double precision, dimension(:,:), allocatable extcaed2
integer, dimension(:), allocatable loitrac
double precision o2satu
integer, dimension(maxwqvar) rank_degra
double precision, dimension(:), allocatable coef1trac
double precision demben
double precision photo
type(bief_obj), target rayaed2
double precision wattemp
subroutine source_waq(NPOIN3, NPOIN2, TEXP, TIMP, TN, HPROP, U, V, CF, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T2_1, T2_2, T2_3, PATMOS, DIMM, NPLAN, LATIT, LONGIT, AT, MARDAT, MARTIM, ZPROP, RHO)
Definition: source_waq.F:10
type(bief_obj), target rayeff
Definition: bief.f:3