|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 ! ########################## 00002 MODULE MODI_UNPACK_SAME_RANK2 00003 ! ########################## 00004 INTERFACE UNPACK_SAME_RANK2 00005 ! 00006 SUBROUTINE UNPACK_SAME_RANK2_FROM1D(KM,P1D_IN,P1D_OUT,PMISS) 00007 00008 INTEGER, DIMENSION(:), INTENT(IN) :: KM 00009 REAL, DIMENSION(:), INTENT(IN) :: P1D_IN 00010 REAL(KIND=4), DIMENSION(:), INTENT(OUT):: P1D_OUT 00011 REAL, OPTIONAL, INTENT(IN) :: PMISS 00012 END SUBROUTINE UNPACK_SAME_RANK2_FROM1D 00013 ! 00014 SUBROUTINE UNPACK_SAME_RANK2_FROM2D(KM,P2D_IN,P2D_OUT,PMISS) 00015 00016 INTEGER, DIMENSION(:), INTENT(IN) :: KM 00017 REAL, DIMENSION(:,:), INTENT(IN) :: P2D_IN 00018 REAL(KIND=4), DIMENSION(:,:), INTENT(OUT):: P2D_OUT 00019 REAL, OPTIONAL, INTENT(IN) :: PMISS 00020 ! 00021 END SUBROUTINE UNPACK_SAME_RANK2_FROM2D 00022 ! 00023 END INTERFACE 00024 ! 00025 END MODULE MODI_UNPACK_SAME_RANK2 00026 ! 00027 ! 00028 ! ############################################## 00029 SUBROUTINE UNPACK_SAME_RANK2_FROM1D(KM,P1D_IN,P1D_OUT,PMISS) 00030 ! ############################################## 00031 ! 00032 !!**** *UNPACK_SAME_RANK2* - extract the defined data from a 1D field into a 1D field of lower rank 00033 !! 00034 !! PURPOSE 00035 !! ------- 00036 !! 00037 !!** METHOD 00038 !! ------ 00039 !! 00040 !! EXTERNAL 00041 !! -------- 00042 !! 00043 !! 00044 !! IMPLICIT ARGUMENTS 00045 !! ------------------ 00046 !! 00047 !! REFERENCE 00048 !! --------- 00049 !! 00050 !! 00051 !! AUTHOR 00052 !! ------ 00053 !! F. Habets *Meteo France* 00054 !! 00055 !! MODIFICATIONS 00056 !! ------------- 00057 !! Original 08/03 00058 !! B. Decharme 2008 Allows to put other optional value for missval 00059 !------------------------------------------------------------------------------- 00060 ! 00061 !* 0. DECLARATIONS 00062 ! ------------ 00063 ! 00064 USE MODD_SURF_PAR, ONLY : XUNDEF 00065 ! 00066 ! 00067 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00068 USE PARKIND1 ,ONLY : JPRB 00069 ! 00070 IMPLICIT NONE 00071 ! 00072 !* 0.1 Declarations of arguments 00073 ! ------------------------- 00074 ! 00075 INTEGER, DIMENSION(:), INTENT(IN) :: KM 00076 REAL, DIMENSION(:), INTENT(IN) :: P1D_IN 00077 REAL(KIND=4), DIMENSION(:), INTENT(OUT):: P1D_OUT 00078 REAL, OPTIONAL, INTENT(IN) :: PMISS 00079 ! 00080 !* 0.2 Declarations of local variables 00081 ! ------------------------------- 00082 ! 00083 INTEGER :: JI ! loop counter 00084 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00085 ! 00086 !------------------------------------------------------------------------------- 00087 ! 00088 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK2:UNPACK_SAME_RANK2_FROM1D',0,ZHOOK_HANDLE) 00089 IF(PRESENT(PMISS))THEN 00090 P1D_OUT(:) = PMISS 00091 ELSE 00092 P1D_OUT(:) = XUNDEF 00093 ENDIF 00094 ! 00095 !cdir nodep 00096 DO JI=1,SIZE(P1D_IN,1) 00097 P1D_OUT(KM(JI)) = P1D_IN(JI) 00098 ENDDO 00099 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK2:UNPACK_SAME_RANK2_FROM1D',1,ZHOOK_HANDLE) 00100 ! 00101 !------------------------------------------------------------------------------- 00102 ! 00103 END SUBROUTINE UNPACK_SAME_RANK2_FROM1D 00104 ! 00105 ! ############################################## 00106 SUBROUTINE UNPACK_SAME_RANK2_FROM2D(KM,P2D_IN,P2D_OUT,PMISS) 00107 ! ############################################## 00108 ! 00109 !!**** *UNPACK_SAME_RANK2* - extract the defined data from a 2D field into a 2D field 00110 !! 00111 !! PURPOSE 00112 !! ------- 00113 !! 00114 !!** METHOD 00115 !! ------ 00116 !! 00117 !! EXTERNAL 00118 !! -------- 00119 !! 00120 !! 00121 !! IMPLICIT ARGUMENTS 00122 !! ------------------ 00123 !! 00124 !! REFERENCE 00125 !! --------- 00126 !! 00127 !! 00128 !! AUTHOR 00129 !! ------ 00130 !! F. Habets *Meteo France* 00131 !! 00132 !! MODIFICATIONS 00133 !! ------------- 00134 !! Original 08/03 00135 !------------------------------------------------------------------------------- 00136 ! 00137 !* 0. DECLARATIONS 00138 ! ------------ 00139 ! 00140 USE MODD_SURF_PAR, ONLY : XUNDEF 00141 ! 00142 ! 00143 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00144 USE PARKIND1 ,ONLY : JPRB 00145 ! 00146 IMPLICIT NONE 00147 ! 00148 !* 0.1 Declarations of arguments 00149 ! ------------------------- 00150 ! 00151 INTEGER, DIMENSION(:), INTENT(IN) :: KM 00152 REAL, DIMENSION(:,:), INTENT(IN) :: P2D_IN 00153 REAL(KIND=4), DIMENSION(:,:), INTENT(OUT):: P2D_OUT 00154 REAL, OPTIONAL, INTENT(IN) :: PMISS 00155 ! 00156 !* 0.2 Declarations of local variables 00157 ! ------------------------------- 00158 ! 00159 INTEGER :: JI, JJ ! loop counter 00160 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00161 ! 00162 !------------------------------------------------------------------------------- 00163 ! 00164 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK2:UNPACK_SAME_RANK2_FROM2D',0,ZHOOK_HANDLE) 00165 IF(PRESENT(PMISS))THEN 00166 P2D_OUT(:,:) = PMISS 00167 ELSE 00168 P2D_OUT(:,:) = XUNDEF 00169 ENDIF 00170 ! 00171 DO JJ=1,SIZE(P2D_IN,2) 00172 !cdir nodep 00173 DO JI=1,SIZE(P2D_IN,1) 00174 P2D_OUT(KM(JI),JJ) = P2D_IN(JI,JJ) 00175 ENDDO 00176 ENDDO 00177 IF (LHOOK) CALL DR_HOOK('MODI_UNPACK_SAME_RANK2:UNPACK_SAME_RANK2_FROM2D',1,ZHOOK_HANDLE) 00178 ! 00179 !------------------------------------------------------------------------------- 00180 ! 00181 END SUBROUTINE UNPACK_SAME_RANK2_FROM2D 00182 !
1.8.0
