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

Go to the documentation of this file.
00001 !     #########
00002       SUBROUTINE WRITESURF_GR_SNOW(HPROGRAM,HSURFTYPE,HPREFIX,TPSNOW  )
00003 !     ##########################################################
00004 !
00005 !!****  *WRITESURF_GR_SNOW* - routine to write snow surface fields
00006 !!
00007 !!    PURPOSE
00008 !!    -------
00009 !       Writes snow surface fields
00010 !
00011 !!**  METHOD
00012 !!    ------
00013 !!    
00014 !!    
00015 !!
00016 !!    EXTERNAL
00017 !!    --------
00018 !!
00019 !!       
00020 !!    IMPLICIT ARGUMENTS
00021 !!    ------------------ 
00022 !!
00023 !!    REFERENCE
00024 !!    ---------
00025 !!
00026 !!      
00027 !!
00028 !!    AUTHOR
00029 !!    ------
00030 !!      V. Masson       * Meteo France *
00031 !!
00032 !!    MODIFICATIONS
00033 !!    -------------
00034 !!      Original      02/2003
00035 !!     A. Bogatchev 09/2005 EBA snow option
00036 !-----------------------------------------------------------------------------
00037 !
00038 !*       0.    DECLARATIONS
00039 !
00040 USE MODD_SURF_PAR,   ONLY : XUNDEF
00041 USE MODD_TYPE_SNOW
00042 USE MODD_PREP_SNOW, ONLY : LSNOW_FRAC_TOT
00043 !
00044 USE MODI_DETECT_FIELD
00045 USE MODI_WRITE_SURF
00046 !
00047 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00048 USE PARKIND1  ,ONLY : JPRB
00049 !
00050 IMPLICIT NONE
00051 !
00052 !*       0.1   declarations of arguments
00053 !
00054  CHARACTER (LEN=6),  INTENT(IN) :: HPROGRAM   ! program
00055  CHARACTER (LEN=*),  INTENT(IN) :: HSURFTYPE  ! generic name used for
00056                                              ! snow characteristics
00057                                              ! storage in file
00058  CHARACTER (LEN=3),  INTENT(IN) :: HPREFIX    ! generic name of prefix for
00059                                              ! patch identification
00060 TYPE(SURF_SNOW),    INTENT(IN) :: TPSNOW     ! snow characteristics
00061 !
00062 !*       0.2   declarations of local variables
00063 !
00064 INTEGER             :: ISURFTYPE_LEN
00065 !
00066  CHARACTER (LEN=100) :: YFMT           ! format for writing
00067  CHARACTER(LEN=12)   :: YRECFM         ! Name of the article to be read
00068  CHARACTER(LEN=100)  :: YCOMMENT       ! Comment string
00069 INTEGER             :: IRESP          ! IRESP  : return-code if a problem appears
00070 !
00071 LOGICAL             :: GSNOW          ! T --> snow exists somewhere
00072 !
00073 INTEGER             :: JLAYER         ! loop counter
00074  CHARACTER(LEN=4)    :: YNLAYER        ! String depending on the number of layer : less
00075                                       !than 10 or more                              
00076 !
00077 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00078 !-------------------------------------------------------------------------------
00079 IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',0,ZHOOK_HANDLE)
00080 !
00081 !*       1.    Initialisation
00082 !              --------------
00083 
00084 ISURFTYPE_LEN = LEN_TRIM(HSURFTYPE)
00085 !
00086 !
00087 !*       2.    Type of snow scheme
00088 !              -------------------
00089 !
00090 WRITE(YFMT,'(A5,I1,A4)') '(A3,A',ISURFTYPE_LEN,',A4)'
00091 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE,'_TYP'
00092 YRECFM=ADJUSTL(HPREFIX//YRECFM)
00093 YCOMMENT=' '
00094  CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%SCHEME,IRESP,HCOMMENT=YCOMMENT)
00095 !
00096 !
00097 !*       3.    Number of layers
00098 !              ----------------
00099 !
00100 WRITE(YFMT,'(A5,I1,A4)') '(A3,A',ISURFTYPE_LEN,',A2)'
00101 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE,'_N'
00102 YRECFM=ADJUSTL(HPREFIX//YRECFM)
00103 YCOMMENT    = '(INTEGER)'
00104  CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%NLAYER,IRESP,HCOMMENT=YCOMMENT)
00105 !
00106 !
00107 !*       4.    Tests to find if there is snow
00108 !              ------------------------------
00109 !
00110 IF (TPSNOW%NLAYER>0) THEN
00111   CALL DETECT_FIELD(HPROGRAM,TPSNOW%WSNOW(:,1,:),GSNOW)
00112 ELSE
00113   GSNOW = .FALSE.
00114 END IF
00115 !
00116 WRITE(YFMT,'(A5,I1,A1)') '(A3,A',ISURFTYPE_LEN,')'
00117 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE
00118 YRECFM=ADJUSTL(HPREFIX//YRECFM)
00119 YCOMMENT    = '(LOGICAL)'
00120  CALL WRITE_SURF(HPROGRAM,YRECFM,GSNOW,IRESP,HCOMMENT=YCOMMENT)
00121 !
00122 !
00123 IF (.NOT. GSNOW) THEN
00124   IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',1,ZHOOK_HANDLE)
00125   RETURN
00126 END IF
00127 !
00128 !
00129 !*       5.    Additional key
00130 !              ---------------
00131 !
00132 YCOMMENT    = '(LOGICAL)'
00133  CALL WRITE_SURF(HPROGRAM,'LSNOW_FRAC_T',LSNOW_FRAC_TOT,IRESP,HCOMMENT=YCOMMENT)
00134 !
00135 !
00136 DO JLAYER = 1,TPSNOW%NLAYER
00137   !
00138   YNLAYER='I1.1'
00139   IF (JLAYER>9) YNLAYER='I2.2'
00140   !
00141   IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. &
00142       TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
00143     !
00144     !*       6.    Snow reservoir
00145     !              --------------
00146     !
00147     WRITE(YFMT,'(A5,I1,A6)') '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00148     WRITE(YRECFM,YFMT) 'WSN_',HSURFTYPE,JLAYER
00149     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00150     WRITE(YFMT,'(A6,I1,A9)') '(A10,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00151     WRITE(YCOMMENT,YFMT) 'X_Y_WSNOW_',HSURFTYPE,JLAYER,' (kg/m2)'
00152     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%WSNOW(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00153     !
00154     !*       7.    Snow density
00155     !              ------------
00156     !
00157     WRITE(YFMT,'(A5,I1,A6)') '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00158     WRITE(YRECFM,YFMT) 'RSN_',HSURFTYPE,JLAYER
00159     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00160     WRITE(YFMT,'(A6,I1,A9)') '(A10,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00161     WRITE(YCOMMENT,YFMT) 'X_Y_RSNOW_',HSURFTYPE,JLAYER,' (kg/m2)'
00162     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%RHO(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00163     !
00164   END IF
00165   !
00166   !*       8.    Snow temperature
00167   !              ----------------
00168   !
00169   IF (TPSNOW%SCHEME=='1-L') THEN
00170     !
00171     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00172     WRITE(YRECFM,YFMT) 'TSN_',HSURFTYPE,JLAYER
00173     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00174     WRITE(YFMT,'(A6,I1,A9)')     '(A10,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00175     WRITE(YCOMMENT,YFMT) 'X_Y_TSNOW_',HSURFTYPE,JLAYER,' (kg/m2)'
00176     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%T(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00177     !
00178   END IF
00179   !
00180   !*       9.    Heat content
00181   !              ------------
00182   !
00183   IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
00184     !
00185     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00186     WRITE(YRECFM,YFMT) 'HSN_',HSURFTYPE,JLAYER
00187     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00188     WRITE(YFMT,'(A6,I1,A9)')     '(A10,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00189     WRITE(YCOMMENT,YFMT) 'X_Y_HSNOW_',HSURFTYPE,JLAYER,' (kg/m2)'
00190     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%HEAT(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00191     !
00192   END IF
00193   !
00194   IF (TPSNOW%SCHEME=='CRO') THEN
00195     !
00196     !*       10.    Snow Gran1
00197     !              ----------
00198     !
00199     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00200     WRITE(YRECFM,YFMT) 'SG1_',HSURFTYPE,JLAYER
00201     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00202     WRITE(YFMT,'(A6,I1,A9)')     '(A11,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00203     WRITE(YCOMMENT,YFMT) 'X_Y_SGRAN1_',HSURFTYPE,JLAYER,' (-)'
00204     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%GRAN1(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00205     !
00206     !*       11.    Snow Gran2
00207     !              ------------
00208     !
00209     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00210     WRITE(YRECFM,YFMT) 'SG2_',HSURFTYPE,JLAYER
00211     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00212     WRITE(YFMT,'(A6,I1,A9)')     '(A11,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00213     WRITE(YCOMMENT,YFMT) 'X_Y_SGRAN2_',HSURFTYPE,JLAYER,' (-)'
00214     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%GRAN2(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00215     !
00216     !*       12.   Historical parameter
00217     !              -------------------
00218     !
00219     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00220     WRITE(YRECFM,YFMT) 'SHI_',HSURFTYPE,JLAYER
00221     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00222     WRITE(YFMT,'(A6,I1,A9)')     '(A10,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00223     WRITE(YCOMMENT,YFMT) 'X_Y_SHIST_',HSURFTYPE,JLAYER,' (-)'
00224     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%HIST(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00225     !
00226     !*       13.    Age parameter
00227     !              ---------------
00228     !
00229     WRITE(YFMT,'(A5,I1,A6)')     '(A4,A',ISURFTYPE_LEN,','//YNLAYER//')'
00230     WRITE(YRECFM,YFMT) 'SAG_',HSURFTYPE,JLAYER
00231     YRECFM=ADJUSTL(HPREFIX//YRECFM)
00232     WRITE(YFMT,'(A6,I1,A9)')     '(A9,A',ISURFTYPE_LEN,','//YNLAYER//',A8))'
00233     WRITE(YCOMMENT,YFMT) 'X_Y_SAGE_',HSURFTYPE,JLAYER,' (-)'
00234     CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%AGE(:,JLAYER,:),IRESP,HCOMMENT=YCOMMENT)
00235     !
00236   END IF
00237   !
00238 END DO
00239 !
00240 !
00241 !*       14.    Albedo
00242 !              ------
00243 !
00244 IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='1-L' .OR. &
00245     TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
00246   !
00247   WRITE(YFMT,'(A5,I1,A1)')     '(A4,A',ISURFTYPE_LEN,')'
00248   WRITE(YRECFM,YFMT) 'ASN_',HSURFTYPE
00249   YRECFM=ADJUSTL(HPREFIX//YRECFM)
00250   WRITE(YFMT,'(A6,I1,A5)')     '(A10,A',ISURFTYPE_LEN,',A10)'
00251   WRITE(YCOMMENT,YFMT) 'X_Y_ASNOW_',HSURFTYPE,' (no unit)'
00252   CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%ALB(:,:),IRESP,HCOMMENT=YCOMMENT)
00253   !
00254 END IF
00255 !
00256 IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',1,ZHOOK_HANDLE)
00257 !
00258 END SUBROUTINE WRITESURF_GR_SNOW