SURFEX  V8_0
Surfex V8_0 release
 All Classes Files Functions Variables
recharge_surf_topd.F90
Go to the documentation of this file.
1 !SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
3 !SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SFX_LIC for details. version 1.
5 !-----------------------------------------------------------
6 ! #######################
7  SUBROUTINE recharge_surf_topd(PHI,PHT,KI)
8 ! #######################
9 !
10 !!**** *RECHARGE_SURF_TOPD*
11 !!
12 !! PURPOSE
13 !! -------
14 !
15 !
16 !
17 !
18 !!** METHOD
19 !! ------
20 !
21 !! EXTERNAL
22 !! --------
23 !!
24 !! none
25 !!
26 !! IMPLICIT ARGUMENTS
27 !! ------------------
28 !!
29 !!
30 !! REFERENCE
31 !! ---------
32 !!
33 !! AUTHOR
34 !! ------
35 !!
36 !! K. Chancibault * LTHE / Meteo-France *
37 !!
38 !! MODIFICATIONS
39 !! -------------
40 !!
41 !! Original 12/2003
42 !! 03/2014 (B. Vincendon) use of the number of pixels included in a mesh and a watershed
43 !!
44 !! WARNING
45 !! ----------------
46 !! WFC is the threshold for deficits
47 !-------------------------------------------------------------------------------
48 !
49 !* 0. DECLARATIONS
50 ! ------------
51 USE modd_coupling_topd, ONLY: nmaski, nmaskt, xwfctopt, xdmaxfc, xwtopt,&
52  xdtopt, xwstopt, nnpix, nnbv_in_mesh
53 USE modd_topodyn, ONLY: nncat, xdmaxt
54 !
55 USE modd_surf_par, ONLY: nundef,xundef
56 !
57 USE modi_abor1_sfx
58 !
59 USE yomhook ,ONLY : lhook, dr_hook
60 USE parkind1 ,ONLY : jprb
61 !
62 IMPLICIT NONE
63 !
64 !* 0.1 declarations of arguments
65 !
66 !
67 INTEGER, INTENT(IN) :: ki ! Grid dimensions
68 REAL, DIMENSION(:), INTENT(INOUT) :: phi ! water content variation since last time step from ISBA (m)
69 REAL, DIMENSION(:,:), INTENT(OUT) :: pht ! water content variation to provide to TOPODYN to be distributed (m)
70 !
71 !* 0.2 declarations of local variables
72 !
73 !
74 LOGICAL, DIMENSION(NNCAT,SIZE(NMASKI,3)) :: gtest
75 INTEGER :: j1,j2,j3,j4 ! loop control
76 INTEGER :: inbsat, inball
77 !
78 REAL :: zrest ! m
79 REAL :: zwnew ! m3/m3
80 REAL(KIND=JPRB) :: zhook_handle
81 !-------------------------------------------------------------------------------
82 IF (lhook) CALL dr_hook('RECHARGE_SURF_TOPD',0,zhook_handle)
83 !
84 !* 0. Initialization:
85 ! ---------------
86 !
87 !* 1. ISBA => TOPODYN-LAT
88 ! -------------------
89 !
90 pht(:,:)=0.
91 !
92 DO j3 = 1,ki
93  !
94  !The water content is lower than the previous one : this case is dealed with first to fasten the computation time.
95  IF (phi(j3) <= 0.0) THEN
96  !
97  DO j1 = 1,nncat
98  !
99  j4 = 1
100  j2 = nmaski(j3,j1,j4)
101  DO WHILE (j2 /= nundef .AND. j4<=nnbv_in_mesh(j3,j1) )
102  !
103  IF ( nmaskt(j1,j2) /= nundef ) THEN
104  !
105  zwnew = xwtopt(j1,j2) + phi(j3) / xdtopt(j1,j2)
106  !
107  IF ( zwnew >= xwfctopt(j1,j2) ) THEN
108  !
109  ! on reste au-dessus de la capacite au champ, malgre l'assechement
110  IF (xdmaxfc(j1,j2)/=xundef) xdmaxt(j1,j2) = xdmaxfc(j1,j2)
111  pht(j1,j2) = (zwnew - xwfctopt(j1,j2)) * xdtopt(j1,j2)
112  !
113  ELSE ! on passe au-dessous de la capacite au champ
114  !
115  IF (xwstopt(j1,j2)/=xundef) &
116  xdmaxt(j1,j2) = (xwstopt(j1,j2) - zwnew) * xdtopt(j1,j2)
117  pht(j1,j2) = 0.0
118  !
119  ENDIF
120  !
121  j4 = j4+1
122  IF ( j4<=SIZE(nmaski,3) ) j2 = nmaski(j3,j1,j4)
123  !
124  ELSE ! pixel non défini dans Isba
125  !
126  xdmaxt(j1,j2) = 0.0
127  pht = 0.0
128  !
129  ENDIF
130  !
131  ENDDO
132  !
133  ENDDO
134  !
135  ELSE ! recharge > 0.0
136  !
137  zrest=1.
138  gtest(:,:)=.true.
139  !
140  DO WHILE ( zrest>0.0 )
141  !
142  zrest=0.0
143  !
144  DO j1=1,nncat
145  !
146  j4=1
147  j2=nmaski(j3,j1,j4)
148  !
149  DO WHILE ( j2/=nundef .AND. j4<=nnbv_in_mesh(j3,j1) )
150  !
151  IF ( gtest(j1,j4) .AND. nmaskt(j1,j2)/=nundef ) THEN
152  !
153  zwnew = xwtopt(j1,j2) + phi(j3) / xdtopt(j1,j2)
154  !
155  IF ( xwtopt(j1,j2) == xwstopt(j1,j2) ) THEN ! pixel déjà saturé ! XDMAXT(J1,J2) = 0.0 PHT(J1,J2) = 0.0 ZREST = ZREST + PHI(J3) GTEST(J1,J4) = .FALSE. ! ELSE IF ( ( XWSTOPT(J1,J2) - XWTOPT(J1,J2) ) * XDTOPT(J1,J2) <= PHI(J3) ) THEN ! ! pixel va se saturer XDMAXT(J1,J2) = XDMAXFC(J1,J2) PHT(J1,J2) = ( XWSTOPT(J1,J2) - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) ZREST = ZREST + PHI(J3) - PHT(J1,J2) GTEST(J1,J4)=.FALSE. ! ELSE IF ( XWTOPT(J1,J2) < XWFCTOPT(J1,J2) ) THEN ! ! en dessous de la capacité au champ avant d'ajouter la recharge IF ( (XWTOPT(J1,J2) + PHI(J3)/XDTOPT(J1,J2)) <= XWFCTOPT(J1,J2) ) THEN ! ! en dessous de la capacité au champ avec la recharge XDMAXT(J1,J2) = ( XWSTOPT(J1,J2) - ZWNEW ) * XDTOPT(J1,J2) PHT(J1,J2) = 0.0 ! ELSE ! au-dessus de la capacité au champ avec la recharge ! XDMAXT(J1,J2) = XDMAXFC(J1,J2) PHT(J1,J2) = ( ZWNEW - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) ! ENDIF ! ELSE ! au-dessus de la capacité au champ avant d'ajouter la recharge ! XDMAXT(J1,J2) = XDMAXFC(J1,J2) PHT(J1,J2) = ( ZWNEW - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) ! ENDIF ! ELSE IF ( NMASKT(J1,J2)==NUNDEF ) THEN! pixel non défini dans Isba ! XDMAXT(J1,J2) = 0.0 PHT = 0.0 ! ENDIF ! J4 = J4+1 IF ( J4<=SIZE(NMASKI,3) ) J2 = NMASKI(J3,J1,J4) ! ENDDO ! ENDDO ! IF ( ZREST/=0.0 ) THEN ! INBSAT=COUNT(.NOT.GTEST) !nb de pixels saturés avec ou sans la recharge ! IF ( INBSAT == NNPIX(J3) ) THEN ! IF (NNPIX(J3) > 400 ) THEN WRITE(*,*) 'MAILLE NUM=',J3, 'nb pix tot=',NNPIX(J3) ! CALL ABOR1_SFX("RECHARGE_SURF_TOPD: TOO MANY PIXELS SATURATED ") ELSE ZREST=0.0 ENDIF ! ELSE ! PHI(J3) = PHI(J3) + ( ZREST / (NNPIX(J3) - INBSAT) ) ! nouvelle recharge à distribuer ! ENDIF ENDIF ! ENDDO ! ENDIF ! ENDDO ! IF (LHOOK) CALL DR_HOOK('RECHARGE_SURF_TOPD',1,ZHOOK_HANDLE) ! END SUBROUTINE RECHARGE_SURF_TOPD
156  !
157  xdmaxt(j1,j2) = 0.0
158  pht(j1,j2) = 0.0
159  zrest = zrest + phi(j3)
160  gtest(j1,j4) = .false.
161  !
162  ELSE IF ( ( xwstopt(j1,j2) - xwtopt(j1,j2) ) * xdtopt(j1,j2) <= phi(j3) ) THEN
163  !
164  ! pixel va se saturer
165  xdmaxt(j1,j2) = xdmaxfc(j1,j2)
166  pht(j1,j2) = ( xwstopt(j1,j2) - xwfctopt(j1,j2) ) * xdtopt(j1,j2)
167  zrest = zrest + phi(j3) - pht(j1,j2)
168  gtest(j1,j4)=.false.
169  !
170  ELSE IF ( xwtopt(j1,j2) < xwfctopt(j1,j2) ) THEN
171  !
172  ! en dessous de la capacité au champ avant d'ajouter la recharge
173  IF ( (xwtopt(j1,j2) + phi(j3)/xdtopt(j1,j2)) <= xwfctopt(j1,j2) ) THEN
174  !
175  ! en dessous de la capacité au champ avec la recharge
176  xdmaxt(j1,j2) = ( xwstopt(j1,j2) - zwnew ) * xdtopt(j1,j2)
177  pht(j1,j2) = 0.0
178  !
179  ELSE ! au-dessus de la capacité au champ avec la recharge
180  !
181  xdmaxt(j1,j2) = xdmaxfc(j1,j2)
182  pht(j1,j2) = ( zwnew - xwfctopt(j1,j2) ) * xdtopt(j1,j2)
183  !
184  ENDIF
185  !
186  ELSE ! au-dessus de la capacité au champ avant d'ajouter la recharge
187  !
188  xdmaxt(j1,j2) = xdmaxfc(j1,j2)
189  pht(j1,j2) = ( zwnew - xwfctopt(j1,j2) ) * xdtopt(j1,j2)
190  !
191  ENDIF
192  !
193  ELSE IF ( nmaskt(j1,j2)==nundef ) then! pixel non défini dans Isba
194  !
195  xdmaxt(j1,j2) = 0.0
196  pht = 0.0
197  !
198  ENDIF
199  !
200  j4 = j4+1
201  IF ( j4<=SIZE(nmaski,3) ) j2 = nmaski(j3,j1,j4)
202  !
203  ENDDO
204  !
205  ENDDO
206  !
207  IF ( zrest/=0.0 ) THEN
208  !
209  inbsat=count(.NOT.gtest) !nb de pixels saturés avec ou sans la recharge
210  !
211  IF ( inbsat == nnpix(j3) ) THEN
212  !
213  IF (nnpix(j3) > 400 ) THEN
214  WRITE(*,*) 'MAILLE NUM=',j3, 'nb pix tot=',nnpix(j3)
215  ! CALL ABOR1_SFX("RECHARGE_SURF_TOPD: TOO MANY PIXELS SATURATED ")
216  ELSE
217  zrest=0.0
218  ENDIF
219  !
220  ELSE
221  !
222  phi(j3) = phi(j3) + ( zrest / (nnpix(j3) - inbsat) ) ! nouvelle recharge à distribuer
223  !
224  ENDIF
225  ENDIF
226  !
227  ENDDO
228  !
229  ENDIF
230  !
231 ENDDO
232 !
233 IF (lhook) CALL dr_hook('RECHARGE_SURF_TOPD',1,zhook_handle)
234 !
235 END SUBROUTINE recharge_surf_topd
modd_coupling_topd
Definition: modd_coupling_topd.F90:6
recharge_surf_topd
subroutine recharge_surf_topd(PHI, PHT, KI)
Definition: recharge_surf_topd.F90:7
modd_surf_par
Definition: modd_surf_par.F90:6
modd_topodyn
Definition: modd_topodyn.F90:7
Generated on Fri May 13 2016 09:31:06 for SURFEX by   doxygen 1.8.5