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

Go to the documentation of this file.
00001 !     ##########################
00002       MODULE MODI_UNPACK_SAME_RANK
00003 !     ##########################
00004 INTERFACE UNPACK_SAME_RANK
00005       SUBROUTINE UNPACK_SAME_RANK_FROM1DI(KM,K1D_IN,K1D_OUT,KMISS)
00006 
00007 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00008 INTEGER, DIMENSION(:),   INTENT(IN) :: K1D_IN
00009 INTEGER, DIMENSION(:),   INTENT(OUT):: K1D_OUT
00010 INTEGER, OPTIONAL,       INTENT(IN) :: KMISS
00011 END SUBROUTINE UNPACK_SAME_RANK_FROM1DI
00012 !
00013       SUBROUTINE UNPACK_SAME_RANK_FROM1DL(KM,O1D_IN,O1D_OUT,OMISS)
00014 
00015 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00016 LOGICAL, DIMENSION(:),   INTENT(IN) :: O1D_IN
00017 LOGICAL, DIMENSION(:),   INTENT(OUT):: O1D_OUT
00018 LOGICAL, OPTIONAL,       INTENT(IN) :: OMISS
00019 END SUBROUTINE UNPACK_SAME_RANK_FROM1DL
00020 !
00021       SUBROUTINE UNPACK_SAME_RANK_FROM1D(KM,P1D_IN,P1D_OUT,PMISS)
00022 
00023 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00024 REAL, DIMENSION(:),   INTENT(IN) :: P1D_IN
00025 REAL, DIMENSION(:),   INTENT(OUT):: P1D_OUT
00026 REAL, OPTIONAL,       INTENT(IN) :: PMISS
00027 END SUBROUTINE UNPACK_SAME_RANK_FROM1D
00028 !
00029       SUBROUTINE UNPACK_SAME_RANK_FROM2D(KM,P2D_IN,P2D_OUT,PMISS)
00030 
00031 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00032 REAL, DIMENSION(:,:), INTENT(IN) :: P2D_IN
00033 REAL, DIMENSION(:,:), INTENT(OUT):: P2D_OUT
00034 REAL, OPTIONAL,       INTENT(IN) :: PMISS
00035 !
00036 END SUBROUTINE UNPACK_SAME_RANK_FROM2D
00037 !
00038       SUBROUTINE UNPACK_SAME_RANK_FROM3D(KM,P3D_IN,P3D_OUT,PMISS)
00039 
00040 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00041 REAL, DIMENSION(:,:,:), INTENT(IN) :: P3D_IN
00042 REAL, DIMENSION(:,:,:), INTENT(OUT):: P3D_OUT
00043 REAL, OPTIONAL,       INTENT(IN) :: PMISS
00044 !
00045 END SUBROUTINE UNPACK_SAME_RANK_FROM3D
00046 !
00047       SUBROUTINE UNPACK_SAME_RANK_FROM4D(KM,P4D_IN,P4D_OUT,PMISS)
00048 
00049 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00050 REAL, DIMENSION(:,:,:,:), INTENT(IN) :: P4D_IN
00051 REAL, DIMENSION(:,:,:,:),   INTENT(OUT):: P4D_OUT
00052 REAL, OPTIONAL,       INTENT(IN) :: PMISS
00053 !
00054 END SUBROUTINE UNPACK_SAME_RANK_FROM4D
00055 !
00056 END INTERFACE 
00057 !
00058 END MODULE MODI_UNPACK_SAME_RANK
00059 !
00060 !     ##############################################
00061       SUBROUTINE UNPACK_SAME_RANK_FROM1D(KM,P1D_IN,P1D_OUT,PMISS)
00062 !     ##############################################
00063 !
00064 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 1D field into a 1D field of lower rank
00065 !!
00066 !!    PURPOSE
00067 !!    -------
00068 !!
00069 !!**  METHOD
00070 !!    ------
00071 !!
00072 !!    EXTERNAL
00073 !!    --------
00074 !!
00075 !!
00076 !!    IMPLICIT ARGUMENTS
00077 !!    ------------------
00078 !!
00079 !!    REFERENCE
00080 !!    ---------
00081 !!
00082 !!
00083 !!    AUTHOR
00084 !!    ------
00085 !!      F. Habets   *Meteo France*      
00086 !!
00087 !!    MODIFICATIONS
00088 !!    -------------
00089 !!      Original    08/03
00090 !!      B. Decharme 2008  Allows to put other optional value for missval
00091 !-------------------------------------------------------------------------------
00092 !
00093 !*       0.    DECLARATIONS
00094 !              ------------
00095 !
00096 USE MODD_SURF_PAR,   ONLY : XUNDEF
00097 !
00098 !
00099 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00100 USE PARKIND1  ,ONLY : JPRB
00101 !
00102 IMPLICIT NONE
00103 !
00104 !*       0.1   Declarations of arguments
00105 !              -------------------------
00106 !
00107 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00108 REAL, DIMENSION(:),   INTENT(IN) :: P1D_IN
00109 REAL, DIMENSION(:),   INTENT(OUT):: P1D_OUT
00110 REAL, OPTIONAL,       INTENT(IN) :: PMISS
00111 !
00112 !*       0.2   Declarations of local variables
00113 !              -------------------------------
00114 !
00115 INTEGER :: JI ! loop counter
00116 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00117 !
00118 !-------------------------------------------------------------------------------
00119 !
00120 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1D',0,ZHOOK_HANDLE)
00121 IF(PRESENT(PMISS))THEN
00122   P1D_OUT(:) = PMISS      
00123 ELSE
00124   P1D_OUT(:) = XUNDEF
00125 ENDIF
00126 !
00127 !cdir nodep
00128 DO JI=1,SIZE(P1D_IN,1)
00129   P1D_OUT(KM(JI)) = P1D_IN(JI) 
00130 ENDDO
00131 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1D',1,ZHOOK_HANDLE)
00132 !
00133 !-------------------------------------------------------------------------------
00134 !
00135 END SUBROUTINE UNPACK_SAME_RANK_FROM1D
00136 !
00137 !
00138 !     ##############################################
00139       SUBROUTINE UNPACK_SAME_RANK_FROM1DI(KM,K1D_IN,K1D_OUT,KMISS)
00140 !     ##############################################
00141 !
00142 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 1D field into a 1D field of lower rank
00143 !!
00144 !!    PURPOSE
00145 !!    -------
00146 !!
00147 !!**  METHOD
00148 !!    ------
00149 !!
00150 !!    EXTERNAL
00151 !!    --------
00152 !!
00153 !!
00154 !!    IMPLICIT ARGUMENTS
00155 !!    ------------------
00156 !!
00157 !!    REFERENCE
00158 !!    ---------
00159 !!
00160 !!
00161 !!    AUTHOR
00162 !!    ------
00163 !!      F. Habets   *Meteo France*      
00164 !!
00165 !!    MODIFICATIONS
00166 !!    -------------
00167 !!      Original    08/03
00168 !-------------------------------------------------------------------------------
00169 !
00170 !*       0.    DECLARATIONS
00171 !              ------------
00172 !
00173 USE MODD_SURF_PAR,   ONLY : NUNDEF
00174 !
00175 !
00176 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00177 USE PARKIND1  ,ONLY : JPRB
00178 !
00179 IMPLICIT NONE
00180 !
00181 !*       0.1   Declarations of arguments
00182 !              -------------------------
00183 !
00184 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00185 INTEGER, DIMENSION(:),   INTENT(IN) :: K1D_IN
00186 INTEGER, DIMENSION(:),   INTENT(OUT):: K1D_OUT
00187 INTEGER, OPTIONAL,       INTENT(IN) :: KMISS
00188 !
00189 !*       0.2   Declarations of local variables
00190 !              -------------------------------
00191 !
00192 INTEGER :: JI ! loop counter
00193 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00194 !
00195 !-------------------------------------------------------------------------------
00196 !
00197 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1DI',0,ZHOOK_HANDLE)
00198 IF(PRESENT(KMISS))THEN
00199   K1D_OUT(:) = KMISS      
00200 ELSE
00201   K1D_OUT(:) = NUNDEF
00202 ENDIF
00203 !
00204 !cdir nodep
00205 DO JI=1,SIZE(K1D_IN,1)
00206   K1D_OUT(KM(JI)) = K1D_IN(JI) 
00207 ENDDO
00208 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1DI',1,ZHOOK_HANDLE)
00209 !
00210 !-------------------------------------------------------------------------------
00211 !
00212 END SUBROUTINE UNPACK_SAME_RANK_FROM1DI
00213 !
00214 !
00215 !     ##############################################
00216       SUBROUTINE UNPACK_SAME_RANK_FROM1DL(KM,O1D_IN,O1D_OUT,OMISS)
00217 !     ##############################################
00218 !
00219 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 1D field into a 1D field of lower rank
00220 !!
00221 !!    PURPOSE
00222 !!    -------
00223 !!
00224 !!**  METHOD
00225 !!    ------
00226 !!
00227 !!    EXTERNAL
00228 !!    --------
00229 !!
00230 !!
00231 !!    IMPLICIT ARGUMENTS
00232 !!    ------------------
00233 !!
00234 !!    REFERENCE
00235 !!    ---------
00236 !!
00237 !!
00238 !!    AUTHOR
00239 !!    ------
00240 !!      F. Habets   *Meteo France*      
00241 !!
00242 !!    MODIFICATIONS
00243 !!    -------------
00244 !!      Original    08/03
00245 !-------------------------------------------------------------------------------
00246 !
00247 !*       0.    DECLARATIONS
00248 !              ------------
00249 !
00250 !
00251 !
00252 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00253 USE PARKIND1  ,ONLY : JPRB
00254 !
00255 IMPLICIT NONE
00256 !
00257 !*       0.1   Declarations of arguments
00258 !              -------------------------
00259 !
00260 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00261 LOGICAL, DIMENSION(:),   INTENT(IN) :: O1D_IN
00262 LOGICAL, DIMENSION(:),   INTENT(OUT):: O1D_OUT
00263 LOGICAL, OPTIONAL,       INTENT(IN) :: OMISS
00264 !
00265 !*       0.2   Declarations of local variables
00266 !              -------------------------------
00267 !
00268 INTEGER :: JI ! loop counter
00269 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00270 !
00271 !-------------------------------------------------------------------------------
00272 !
00273 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1DL',0,ZHOOK_HANDLE)
00274 IF(PRESENT(OMISS))THEN
00275   O1D_OUT(:) = OMISS      
00276 ELSE
00277   O1D_OUT(:) = .FALSE.
00278 ENDIF
00279 !
00280 !cdir nodep
00281 DO JI=1,SIZE(O1D_IN,1)
00282   O1D_OUT(KM(JI)) = O1D_IN(JI) 
00283 ENDDO
00284 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM1DL',1,ZHOOK_HANDLE)
00285 !
00286 !-------------------------------------------------------------------------------
00287 !
00288 END SUBROUTINE UNPACK_SAME_RANK_FROM1DL
00289 !
00290 !
00291 !     ##############################################
00292       SUBROUTINE UNPACK_SAME_RANK_FROM2D(KM,P2D_IN,P2D_OUT,PMISS)
00293 !     ##############################################
00294 !
00295 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 2D field into a 2D field
00296 !!
00297 !!    PURPOSE
00298 !!    -------
00299 !!
00300 !!**  METHOD
00301 !!    ------
00302 !!
00303 !!    EXTERNAL
00304 !!    --------
00305 !!
00306 !!
00307 !!    IMPLICIT ARGUMENTS
00308 !!    ------------------
00309 !!
00310 !!    REFERENCE
00311 !!    ---------
00312 !!
00313 !!
00314 !!    AUTHOR
00315 !!    ------
00316 !!      F. Habets   *Meteo France*      
00317 !!
00318 !!    MODIFICATIONS
00319 !!    -------------
00320 !!      Original    08/03
00321 !-------------------------------------------------------------------------------
00322 !
00323 !*       0.    DECLARATIONS
00324 !              ------------
00325 !
00326 USE MODD_SURF_PAR,   ONLY : XUNDEF
00327 !
00328 !
00329 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00330 USE PARKIND1  ,ONLY : JPRB
00331 !
00332 IMPLICIT NONE
00333 !
00334 !*       0.1   Declarations of arguments
00335 !              -------------------------
00336 !
00337 INTEGER, DIMENSION(:),  INTENT(IN) :: KM
00338 REAL, DIMENSION(:,:),   INTENT(IN) :: P2D_IN
00339 REAL, DIMENSION(:,:),   INTENT(OUT):: P2D_OUT
00340 REAL, OPTIONAL,         INTENT(IN) :: PMISS
00341 !
00342 !*       0.2   Declarations of local variables
00343 !              -------------------------------
00344 !
00345 INTEGER :: JI, JJ ! loop counter
00346 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00347 !
00348 !-------------------------------------------------------------------------------
00349 !
00350 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM2D',0,ZHOOK_HANDLE)
00351 IF(PRESENT(PMISS))THEN
00352   P2D_OUT(:,:) = PMISS      
00353 ELSE
00354   P2D_OUT(:,:) = XUNDEF
00355 ENDIF
00356 !
00357 DO JJ=1,SIZE(P2D_IN,2)
00358 !cdir nodep
00359   DO JI=1,SIZE(P2D_IN,1)
00360     P2D_OUT(KM(JI),JJ) = P2D_IN(JI,JJ)
00361   ENDDO 
00362 ENDDO
00363 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM2D',1,ZHOOK_HANDLE)
00364 !
00365 !-------------------------------------------------------------------------------
00366 !
00367 END SUBROUTINE UNPACK_SAME_RANK_FROM2D
00368 !
00369 !
00370 !-------------------------------------------------------------------------------
00371 !-------------------------------------------------------------------------------
00372 !     ##############################################
00373       SUBROUTINE UNPACK_SAME_RANK_FROM3D(KM,P3D_IN,P3D_OUT,PMISS)
00374 !     ##############################################
00375 !
00376 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 3D field into a 3D field
00377 !!
00378 !!    PURPOSE
00379 !!    -------
00380 !!
00381 !!**  METHOD
00382 !!    ------
00383 !!
00384 !!    EXTERNAL
00385 !!    --------
00386 !!
00387 !!
00388 !!    IMPLICIT ARGUMENTS
00389 !!    ------------------
00390 !!
00391 !!    REFERENCE
00392 !!    ---------
00393 !!
00394 !!
00395 !!    AUTHOR
00396 !!    ------
00397 !!      F. Habets   *Meteo France*      
00398 !!
00399 !!    MODIFICATIONS
00400 !!    -------------
00401 !!      Original    08/03
00402 !-------------------------------------------------------------------------------
00403 !
00404 !*       0.    DECLARATIONS
00405 !              ------------
00406 !
00407 USE MODD_SURF_PAR,   ONLY : XUNDEF
00408 !
00409 !
00410 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00411 USE PARKIND1  ,ONLY : JPRB
00412 !
00413 IMPLICIT NONE
00414 !
00415 !*       0.1   Declarations of arguments
00416 !              -------------------------
00417 !
00418 INTEGER, DIMENSION(:),   INTENT(IN) :: KM
00419 REAL, DIMENSION(:,:,:),  INTENT(IN) :: P3D_IN
00420 REAL, DIMENSION(:,:,:),  INTENT(OUT):: P3D_OUT
00421 REAL, OPTIONAL,          INTENT(IN) :: PMISS
00422 !
00423 !*       0.2   Declarations of local variables
00424 !              -------------------------------
00425 !
00426 INTEGER :: JI, JJ, JK ! loop counter
00427 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00428 !
00429 !-------------------------------------------------------------------------------
00430 !
00431 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM3D',0,ZHOOK_HANDLE)
00432 IF(PRESENT(PMISS))THEN
00433   P3D_OUT(:,:,:) = PMISS      
00434 ELSE
00435   P3D_OUT(:,:,:) = XUNDEF
00436 ENDIF
00437 !
00438 DO JK=1,SIZE(P3D_IN,3)
00439   DO JJ=1,SIZE(P3D_IN,2)
00440 !cdir nodep
00441     DO JI=1,SIZE(P3D_IN,1)
00442       P3D_OUT(KM(JI),JJ,JK) = P3D_IN(JI,JJ,JK)
00443     ENDDO
00444   ENDDO 
00445 ENDDO
00446 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM3D',1,ZHOOK_HANDLE)
00447 !
00448 !-------------------------------------------------------------------------------
00449 !
00450 END SUBROUTINE UNPACK_SAME_RANK_FROM3D
00451 !
00452 !-------------------------------------------------------------------------------
00453 !-------------------------------------------------------------------------------
00454 !     ##############################################
00455       SUBROUTINE UNPACK_SAME_RANK_FROM4D(KM,P4D_IN,P4D_OUT,PMISS)
00456 !     ##############################################
00457 !
00458 !!****  *UNPACK_SAME_RANK* - extract the defined data from a 4D field into a 4D field
00459 !!
00460 !!    PURPOSE
00461 !!    -------
00462 !!
00463 !!**  METHOD
00464 !!    ------
00465 !!
00466 !!    EXTERNAL
00467 !!    --------
00468 !!
00469 !!
00470 !!    IMPLICIT ARGUMENTS
00471 !!    ------------------
00472 !!
00473 !!    REFERENCE
00474 !!    ---------
00475 !!
00476 !!
00477 !!    AUTHOR
00478 !!    ------
00479 !!      F. Habets   *Meteo France*      
00480 !!
00481 !!    MODIFICATIONS
00482 !!    -------------
00483 !!      Original    08/03
00484 !-------------------------------------------------------------------------------
00485 !
00486 !*       0.    DECLARATIONS
00487 !              ------------
00488 !
00489 USE MODD_SURF_PAR,   ONLY : XUNDEF
00490 !
00491 !
00492 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00493 USE PARKIND1  ,ONLY : JPRB
00494 !
00495 IMPLICIT NONE
00496 !
00497 !*       0.1   Declarations of arguments
00498 !              -------------------------
00499 !
00500 INTEGER, DIMENSION(:),    INTENT(IN) :: KM
00501 REAL, DIMENSION(:,:,:,:), INTENT(IN) :: P4D_IN
00502 REAL, DIMENSION(:,:,:,:), INTENT(OUT):: P4D_OUT
00503 REAL, OPTIONAL,           INTENT(IN) :: PMISS
00504 !
00505 !*       0.2   Declarations of local variables
00506 !              -------------------------------
00507 !
00508 !
00509 INTEGER :: JI, JJ, JK, JL ! loop counter
00510 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00511 !
00512 !-------------------------------------------------------------------------------
00513 !
00514 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM4D',0,ZHOOK_HANDLE)
00515 IF(PRESENT(PMISS))THEN
00516   P4D_OUT(:,:,:,:) = PMISS      
00517 ELSE
00518   P4D_OUT(:,:,:,:) = XUNDEF
00519 ENDIF
00520 !
00521 DO JL=1,SIZE(P4D_OUT,4)
00522   DO JK=1,SIZE(P4D_OUT,3)
00523     DO JJ=1,SIZE(P4D_OUT,2)
00524 !cdir nodep
00525       DO JI=1,SIZE(P4D_OUT,1)
00526         P4D_OUT(KM(JI),JJ,JK,JL) = P4D_IN(JI,JJ,JK,JL)
00527       ENDDO
00528     ENDDO
00529   ENDDO
00530 ENDDO
00531 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK:UNPACK_SAME_RANK_FROM4D',1,ZHOOK_HANDLE)
00532 !
00533 !-------------------------------------------------------------------------------
00534 !
00535 END SUBROUTINE UNPACK_SAME_RANK_FROM4D