SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/write_diag_pgd

Go to the documentation of this file.
00001 !     #########
00002       SUBROUTINE WRITE_DIAG_PGD_ISBA_n(HPROGRAM)
00003 !     #########################################
00004 !
00005 !!****  *WRITE_DIAG_PGD_ISBA_n* - writes the ISBA physiographic diagnostic fields
00006 !!
00007 !!    PURPOSE
00008 !!    -------
00009 !!
00010 !!**  METHOD
00011 !!    ------
00012 !!
00013 !!    EXTERNAL
00014 !!    --------
00015 !!
00016 !!
00017 !!    IMPLICIT ARGUMENTS
00018 !!    ------------------
00019 !!
00020 !!    REFERENCE
00021 !!    ---------
00022 !!
00023 !!
00024 !!    AUTHOR
00025 !!    ------
00026 !!      V. Masson   *Meteo France*      
00027 !!
00028 !!    MODIFICATIONS
00029 !!    -------------
00030 !!      Original    01/2004 
00031 !!      Modified    10/2004 by P. Le Moigne: add XZ0REL, XVEGTYPE_PATCH
00032 !!      Modified    11/2005 by P. Le Moigne: limit length of VEGTYPE_PATCH field names
00033 !-------------------------------------------------------------------------------
00034 !
00035 !*       0.    DECLARATIONS
00036 !              ------------
00037 !
00038 USE MODD_SURF_PAR,   ONLY : XUNDEF, NUNDEF
00039 USE MODD_ISBA_n,     ONLY : NPATCH, CPHOTO, CHORT, CISBA,                           &
00040                               XLAI, XVEG, XZ0,XALBNIR_SOIL,XALBVIS_SOIL,XALBUV_SOIL,&
00041                               XRSMIN, XGAMMA, XRGL, XCV, XEMIS, XDG, XWRMAX_CF,     &
00042                               XZ0REL, XVEGTYPE_PATCH, XALBNIR, XALBVIS, XALBUV,     &
00043                               XPATCH, XWATSUP, TSEED, TREAP, XIRRIG, XD_ICE,        &
00044                               XROOTFRAC, NWG_LAYER, XDROOT, XDG2,                   &
00045                               XWSAT, XWFC, XWWILT, XRUNOFFD, CSOC, XFRACSOC   
00046 USE MODD_AGRI,       ONLY : LAGRIP
00047 !
00048 USE MODD_DIAG_MISC_ISBA_n,ONLY : LSURF_DIAG_ALBEDO
00049 !
00050 USE MODD_IO_SURF_FA, ONLY : LFANOCOMPACT, LPREP
00051 !
00052 USE MODD_CH_ISBA_n,  ONLY : XSOILRC_SO2, XSOILRC_O3, CCH_DRY_DEP, NBEQ
00053 USE MODI_INIT_IO_SURF_n
00054 USE MODI_WRITE_SURF
00055 USE MODI_END_IO_SURF_n
00056 !
00057 !
00058 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00059 USE PARKIND1  ,ONLY : JPRB
00060 !
00061 IMPLICIT NONE
00062 !
00063 !*       0.1   Declarations of arguments
00064 !              -------------------------
00065 !
00066  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
00067 !
00068 !*       0.2   Declarations of local variables
00069 !              -------------------------------
00070 !
00071 REAL, DIMENSION(SIZE(XDG,1),SIZE(XDG,3)) :: ZWORK ! Work array
00072 !
00073 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
00074  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
00075  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
00076  CHARACTER(LEN=2)  :: YLVLV, YPAS
00077 !
00078 INTEGER           :: JJ, JL, JP, ILAYER
00079 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00080 !-------------------------------------------------------------------------------
00081 !
00082 !         Initialisation for IO
00083 !
00084 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_ISBA_N',0,ZHOOK_HANDLE)
00085  CALL INIT_IO_SURF_n(HPROGRAM,'NATURE','ISBA  ','WRITE')
00086 !
00087 !-------------------------------------------------------------------------------
00088 !
00089 !* Leaf Area Index
00090 !
00091 IF (CPHOTO=='NON' .OR. CPHOTO=='AGS' .OR. CPHOTO=='AST') THEN
00092   !
00093   YRECFM='LAI'
00094   YCOMMENT='leaf area index (-)'
00095   !
00096   CALL WRITE_SURF(HPROGRAM,YRECFM,XLAI(:,:),IRESP,HCOMMENT=YCOMMENT)
00097   !
00098 ENDIF
00099 !
00100 !-------------------------------------------------------------------------------
00101 !
00102 !* Vegetation fraction
00103 !
00104 YRECFM='VEG'
00105 YCOMMENT='vegetation fraction (-)'
00106 !
00107  CALL WRITE_SURF(HPROGRAM,YRECFM,XVEG(:,:),IRESP,HCOMMENT=YCOMMENT)
00108 !
00109 !* Surface roughness length (without snow)
00110 !
00111 YRECFM='Z0VEG'
00112 YCOMMENT='surface roughness length (without snow) (M)'
00113 !
00114  CALL WRITE_SURF(HPROGRAM,YRECFM,XZ0(:,:),IRESP,HCOMMENT=YCOMMENT)
00115 !
00116 !-------------------------------------------------------------------------------
00117 !
00118 !* Fraction for each patch
00119 !
00120 IF(.NOT.LFANOCOMPACT.OR.LPREP)THEN
00121   YRECFM='PATCH'
00122   YCOMMENT='fraction for each patch (-)'
00123   CALL WRITE_SURF(HPROGRAM,YRECFM,XPATCH(:,:),IRESP,HCOMMENT=YCOMMENT)
00124 ENDIF
00125 !-------------------------------------------------------------------------------
00126 !
00127 !* Soil depth for each patch
00128 !
00129 DO JL=1,SIZE(XDG,2)
00130   IF (JL<10) THEN
00131     WRITE(YRECFM,FMT='(A2,I1)') 'DG',JL
00132   ELSE
00133     WRITE(YRECFM,FMT='(A2,I2)') 'DG',JL          
00134   ENDIF
00135   YCOMMENT='soil depth'//' (M)'
00136   CALL WRITE_SURF(HPROGRAM,YRECFM,XDG(:,JL,:),IRESP,HCOMMENT=YCOMMENT)
00137 END DO
00138 !-------------------------------------------------------------------------------
00139 !
00140 IF(CISBA=='DIF')THEN
00141 !
00142 !* Root depth
00143 !
00144   YRECFM='DROOT_DIF'
00145   YCOMMENT='Root depth in ISBA-DIF'
00146 !
00147   CALL WRITE_SURF(HPROGRAM,YRECFM,XDROOT(:,:),IRESP,HCOMMENT=YCOMMENT)
00148 !
00149   YRECFM='DG2_DIF'
00150   YCOMMENT='DG2 depth in ISBA-DIF'
00151 !
00152   CALL WRITE_SURF(HPROGRAM,YRECFM,XDG2(:,:),IRESP,HCOMMENT=YCOMMENT)
00153 !
00154 !* Runoff depth
00155 !
00156   YRECFM='RUNOFFD'
00157   YCOMMENT='Runoff deph in ISBA-DIF'
00158 !
00159   CALL WRITE_SURF(HPROGRAM,YRECFM,XRUNOFFD(:,:),IRESP,HCOMMENT=YCOMMENT)
00160 !
00161 !* Total soil depth for mositure
00162 !
00163   ZWORK(:,:)=XUNDEF
00164   DO JP=1,SIZE(XDG,3)
00165      DO JJ=1,SIZE(XDG,1)
00166         JL=NWG_LAYER(JJ,JP)
00167         IF(JL/=NUNDEF)THEN
00168           ZWORK(JJ,JP)=XDG(JJ,JL,JP)
00169         ENDIF
00170      ENDDO
00171   ENDDO
00172   YRECFM='DTOT_DIF'
00173   YCOMMENT='Total soil depth for moisture in ISBA-DIF'
00174   CALL WRITE_SURF(HPROGRAM,YRECFM,ZWORK(:,:),IRESP,HCOMMENT=YCOMMENT)
00175 !
00176 !* Root fraction for each patch
00177 !
00178   DO JL=1,SIZE(XROOTFRAC,2)
00179      IF (JL<10) THEN
00180        WRITE(YRECFM,FMT='(A8,I1)') 'ROOTFRAC',JL
00181      ELSE
00182        WRITE(YRECFM,FMT='(A8,I2)') 'ROOTFRAC',JL          
00183      ENDIF  
00184      YCOMMENT='root fraction by layer (-)'
00185      ZWORK(:,:)=XUNDEF
00186      DO JJ=1,SIZE(XDG,1)
00187         WHERE(JL<=NWG_LAYER(JJ,:).AND.NWG_LAYER(JJ,:)/=NUNDEF)
00188               ZWORK(JJ,:)=XROOTFRAC(JJ,JL,:)
00189         ENDWHERE
00190      ENDDO
00191      CALL WRITE_SURF(HPROGRAM,YRECFM,ZWORK(:,:),IRESP,HCOMMENT=YCOMMENT)
00192   END DO
00193 !
00194 !* SOC fraction for each layer
00195 !
00196   IF(CSOC=='SGH')THEN
00197     DO JL=1,SIZE(XDG,2)
00198      IF (JL<10) THEN
00199        WRITE(YRECFM,FMT='(A7,I1)') 'FRACSOC',JL
00200      ELSE
00201        WRITE(YRECFM,FMT='(A7,I2)') 'FRACSOC',JL          
00202      ENDIF  
00203      YCOMMENT='SOC fraction by layer (-)'
00204      CALL WRITE_SURF(HPROGRAM,YRECFM,XFRACSOC(:,JL),IRESP,HCOMMENT=YCOMMENT)
00205     END DO
00206   ENDIF
00207 !
00208 ENDIF        
00209 !
00210 !-------------------------------------------------------------------------------
00211 !
00212 DO JL=1,SIZE(XDG,2)
00213    IF (JL<10) THEN
00214      WRITE(YRECFM,FMT='(A4,I1)') 'WSAT',JL
00215    ELSE
00216      WRITE(YRECFM,FMT='(A4,I2)') 'WSAT',JL          
00217    ENDIF  
00218   YCOMMENT='soil porosity by layer (m3/m3)'
00219   CALL WRITE_SURF(HPROGRAM,YRECFM,XWSAT(:,JL),IRESP,HCOMMENT=YCOMMENT)
00220 ENDDO
00221 !
00222 DO JL=1,SIZE(XDG,2)
00223    IF (JL<10) THEN
00224      WRITE(YRECFM,FMT='(A3,I1)') 'WFC',JL
00225    ELSE
00226      WRITE(YRECFM,FMT='(A3,I2)') 'WFC',JL          
00227    ENDIF  
00228   YCOMMENT='field capacity by layer (m3/m3)'
00229   CALL WRITE_SURF(HPROGRAM,YRECFM,XWFC(:,JL),IRESP,HCOMMENT=YCOMMENT)
00230 ENDDO
00231 !
00232 DO JL=1,SIZE(XDG,2)
00233    IF (JL<10) THEN
00234      WRITE(YRECFM,FMT='(A5,I1)') 'WWILT',JL
00235    ELSE
00236      WRITE(YRECFM,FMT='(A5,I2)') 'WWILT',JL          
00237    ENDIF  
00238   YCOMMENT='wilting point by layer (m3/m3)'
00239   CALL WRITE_SURF(HPROGRAM,YRECFM,XWWILT(:,JL),IRESP,HCOMMENT=YCOMMENT)
00240 ENDDO     
00241 !
00242 !-------------------------------------------------------------------------------
00243 ! For Earth System Model
00244 IF(LFANOCOMPACT.AND..NOT.LPREP)THEN
00245   CALL END_IO_SURF_n(HPROGRAM)
00246   IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_ISBA_N',1,ZHOOK_HANDLE)
00247   RETURN
00248 ENDIF
00249 !
00250 !-------------------------------------------------------------------------------
00251 !
00252 YRECFM='Z0REL'
00253 YCOMMENT='orography roughness length (M)'
00254 !
00255  CALL WRITE_SURF(HPROGRAM,YRECFM,XZ0REL(:),IRESP,HCOMMENT=YCOMMENT)
00256 !
00257 !-------------------------------------------------------------------------------
00258 !
00259 !* Runoff soil ice depth for each patch
00260 !
00261 IF(CHORT=='SGH'.AND.CISBA/='DIF')THEN
00262   YRECFM='DICE'
00263   YCOMMENT='soil ice depth for runoff (m)'
00264   CALL WRITE_SURF(HPROGRAM,YRECFM,XD_ICE(:,:),IRESP,HCOMMENT=YCOMMENT)
00265 ENDIF
00266 !
00267 !-------------------------------------------------------------------------------
00268 !
00269 !* Fraction of each vegetation type for each patch
00270 !
00271 DO JL=1,SIZE(XVEGTYPE_PATCH,2)
00272   WRITE(YPAS,'(I2)') JL 
00273   YLVLV=ADJUSTL(YPAS(:LEN_TRIM(YPAS)))
00274   WRITE(YRECFM,FMT='(A9)') 'VEGTY_P'//YLVLV
00275   YCOMMENT='fraction of each vegetation type for each patch'//' (-)'
00276   CALL WRITE_SURF(HPROGRAM,YRECFM,XVEGTYPE_PATCH(:,JL,:),IRESP,HCOMMENT=YCOMMENT)
00277 END DO
00278 !-------------------------------------------------------------------------------
00279 !
00280 !* other surface parameters
00281 !
00282 YRECFM='RSMIN'
00283 YCOMMENT='minimum stomatal resistance (SM-1)'
00284  CALL WRITE_SURF(HPROGRAM,YRECFM,XRSMIN(:,:),IRESP,HCOMMENT=YCOMMENT)
00285 !
00286 YRECFM='GAMMA'
00287 YCOMMENT='coefficient for RSMIN calculation (-)'
00288  CALL WRITE_SURF(HPROGRAM,YRECFM,XGAMMA(:,:),IRESP,HCOMMENT=YCOMMENT)
00289 !
00290 YRECFM='CV'
00291 YCOMMENT='vegetation thermal inertia coefficient (-)'
00292  CALL WRITE_SURF(HPROGRAM,YRECFM,XCV(:,:),IRESP,HCOMMENT=YCOMMENT)
00293 !
00294 YRECFM='RGL'
00295 YCOMMENT='maximum solar radiation usable in photosynthesis (-)'
00296  CALL WRITE_SURF(HPROGRAM,YRECFM,XRGL(:,:),IRESP,HCOMMENT=YCOMMENT)
00297 !
00298 YRECFM='EMIS_ISBA'
00299 YCOMMENT='surface emissivity (-)'
00300  CALL WRITE_SURF(HPROGRAM,YRECFM,XEMIS(:,:),IRESP,HCOMMENT=YCOMMENT)
00301 !
00302 YRECFM='WRMAX_CF'
00303 YCOMMENT='coefficient for maximum water interception (-)'
00304  CALL WRITE_SURF(HPROGRAM,YRECFM,XWRMAX_CF(:,:),IRESP,HCOMMENT=YCOMMENT)
00305 !
00306 !-------------------------------------------------------------------------------
00307 !
00308 IF (LSURF_DIAG_ALBEDO) THEN
00309 !
00310 !* Soil albedos
00311 !
00312 !
00313    YRECFM='ALBNIR_S'
00314    YCOMMENT='soil near-infra-red albedo (-)'
00315    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBNIR_SOIL(:,:),IRESP,HCOMMENT=YCOMMENT)
00316 !
00317 !-------------------------------------------------------------------------------
00318 !
00319    YRECFM='ALBVIS_S'
00320    YCOMMENT='soil visible albedo (-)'
00321    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBVIS_SOIL(:,:),IRESP,HCOMMENT=YCOMMENT)
00322 !
00323 !-------------------------------------------------------------------------------
00324 !
00325    YRECFM='ALBUV_S'
00326    YCOMMENT='soil UV albedo (-)'
00327    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBUV_SOIL(:,:),IRESP,HCOMMENT=YCOMMENT)
00328 !
00329 !-------------------------------------------------------------------------------
00330 !
00331 !* albedos
00332 !
00333    YRECFM='ALBNIR_ISBA'
00334    YCOMMENT='total near-infra-red albedo (-)'
00335    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBNIR(:,:),IRESP,HCOMMENT=YCOMMENT)
00336 !
00337 !-------------------------------------------------------------------------------
00338 !
00339    YRECFM='ALBVIS_ISBA'
00340    YCOMMENT='total visible albedo (-)'
00341    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBVIS(:,:),IRESP,HCOMMENT=YCOMMENT)
00342 !
00343 !-------------------------------------------------------------------------------
00344 !
00345    YRECFM='ALBUV_ISBA'
00346    YCOMMENT='total UV albedo (-)'
00347    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBUV(:,:),IRESP,HCOMMENT=YCOMMENT)
00348 !
00349 END IF
00350 !
00351 !-------------------------------------------------------------------------------
00352 !
00353 !* chemical soil resistances
00354 !
00355 IF (CCH_DRY_DEP=='WES89' .AND. NBEQ>0) THEN
00356   YRECFM='SOILRC_SO2'
00357   YCOMMENT='bare soil resistance for SO2 (?)'
00358   CALL WRITE_SURF(HPROGRAM,YRECFM,XSOILRC_SO2(:,:),IRESP,HCOMMENT=YCOMMENT)
00359   !
00360   YRECFM='SOILRC_O3'
00361   YCOMMENT='bare soil resistance for O3 (?)'
00362   CALL WRITE_SURF(HPROGRAM,YRECFM,XSOILRC_O3(:,:),IRESP,HCOMMENT=YCOMMENT)
00363 END IF
00364 !
00365 !-------------------------------------------------------------------------------
00366 !
00367 IF (LAGRIP .AND. (CPHOTO=='LAI' .OR. CPHOTO=='LST' .OR. CPHOTO=='NIT' .OR. CPHOTO=='NCB') ) THEN
00368 !
00369 !* seeding and reaping
00370 !
00371 !
00372   YRECFM='TSEED'
00373   YCOMMENT='date of seeding (-)'
00374 !
00375   CALL WRITE_SURF(HPROGRAM,YRECFM,TSEED(:,:),IRESP,HCOMMENT=YCOMMENT)
00376 !
00377   YRECFM='TREAP'
00378   YCOMMENT='date of reaping (-)'
00379 !
00380   CALL WRITE_SURF(HPROGRAM,YRECFM,TREAP(:,:),IRESP,HCOMMENT=YCOMMENT)
00381 !
00382 !-------------------------------------------------------------------------------
00383 !
00384 !* irrigated fraction
00385 !
00386   YRECFM='IRRIG'
00387   YCOMMENT='flag for irrigation (irrigation if >0.) (-)'
00388 !
00389   CALL WRITE_SURF(HPROGRAM,YRECFM,XIRRIG(:,:),IRESP,HCOMMENT=YCOMMENT)
00390 !
00391 !-------------------------------------------------------------------------------
00392 !
00393 !* water supply for irrigation
00394 !
00395   YRECFM='WATSUP'
00396   YCOMMENT='water supply during irrigation process (mm)'
00397 !
00398   CALL WRITE_SURF(HPROGRAM,YRECFM,XWATSUP(:,:),IRESP,HCOMMENT=YCOMMENT)
00399 !
00400 ENDIF
00401 !-------------------------------------------------------------------------------
00402 !         End of IO
00403 !
00404  CALL END_IO_SURF_n(HPROGRAM)
00405 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_ISBA_N',1,ZHOOK_HANDLE)
00406 !
00407 !
00408 END SUBROUTINE WRITE_DIAG_PGD_ISBA_n