SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/TOPD/topd_to

Go to the documentation of this file.
00001 !-----------------------------------------------------------------
00002 !     ####################
00003       SUBROUTINE TOPD_TO_ISBA(KI,KSTEP,GTOPD)
00004 !     ####################
00005 !
00006 !!****  *TOPD_TO_ISBA*  
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 !!    
00027 !!
00028 !!      
00029 !!    REFERENCE
00030 !!    ---------
00031 !!
00032 !!    
00033 !!      
00034 !!    AUTHOR
00035 !!    ------
00036 !!
00037 !!      K. Chancibault  * LTHE / Meteo-France *
00038 !!
00039 !!    MODIFICATIONS
00040 !!    -------------
00041 !!
00042 !!      Original   09/10/2003
00043 !-------------------------------------------------------------------------------
00044 !
00045 !*       0.     DECLARATIONS
00046 !               ------------
00047 !
00048 !*** SurfEx ***
00049 USE MODI_UNPACK_SAME_RANK
00050 !*** Coupling ***
00051 USE MODI_WRITE_FILE_ISBAMAP
00052 USE MODI_OPEN_FILE
00053 USE MODI_CLOSE_FILE
00054 !
00055 USE MODD_TOPODYN,       ONLY : NNCAT, NNMC, NNB_TOPD_STEP
00056 USE MODD_COUPLING_TOPD, ONLY : XWG_FULL, XDTOPT, XWTOPT, XWSUPSAT,&
00057                                  NMASKT, XTOTBV_IN_MESH, NNPIX, NFREQ_MAPS_WG
00058 !
00059 USE MODD_ISBA_n,          ONLY : XWSAT
00060 USE MODD_SURF_ATM_GRID_n, ONLY : XMESH_SIZE
00061 USE MODD_SURF_PAR,        ONLY : XUNDEF
00062 USE MODD_SURF_ATM_n,      ONLY : NR_NATURE
00063 USE MODD_ISBA_PAR,        ONLY : XWGMIN
00064 !
00065 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00066 USE PARKIND1  ,ONLY : JPRB
00067 !
00068 IMPLICIT NONE
00069 !
00070 !*      0.1    declarations of arguments
00071 !
00072 !
00073 INTEGER, INTENT(IN)                 :: KI      ! Grid dimensions
00074 INTEGER, INTENT(IN)                 :: KSTEP   ! Topodyn current time step
00075 LOGICAL, DIMENSION(:), INTENT(IN) :: GTOPD     ! 
00076 !
00077 !*      0.2    declarations of local variables
00078 !
00079 !
00080 INTEGER                :: JJ, JI          ! loop control 
00081 INTEGER                :: IUNIT               
00082 REAL, DIMENSION(KI)    :: ZW              ! TOPODYN water content on ISBA grid (mm)
00083 REAL, DIMENSION(KI)    :: ZCOUNT          ! TOPO pixel number in an ISBA pixel
00084 REAL, DIMENSION(KI)    :: ZWSAT_FULL      ! Water content at saturation on the layer 2 
00085                                           ! on the full grid
00086 REAL, DIMENSION(KI)    :: ZWG_OLD
00087 REAL, DIMENSION(KI)    :: ZDG_FULL
00088  CHARACTER(LEN=3)       :: YSTEP
00089 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00090 !-------------------------------------------------------------------------------
00091 IF (LHOOK) CALL DR_HOOK('TOPD_TO_ISBA',0,ZHOOK_HANDLE)
00092 !
00093 !*       0.     Initialization:
00094 !               ---------------
00095 !
00096 ZW(: )= 0.0
00097 !
00098 ZWG_OLD(:) = XWG_FULL(:)
00099 !
00100 !
00101 !*       1.     TOPODYN-LAT => ISBA
00102 !               -------------------
00103 !*       1.1    mobilizable water
00104 !               -----------------
00105 !
00106 DO JJ=1,NNCAT
00107   IF (GTOPD(JJ)) THEN
00108     DO JI=1,NNMC(JJ)
00109       IF (XDTOPT(JJ,JI) /= XUNDEF) THEN
00110         ZW(NMASKT(JJ,JI)) = ZW(NMASKT(JJ,JI)) + XWTOPT(JJ,JI)
00111       ENDIF
00112     ENDDO
00113   ELSE
00114     GOTO 10 
00115   ENDIF
00116 ENDDO
00117 !
00118 ZCOUNT(:)=REAL(NNPIX(:))
00119 !
00120 WHERE (ZCOUNT(:) /= 0.0.AND.XWG_FULL(:)/=XUNDEF)
00121   ZW(:) = ZW(:) / ZCOUNT
00122 ENDWHERE
00123 !
00124 !
00125 ! The soil water content is the balanced mean between the soil water content calculated by TOPODYN 
00126 ! and the initial soil water content in each mesh, in function of the area of the mesh occupied by TOPODYN
00127 WHERE ( XMESH_SIZE(:) - XTOTBV_IN_MESH(:) <= 0.0) ! la maille isba est totalement couverte par des bassins versants
00128   XWG_FULL(:) = ZW(:)
00129 ELSEWHERE (XTOTBV_IN_MESH(:) /= 0.0)
00130   XWG_FULL = (XTOTBV_IN_MESH(:)/XMESH_SIZE(:))*ZW(:) + ((XMESH_SIZE(:)-XTOTBV_IN_MESH(:))/XMESH_SIZE(:))*XWG_FULL(:)
00131 
00132 ENDWHERE
00133 !
00134 XWG_FULL(:) = MAX(XWG_FULL(:),XWGMIN)
00135 !
00136 10 CONTINUE 
00137 !
00138  CALL UNPACK_SAME_RANK(NR_NATURE,XWSAT(:,2),ZWSAT_FULL)
00139 !
00140 IF (.NOT.ALLOCATED(XWSUPSAT)) ALLOCATE(XWSUPSAT(KI))
00141 XWSUPSAT=0.
00142 !ludo glace Wsat varie
00143 WHERE ( XWG_FULL(:) > ZWSAT_FULL(:) .AND. XWG_FULL(:)/=XUNDEF )
00144   !ludo calcul sat avant wg
00145   XWSUPSAT(:) = XWG_FULL(:) - ZWSAT_FULL(:)
00146   XWG_FULL(:) = ZWSAT_FULL(:)
00147 ENDWHERE
00148 !
00149 WHERE (XWG_FULL(:) < XWGMIN .AND. XWG_FULL(:)/=XUNDEF)
00150   XWG_FULL(:) = XWGMIN
00151 ENDWHERE
00152 !
00153 IF ( NFREQ_MAPS_WG/=0 .AND. (MOD(KSTEP,NFREQ_MAPS_WG)==0 .OR. KSTEP==NNB_TOPD_STEP) ) THEN
00154   ! writing of YSTEP to be able to write maps
00155   IF (KSTEP<10) THEN
00156     WRITE(YSTEP,'(I1)') KSTEP
00157   ELSEIF (KSTEP < 100) THEN
00158     WRITE(YSTEP,'(I2)') KSTEP
00159   ELSE
00160     WRITE(YSTEP,'(I3)') KSTEP
00161   ENDIF
00162   !
00163   CALL OPEN_FILE('ASCII ',IUNIT,HFILE='carte_w'//YSTEP,HFORM='FORMATTED',HACTION='WRITE')
00164   CALL WRITE_FILE_ISBAMAP(IUNIT,XWG_FULL,KI)
00165   CALL CLOSE_FILE('ASCII ',IUNIT)
00166   !
00167 ENDIF
00168 !
00169 IF (LHOOK) CALL DR_HOOK('TOPD_TO_ISBA',1,ZHOOK_HANDLE)
00170 !
00171 END SUBROUTINE TOPD_TO_ISBA