The TELEMAC-MASCARET system  trunk
calcs2d_micropol.f
Go to the documentation of this file.
1 ! ***************************
2  SUBROUTINE calcs2d_micropol
3 ! ***************************
4 !
5  & (npoin,tn,texp,timp,hprop,cf,un,vn,
6  & t1,t2,t3,t4)
7 !
8 !***********************************************************************
9 ! WAQTEL V8P1
10 !***********************************************************************
11 !
12 !brief COMPUTES SOURCE TERMS FOR MICROPOL WAQ PROCESS
13 ! WAQ PROCESS OF CODE_TRACER (MASCARET SYSTEM)
14 !
15 !history R. ATA
16 !+ 21/09/2014
17 !+ V7P0
18 !+ CREATION (VOID)
19 !history R. ATA
20 !+ 28/09/2015
21 !+ V7P1
22 !+ REAL CREATION
23 !
24 !history S.E. BOURBAN (HRW)
25 !+ 07/06/2017
26 !+ V7P3
27 !+ Indexing tracer (IND_*) to avoid conflicting naming convention
28 !+ between user defined tracers, water quality processes and
29 !+ ice processes. Introduction of the array RANK_*.
30 !
31 !history S.E. BOURBAN (HRW)
32 !+ 25/09/2017
33 !+ V7P3
34 !+ TEXP and TIMP are now additive to account for a variety of
35 !+ of sources / sinks on a given TRACER
36 !
37 !history C.-T. PHAM
38 !+ 20/11/2019
39 !+ V8P1
40 !+ The calculation of the 4th ad 5th equations is with RS/SF
41 !+ and SEDP not RS and SED=SEDP*SS
42 !
43 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
44 !| CCSEDIM |-->| CONSTANT OF EXPONENTIAL DESINTEGRATION
45 !| CDISTRIB |-->| COEFFICIENT OF DISTRIBUTION (KD)
46 !| ERO |-->| EROSION RATE
47 !| KDESORP |-->| KINETIC CONSTANT OF DESORPTION
48 !| NPOIN |-->| TOTAL NUMBER OF MESH NODES
49 !| NTRAC |-->| NUMBER OF TRACERS
50 !| TAUB |-->| BED SHEAR
51 !| TAUS |-->| CRITICAL STRESS OF RESUSPENSION
52 !| TAUR |-->| SEDIMENTATION CRITICAL STRESS
53 !| TEXP |<--| EXPLICIT SOURCE TERMS OF TRACERS
54 !| TIMP |<--| IMPLICIT SOURCE TERMS OF TRACERS
55 !| TN |-->| TRACERS
56 !| VITCHU |-->| SEDIMENT SETTLING VELOCITY
57 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
58 !
59  USE bief
63  & ro0,kdesorp,ccsedim,
64  & ind_ss,ind_sf,ind_c,ind_css,ind_csf
65  USE interface_waqtel, ex_calcs2d_micropol => calcs2d_micropol
66 !
67  IMPLICIT NONE
68 !
69 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
70 !
71 !
72  INTEGER , INTENT(IN ) :: npoin
73  TYPE(bief_obj) , INTENT(IN ) :: tn,hprop,cf,un,vn
74  TYPE(bief_obj) , INTENT(INOUT) :: texp,t1,t2,t3,t4,timp
75 !
76 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
77 !
78 ! LOCAL VARIABLES
79  DOUBLE PRECISION, PARAMETER :: eps=1.d-3
80  DOUBLE PRECISION :: cc
81 !
82 !-----------------------------------------------------------------------
83 !
84 !
85 ! =======================================
86 ! PRELIMINARY COMPUTATIONS
87 ! =======================================
88 !
89 ! BED SHEAR STRESS (TAUB-STORED IN T1)
90 !
91  CALL taub_waqtel(cf,ro0,t1,npoin,un,vn)
92 !
93 ! DEPOSITION PROBABILITY (SED): STORED IN T2, NOT SEDP
94 !
95  CALL depos_fx(t2,t1,tn%ADR(ind_ss)%P,taus,vitchu,npoin)
96 !
97 ! SEDP = SED/SS: STORED IN T4, NOT SED
98 !
99  CALL os ('X=C ', x=t3,c=1.d0)
100  CALL depos_fx(t4,t1,t3,taus,vitchu,npoin)
101 !
102 ! EROSION FLUX (RS): STORED IN T3
103 !
104  CALL erosion_fx(t3,t1,tn%ADR(ind_sf)%P,taur,ero,1.d-10,npoin)
105 !
106 !
107 ! =======================================
108 ! LET'S NOW COMPUTE SOURCE TERMS
109 ! =======================================
110 !
111 ! FIRST TRACER: SUSPENDED LOAD [SS] (IND_SS)
112 ! RS SED
113  CALL os ('X=Y-Z ', x=t1, y=t3,z=t2 )
114  CALL ovd('X=X+CY/Z', texp%ADR(ind_ss)%P%R,t1%R,hprop%R,
115  & 1.d0, npoin,2,0.d0,eps )
116 !
117 ! SECOND TRACER: BED SEDIMENT [SF] (IND_SF)
118 ! warning: no advection neither diffusion for this tracer
119 ! SED RS
120  CALL os ('X=Y-Z ', x=t1,y=t2,z=t3 )
121  CALL os ('X=X+Y ', x=texp%ADR(ind_sf)%P, y=t1 )
122 !
123 ! THIRD TRACER: POLLUTANT DENSITY [C] (IND_C)
124 !
125 ! implicit part
126 ! CCSEDIM = CONSTANT L IN THE DOC
127 ! CALL OS( 'X=X+C ' ,X=TIMP%ADR(IND_C)%P,C=CCSEDIM )
128  CALL os( 'X=X+CY ' ,x=timp%ADR(ind_c)%P,y=hprop,c=-ccsedim)
129 ! explicit part
130  CALL os( 'X=CY ' ,x=t1,y=tn%ADR(ind_css)%P,c=kdesorp )
131  cc =-kdesorp*cdistrib
132  CALL os( 'X=X+CYZ ' ,x=t1,y=tn%ADR(ind_c)%P,
133  & z=tn%ADR(ind_ss)%P ,c=cc )
134  CALL os( 'X=X+Y ' ,x=texp%ADR(ind_c)%P,y=t1 )
135 !
136 ! FOURTH TRACER: ADSORBED POLLUTANT BY SUSPENDED LOAD [CSS] (IND_CSS)
137 !
138 ! implicit part
139 ! CALL OS( 'X=X+C ' ,X=TIMP%ADR(IND_CSS)%P,C=CCSEDIM )
140  CALL os( 'X=X+CY ' ,x=timp%ADR(ind_css)%P,y=hprop,c=-ccsedim)
141 ! explicit part
142  CALL os( 'X=X-Y ' ,x=texp%ADR(ind_css)%P,y=t1 )
143 ! CALL OS( 'X=YZ ' ,X=T4,Y=T3,Z=TN%ADR(IND_CSF)%P )
144 ! CALL OS( 'X=X+CYZ ' ,X=T4,Y=TN%ADR(IND_CSS)%P,Z=T2,C=-1.D0 )
145 ! CALL OVD('X=Y/Z ' ,T4%R,T4%R,
146 ! & HPROP%R,0.D0,NPOIN,2,0.D0,EPS)
147 ! CALL OS( 'X=X+Y ' ,X=TEXP%ADR(IND_CSS)%P,Y=T4 )
148 ! RS
149  CALL os( 'X=Y ' ,x=t1,y=t3)
150  CALL ovd('X=CXY/Z ' ,t1%R,tn%ADR(ind_csf)%P%R,tn%ADR(ind_sf)%P%R,
151  & 1.d0, npoin,2,0.d0,eps)
152 ! SEDP
153  CALL os( 'X=X-YZ ' ,x=t1,y=t4,z=tn%ADR(ind_css)%P)
154  CALL ovd('X=X+CY/Z', texp%ADR(ind_css)%P%R,t1%R,hprop%R,
155  & 1.d0, npoin,2,0.d0,eps )
156 
157 !
158 ! FIFTH TRACER: ADSORBED POLLUTANT BY BED SEDIMENT [CFF] (IND_CSF)
159 !
160 ! CALL OS( 'X=X+YZ ' ,X=TEXP%ADR(IND_CSF)%P,Y=TN%ADR(IND_CSS)%P,
161 ! & Z=T2 )
162 ! CALL OS( 'X=X+CYZ ' ,X=TEXP%ADR(IND_CSF)%P,Y=TN%ADR(IND_CSF)%P,
163 ! & Z=T3,C=-1.D0 )
164 ! CALL OS( 'X=X+CY ' ,X=TEXP%ADR(IND_CSF)%P,Y=TN%ADR(IND_CSF)%P,
165 ! & C=-CCSEDIM )
166 ! implicit part
167  CALL os( 'X=X+CY ' ,x=timp%ADR(ind_csf)%P,y=hprop,c=-ccsedim)
168 ! explicit part
169  CALL os( 'X=X-Y ' ,x=texp%ADR(ind_csf)%P,y=t1)
170 !
171 !-----------------------------------------------------------------------
172 !
173  RETURN
174  END
subroutine taub_waqtel(CF, DENSITY, TAUB, NPOIN, UN, VN)
Definition: taub_waqtel.f:7
double precision vitchu
subroutine ovd(OP, X, Y, Z, C, NPOIN, IOPT, D, EPS)
Definition: ovd.f:7
double precision cdistrib
subroutine os(OP, X, Y, Z, C, IOPT, INFINI, ZERO)
Definition: os.f:7
Definition: bief.f:3