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

Go to the documentation of this file.
00001 MODULE MODI_INI_VAR_FROM_DATA
00002 !
00003 INTERFACE INI_VAR_FROM_DATA
00004 !
00005 SUBROUTINE INI_VAR_FROM_DATA_1D(HPROGRAM, HATYPE, HNAME, HTYPE, HFNAM, &
00006                                 HFTYP, PUNIF, PFIELD, OPRESENT)
00007 IMPLICIT NONE
00008 !
00009 !*    0.1    Declaration of arguments
00010 !            ------------------------
00011 !
00012  CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM
00013  CHARACTER(LEN=3), INTENT(IN) :: HATYPE
00014  CHARACTER(LEN=*), INTENT(IN) :: HNAME
00015  CHARACTER(LEN=3), INTENT(IN) :: HTYPE
00016  CHARACTER(LEN=28), DIMENSION(:), INTENT(IN) :: HFNAM
00017  CHARACTER(LEN=6), DIMENSION(:), INTENT(IN) :: HFTYP
00018 REAL, DIMENSION(:), INTENT(IN) :: PUNIF
00019 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD
00020 LOGICAL, INTENT(OUT) :: OPRESENT
00021 !
00022 END SUBROUTINE INI_VAR_FROM_DATA_1D
00023 !
00024 !
00025       SUBROUTINE INI_VAR_FROM_DATA_2D(HPROGRAM, HATYPE, HNAME, HTYPE, HFNAM, &
00026                                       HFTYP, PUNIF, PFIELD_TIME, OPRESENT)
00027 !                                         
00028 IMPLICIT NONE
00029 !
00030 !*    0.1    Declaration of arguments
00031 !            ------------------------
00032 !
00033  CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM
00034  CHARACTER(LEN=3), INTENT(IN) :: HATYPE
00035  CHARACTER(LEN=*), INTENT(IN) :: HNAME
00036  CHARACTER(LEN=3), INTENT(IN) :: HTYPE
00037  CHARACTER(LEN=28), DIMENSION(:,:), INTENT(IN) :: HFNAM
00038  CHARACTER(LEN=6), DIMENSION(:,:), INTENT(IN) :: HFTYP
00039 REAL, DIMENSION(:,:), INTENT(IN) :: PUNIF
00040 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD_TIME
00041 LOGICAL, INTENT(OUT) :: OPRESENT
00042 !
00043 END SUBROUTINE INI_VAR_FROM_DATA_2D
00044 !
00045 !
00046 END INTERFACE INI_VAR_FROM_DATA
00047 !
00048 END MODULE MODI_INI_VAR_FROM_DATA
00049 !
00050 !
00051 !     #########
00052       SUBROUTINE INI_VAR_FROM_DATA_1D(HPROGRAM, HATYPE, HNAME ,HTYPE, HFNAM, &
00053                                       HFTYP, PUNIF, PFIELD, OPRESENT)
00054 !     ##############################################################
00055 !
00056 !!
00057 !!    PURPOSE
00058 !!    -------
00059 !!
00060 !!    METHOD
00061 !!    ------
00062 !!   
00063 !
00064 !!    EXTERNAL
00065 !!    --------
00066 !!
00067 !!    IMPLICIT ARGUMENTS
00068 !!    ------------------
00069 !!
00070 !!    REFERENCE
00071 !!    ---------
00072 !!
00073 !!    AUTHOR
00074 !!    ------
00075 !!
00076 !!    S. Faroux        Meteo-France
00077 !!
00078 !!    MODIFICATION
00079 !!    ------------
00080 !!
00081 !!    Original    16/11/10
00082 !!
00083 !----------------------------------------------------------------------------
00084 !
00085 !*    0.     DECLARATION
00086 !            -----------
00087 !
00088 USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
00089 USE MODD_DATA_ISBA_n, ONLY : XPAR_VEGTYPE
00090 !
00091 USE MODI_INI_VAR_FROM_DATA_0D
00092 USE MODI_ABOR1_SFX
00093 !
00094 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00095 USE PARKIND1  ,ONLY : JPRB
00096 !
00097 IMPLICIT NONE
00098 !
00099 !*    0.1    Declaration of arguments
00100 !            ------------------------
00101 !
00102  CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM
00103  CHARACTER(LEN=3), INTENT(IN) :: HATYPE
00104  CHARACTER(LEN=*), INTENT(IN) :: HNAME
00105  CHARACTER(LEN=3), INTENT(IN) :: HTYPE
00106  CHARACTER(LEN=28), DIMENSION(:), INTENT(IN) :: HFNAM
00107  CHARACTER(LEN=6), DIMENSION(:), INTENT(IN) :: HFTYP
00108 REAL, DIMENSION(:), INTENT(IN) :: PUNIF
00109 REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD
00110 LOGICAL, INTENT(OUT) :: OPRESENT
00111 !
00112 !
00113 !*    0.2    Declaration of local variables
00114 !            ------------------------------
00115 !
00116  CHARACTER(LEN=40) :: YNAME
00117 LOGICAL, DIMENSION(SIZE(PFIELD,2)) :: LPRESENT 
00118 INTEGER               :: JI, JJ  ! loop counter on vegtypes
00119 !
00120 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00121 !
00122 
00123 !-------------------------------------------------------------------------------
00124 !
00125 !*    1.      Initializations
00126 !             ---------------
00127 !
00128 IF (LHOOK) &
00129   CALL DR_HOOK('MODI_INI_VAR_FROM_DATA:INI_VAR_FROM_DATA_1D',0,ZHOOK_HANDLE)
00130 !
00131 OPRESENT=.FALSE.
00132 YNAME=ADJUSTL(HNAME)
00133 !
00134 DO JI=1,SIZE(PFIELD,2)
00135   CALL INI_VAR_FROM_DATA_0D(HPROGRAM, HATYPE, HNAME, HTYPE, HFNAM(JI), &
00136               HFTYP(JI), PUNIF(JI), PFIELD(:,JI), LPRESENT(JI))
00137 ENDDO
00138 !
00139 IF (ANY(LPRESENT(:))) THEN
00140 
00141   OPRESENT=.TRUE.
00142 
00143   IF (SIZE(PFIELD,2)==NVEGTYPE .AND. YNAME(1:7).NE.'VEGTYPE') THEN
00144 
00145     !if a vegtype are missing, the last present gives it his values
00146     DO JI=2,SIZE(PFIELD,2)
00147       IF (.NOT.LPRESENT(JI)) THEN
00148         DO JJ=JI,1,-1
00149           IF (LPRESENT(JJ)) THEN
00150             PFIELD(:,JI)=PFIELD(:,JJ)
00151             LPRESENT(JI)=.TRUE.
00152             EXIT
00153           ENDIF
00154         ENDDO
00155       ENDIF
00156     ENDDO
00157 
00158     DO JI=1,SIZE(PFIELD,2)
00159       IF (LPRESENT(JI)) THEN
00160         WHERE (XPAR_VEGTYPE(:,JI).EQ.0.) PFIELD(:,JI)=0.0
00161       ELSE
00162         PFIELD(:,JI)=0.
00163       ENDIF
00164     ENDDO
00165 
00166   ELSEIF (.NOT.ALL(LPRESENT)) THEN
00167     CALL ABOR1_SFX("INI_VAR_FROM_DATA_1D: MISSING INPUT DATA FOR "//HNAME)
00168   ENDIF
00169 ENDIF
00170 !
00171 IF (LHOOK) &
00172   CALL DR_HOOK('MODI_INI_VAR_FROM_DATA:INI_VAR_FROM_DATA_1D',1,ZHOOK_HANDLE)
00173 !
00174 !-------------------------------------------------------------------------------
00175 !
00176 END SUBROUTINE INI_VAR_FROM_DATA_1D
00177 !
00178 !     #########
00179       SUBROUTINE INI_VAR_FROM_DATA_2D(HPROGRAM, HATYPE, HNAME, HTYPE, HFNAM, &
00180                                        HFTYP, PUNIF, PFIELD_TIME, OPRESENT)
00181 !     ##############################################################
00182 !
00183 !!
00184 !!    PURPOSE
00185 !!    -------
00186 !!
00187 !!    METHOD
00188 !!    ------
00189 !!   
00190 !
00191 !!    EXTERNAL
00192 !!    --------
00193 !!
00194 !!    IMPLICIT ARGUMENTS
00195 !!    ------------------
00196 !!
00197 !!    REFERENCE
00198 !!    ---------
00199 !!
00200 !!    AUTHOR
00201 !!    ------
00202 !!
00203 !!    S. Faroux        Meteo-France
00204 !!
00205 !!    MODIFICATION
00206 !!    ------------
00207 !!
00208 !!    Original    16/11/10
00209 !!
00210 !----------------------------------------------------------------------------
00211 !
00212 !*    0.     DECLARATION
00213 !            -----------
00214 !
00215 USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
00216 USE MODD_DATA_ISBA_n, ONLY : XPAR_VEGTYPE
00217 !
00218 USE MODI_INI_VAR_FROM_DATA_0D
00219 USE MODI_PUT_IN_TIME
00220 !
00221 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00222 USE PARKIND1  ,ONLY : JPRB
00223 !
00224 USE MODI_ABOR1_SFX
00225 !
00226 IMPLICIT NONE
00227 !
00228 !*    0.1    Declaration of arguments
00229 !            ------------------------
00230 !
00231  CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM
00232  CHARACTER(LEN=3), INTENT(IN) :: HATYPE
00233  CHARACTER(LEN=*), INTENT(IN) :: HNAME
00234  CHARACTER(LEN=3), INTENT(IN) :: HTYPE
00235  CHARACTER(LEN=28), DIMENSION(:,:), INTENT(IN) :: HFNAM
00236  CHARACTER(LEN=6), DIMENSION(:,:), INTENT(IN) :: HFTYP
00237 REAL, DIMENSION(:,:), INTENT(IN) :: PUNIF
00238 REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD_TIME
00239 LOGICAL, INTENT(OUT) :: OPRESENT
00240 !
00241 !
00242 !*    0.2    Declaration of local variables
00243 !            ------------------------------
00244 !
00245 LOGICAL, DIMENSION(SIZE(PFIELD_TIME,3)) :: LPRESENT
00246 LOGICAL, DIMENSION(SIZE(PFIELD_TIME,2)) :: LPRESENT_TIME
00247 INTEGER               :: JI, JJ  ! loop counter on vegtypes
00248 INTEGER               :: JTIME
00249 INTEGER               :: ITIME
00250 !
00251 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00252 !
00253 
00254 !-------------------------------------------------------------------------------
00255 !
00256 !*    1.      Initializations
00257 !             ---------------
00258 !
00259 IF (LHOOK) &
00260   CALL DR_HOOK('MODI_INI_VAR_FROM_DATA:INI_VAR_FROM_DATA_2D',0,ZHOOK_HANDLE)
00261 !
00262 OPRESENT=.FALSE.
00263 LPRESENT_TIME(:)=.FALSE.
00264 ITIME=0
00265 !
00266 DO JTIME=1,SIZE(PFIELD_TIME,2)
00267 
00268   DO JI=1,SIZE(PFIELD_TIME,3)
00269 
00270     CALL INI_VAR_FROM_DATA_0D(HPROGRAM, HATYPE, HNAME, HTYPE, HFNAM(JI,JTIME), &
00271               HFTYP(JI,JTIME), PUNIF(JI,JTIME), PFIELD_TIME(:,JTIME,JI),&
00272               LPRESENT(JI))
00273 
00274   ENDDO 
00275 
00276   IF (ANY(LPRESENT(:))) THEN
00277 
00278     LPRESENT_TIME(JTIME)=.TRUE.
00279     OPRESENT=.TRUE.
00280     ITIME=ITIME+1
00281 
00282     IF (SIZE(PFIELD_TIME,3)==NVEGTYPE) THEN
00283 
00284       DO JI=2,SIZE(PFIELD_TIME,3)
00285         IF (.NOT.LPRESENT(JI)) THEN
00286           DO JJ=JI,1,-1
00287             IF (LPRESENT(JJ)) THEN
00288               PFIELD_TIME(:,JTIME,JI)=PFIELD_TIME(:,JTIME,JJ)
00289               LPRESENT(JI)=.TRUE.
00290               EXIT
00291             ENDIF
00292           ENDDO
00293         ENDIF
00294       ENDDO
00295       DO JI=1,SIZE(PFIELD_TIME,3)
00296         IF (LPRESENT(JI)) THEN
00297           WHERE (XPAR_VEGTYPE(:,JI).EQ.0.) PFIELD_TIME(:,JTIME,JI)=0.0
00298         ELSE
00299           PFIELD_TIME(:,JTIME,JI)=0.
00300         ENDIF
00301       ENDDO
00302 
00303     ELSEIF (.NOT.ALL(LPRESENT)) THEN
00304       CALL ABOR1_SFX("INI_VAR_FROM_DATA_1D: MISSING INPUT DATA FOR "//HNAME)
00305     ENDIF
00306 
00307   ENDIF
00308 
00309 ENDDO
00310 !
00311 IF (OPRESENT) THEN
00312   IF (SIZE(PFIELD_TIME,2)==36) THEN
00313      CALL PUT_IN_TIME(ITIME,36,PFIELD_TIME)
00314   ELSE
00315     IF (ANY(LPRESENT_TIME(:)) .AND. .NOT.ALL(LPRESENT_TIME(:))) &
00316       CALL ABOR1_SFX("INI_VAR_FROM_DATA_2D: MISSING INPUT DATA FOR "//HNAME)
00317   ENDIF
00318 ENDIF
00319 !
00320 !
00321 IF (LHOOK) &
00322   CALL DR_HOOK('MODI_INI_VAR_FROM_DATA:INI_VAR_FROM_DATA_2D',1,ZHOOK_HANDLE)
00323 !
00324 !-------------------------------------------------------------------------------
00325 !
00326 END SUBROUTINE INI_VAR_FROM_DATA_2D