|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 !----------------------------------------------------------- 00002 ! ####################### 00003 SUBROUTINE RECHARGE_SURF_TOPD(PHI,PHT,KI) 00004 ! ####################### 00005 ! 00006 !!**** *RECHARGE_SURF_TOPD* 00007 !! 00008 !! PURPOSE 00009 !! ------- 00010 ! 00011 ! 00012 ! 00013 ! 00014 !!** METHOD 00015 !! ------ 00016 ! 00017 !! EXTERNAL 00018 !! -------- 00019 !! 00020 !! none 00021 !! 00022 !! IMPLICIT ARGUMENTS 00023 !! ------------------ 00024 !! 00025 !! 00026 !! REFERENCE 00027 !! --------- 00028 !! 00029 !! AUTHOR 00030 !! ------ 00031 !! 00032 !! K. Chancibault * LTHE / Meteo-France * 00033 !! 00034 !! MODIFICATIONS 00035 !! ------------- 00036 !! 00037 !! Original 12/2003 00038 !! 00039 !! WARNING 00040 !! ---------------- 00041 !! on considère que le seuil pour les deficits reste le niveau Wfc 00042 !------------------------------------------------------------------------------- 00043 ! 00044 !* 0. DECLARATIONS 00045 ! ------------ 00046 USE MODD_COUPLING_TOPD, ONLY: NMASKI, XWFCTOPT, XDMAXFC, XWTOPT,& 00047 XDTOPT, XWSTOPT, NNPIX 00048 USE MODD_TOPODYN, ONLY: NNCAT, XDMAXT 00049 ! 00050 USE MODD_SURF_PAR, ONLY: XUNDEF,NUNDEF 00051 ! 00052 USE MODI_ABOR1_SFX 00053 ! 00054 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00055 USE PARKIND1 ,ONLY : JPRB 00056 ! 00057 IMPLICIT NONE 00058 ! 00059 !* 0.1 declarations of arguments 00060 ! 00061 ! 00062 INTEGER, INTENT(IN) :: KI ! Grid dimensions 00063 REAL, DIMENSION(:), INTENT(INOUT) :: PHI ! water content variation since last time step from ISBA (m) 00064 REAL, DIMENSION(:,:), INTENT(OUT) :: PHT ! water content variation to provide to TOPODYN to be distributed (m) 00065 ! 00066 !* 0.2 declarations of local variables 00067 ! 00068 ! 00069 LOGICAL, DIMENSION(NNCAT,SIZE(NMASKI,3)) :: GTEST 00070 INTEGER :: J1,J2,J3,J4 ! loop control 00071 INTEGER :: INBSAT, INBALL 00072 ! 00073 REAL :: ZREST ! m 00074 REAL :: ZWNEW ! m3/m3 00075 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00076 !------------------------------------------------------------------------------- 00077 IF (LHOOK) CALL DR_HOOK('RECHARGE_SURF_TOPD',0,ZHOOK_HANDLE) 00078 ! 00079 !* 0. Initialization: 00080 ! --------------- 00081 ! 00082 !* 1. ISBA => TOPODYN-LAT 00083 ! ------------------- 00084 ! 00085 PHT(:,:)=0. 00086 ! 00087 DO J3 = 1,KI 00088 ! 00089 !The water content is lower than the previous one : this case is dealed with first to fasten the computation time. 00090 IF (PHI(J3) <= 0.0) THEN 00091 ! 00092 DO J1 = 1,NNCAT 00093 ! 00094 J4 = 1 00095 J2 = NMASKI(J3,J1,J4) 00096 ! 00097 DO WHILE (J2 /= NUNDEF .AND. J4<=SIZE(NMASKI,3) ) 00098 ! 00099 IF ( XWFCTOPT(J1,J2) /= XUNDEF ) THEN 00100 ! 00101 ZWNEW = XWTOPT(J1,J2) + PHI(J3) / XDTOPT(J1,J2) 00102 ! 00103 IF ( ZWNEW >= XWFCTOPT(J1,J2) ) THEN 00104 ! 00105 ! on reste au-dessus de la capacite au champ, malgre l'assechement 00106 XDMAXT(J1,J2) = XDMAXFC(J1,J2) 00107 PHT(J1,J2) = (ZWNEW - XWFCTOPT(J1,J2)) * XDTOPT(J1,J2) 00108 ! 00109 ELSE ! on passe au-dessous de la capacite au champ 00110 ! 00111 XDMAXT(J1,J2) = (XWSTOPT(J1,J2) - ZWNEW) * XDTOPT(J1,J2) 00112 PHT(J1,J2) = 0.0 00113 ! 00114 ENDIF 00115 ! 00116 J4 = J4+1 00117 IF ( J4<=SIZE(NMASKI,3) ) J2 = NMASKI(J3,J1,J4) 00118 ! 00119 ELSE ! pixel non défini dans Isba 00120 ! 00121 XDMAXT(J1,J2) = 0.0 00122 PHT = 0.0 00123 ! 00124 ENDIF 00125 ! 00126 ENDDO 00127 ! 00128 ENDDO 00129 ! 00130 ELSE ! recharge > 0.0 00131 ! 00132 ZREST=1. 00133 GTEST(:,:)=.TRUE. 00134 ! 00135 DO WHILE ( ZREST>0.0 ) 00136 ! 00137 ZREST=0.0 00138 ! 00139 DO J1=1,NNCAT 00140 ! 00141 J4=1 00142 J2=NMASKI(J3,J1,J4) 00143 ! 00144 DO WHILE ( J2/=NUNDEF .AND. J4<=SIZE(NMASKI,3) ) 00145 ! 00146 IF ( GTEST(J1,J4) .AND. XWFCTOPT(J1,J2)/=XUNDEF ) THEN 00147 ! 00148 ZWNEW = XWTOPT(J1,J2) + PHI(J3) / XDTOPT(J1,J2) 00149 ! 00150 IF ( XWTOPT(J1,J2) == XWSTOPT(J1,J2) ) THEN ! pixel déjà saturé 00151 ! 00152 XDMAXT(J1,J2) = 0.0 00153 PHT(J1,J2) = 0.0 00154 ZREST = ZREST + PHI(J3) 00155 GTEST(J1,J4) = .FALSE. 00156 ! 00157 ELSE IF ( ( XWSTOPT(J1,J2) - XWTOPT(J1,J2) ) * XDTOPT(J1,J2) <= PHI(J3) ) THEN 00158 ! 00159 ! pixel va se saturer 00160 XDMAXT(J1,J2) = XDMAXFC(J1,J2) 00161 PHT(J1,J2) = ( XWSTOPT(J1,J2) - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) 00162 ZREST = ZREST + PHI(J3) - PHT(J1,J2) 00163 GTEST(J1,J4)=.FALSE. 00164 ! 00165 ELSE IF ( XWTOPT(J1,J2) < XWFCTOPT(J1,J2) ) THEN 00166 ! 00167 ! en dessous de la capacité au champ avant d'ajouter la recharge 00168 IF ( (XWTOPT(J1,J2) + PHI(J3)/XDTOPT(J1,J2)) <= XWFCTOPT(J1,J2) ) THEN 00169 ! 00170 ! en dessous de la capacité au champ avec la recharge 00171 XDMAXT(J1,J2) = ( XWSTOPT(J1,J2) - ZWNEW ) * XDTOPT(J1,J2) 00172 PHT(J1,J2) = 0.0 00173 ! 00174 ELSE ! au-dessus de la capacité au champ avec la recharge 00175 ! 00176 XDMAXT(J1,J2) = XDMAXFC(J1,J2) 00177 PHT(J1,J2) = ( ZWNEW - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) 00178 ! 00179 ENDIF 00180 ! 00181 ELSE ! au-dessus de la capacité au champ avant d'ajouter la recharge 00182 ! 00183 XDMAXT(J1,J2) = XDMAXFC(J1,J2) 00184 PHT(J1,J2) = ( ZWNEW - XWFCTOPT(J1,J2) ) * XDTOPT(J1,J2) 00185 ! 00186 ENDIF 00187 ! 00188 ELSE IF ( XWFCTOPT(J1,J2)==XUNDEF ) THEN! pixel non défini dans Isba 00189 ! 00190 XDMAXT(J1,J2) = 0.0 00191 PHT = 0.0 00192 ! 00193 ENDIF 00194 ! 00195 J4 = J4+1 00196 IF ( J4<=SIZE(NMASKI,3) ) J2 = NMASKI(J3,J1,J4) 00197 ! 00198 ENDDO 00199 ! 00200 ENDDO 00201 ! 00202 IF ( ZREST/=0.0 ) THEN 00203 ! 00204 INBSAT=COUNT(.NOT.GTEST) !nb de pixels saturés avec ou sans la recharge 00205 ! 00206 IF ( INBSAT == NNPIX(J3) ) THEN 00207 ! 00208 IF (NNPIX(J3) > 400 ) THEN 00209 WRITE(*,*) 'MAILLE NUM=',J3, 'nb pix tot=',NNPIX(J3) 00210 CALL ABOR1_SFX("RECHARGE_SURF_TOPD: TOO MANY PIXELS SATURATED ") 00211 ELSE 00212 ZREST=0.0 00213 ENDIF 00214 ! 00215 ELSE 00216 ! 00217 PHI(J3) = PHI(J3) + ( ZREST / (NNPIX(J3) - INBSAT) ) ! nouvelle recharge à distribuer 00218 ! 00219 ENDIF 00220 ENDIF 00221 ! 00222 ENDDO 00223 ! 00224 ENDIF 00225 ! 00226 ENDDO 00227 ! 00228 IF (LHOOK) CALL DR_HOOK('RECHARGE_SURF_TOPD',1,ZHOOK_HANDLE) 00229 ! 00230 END SUBROUTINE RECHARGE_SURF_TOPD
1.8.0
