|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 !########################## 00002 MODULE MODE_GAUSS_INDEX 00003 !########################## 00004 ! 00005 ! 00006 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK 00007 USE PARKIND1 ,ONLY : JPRB 00008 ! 00009 USE MODI_ABOR1_SFX 00010 ! 00011 IMPLICIT NONE 00012 ! 00013 !############################################################################ 00014 ! 00015 CONTAINS 00016 ! 00017 !############################################################################ 00018 ! 00019 !############################################################################### 00020 SUBROUTINE READ_GAUSS_CONF(HPROGRAM,HFILE,HINDEX_1KM,HINDEX_10KM,HINDEX_100KM, & 00021 HINDEX,HRES,KDIM,KNLON,KNLAT,PDLON,PDLAT,PLON,PLAT) 00022 !############################################################################### 00023 ! 00024 !!**** *READ_GAUSS_CONF* - routine to read asked dimenssion 00025 !! 00026 !! AUTHOR 00027 !! ------ 00028 !! B. Decharme *Meteo France* 00029 !! 00030 !! MODIFICATIONS 00031 !! ------------- 00032 !! Original 02/2010 00033 !------------------------------------------------------------------------------- 00034 ! 00035 !* 0. DECLARATIONS 00036 ! ------------ 00037 ! 00038 USE MODI_OPEN_NAMELIST 00039 USE MODI_CLOSE_NAMELIST 00040 USE MODI_READHEAD 00041 ! 00042 IMPLICIT NONE 00043 ! 00044 ! 00045 !* 0.1 Declarations of arguments 00046 ! ------------------------- 00047 ! 00048 CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM ! Type of program 00049 CHARACTER(LEN=28), INTENT(IN) :: HFILE ! Name of the field file. 00050 CHARACTER(LEN=28), INTENT(IN) :: HINDEX_1KM ! index file at 1km 00051 CHARACTER(LEN=28), INTENT(IN) :: HINDEX_10KM ! index file at 10km 00052 CHARACTER(LEN=28), INTENT(IN) :: HINDEX_100KM ! index file at 100km 00053 CHARACTER(LEN=28), INTENT(OUT) :: HINDEX ! index file 00054 CHARACTER(LEN=5), INTENT(OUT) :: HRES ! resolution 00055 INTEGER, INTENT(OUT) :: KDIM ! number of grid point in file 00056 INTEGER, INTENT(OUT) :: KNLON ! number of longitude rows in file 00057 INTEGER, INTENT(OUT) :: KNLAT ! number of latitude rows in file 00058 REAL, DIMENSION(:), POINTER :: PLON ! longitude of data points 00059 REAL, DIMENSION(:), POINTER :: PLAT ! latitude of data points 00060 REAL, INTENT(OUT) :: PDLON ! longitude mesh in the data file 00061 REAL, INTENT(OUT) :: PDLAT ! latitude mesh in the data file 00062 ! 00063 ! 00064 !* 0.2 Declarations of local variables 00065 ! ------------------------------- 00066 ! 00067 CHARACTER(LEN=28) :: YFILEHDR ! Name of the field file header 00068 INTEGER :: IERR, IGLBHDR ! logical units 00069 ! 00070 REAL :: ZGLBLATMIN ! minimum latitude of data box in the file 00071 REAL :: ZGLBLONMIN ! minimum longitude of data box in the file 00072 REAL :: ZGLBLATMAX ! maximum latitude of data box in the file 00073 REAL :: ZGLBLONMAX ! maximum longitude of data box in the file 00074 INTEGER :: INBLINE ! number of latitude rows (number of lines 00075 INTEGER :: INBCOL ! number of longitude rows (number of columns) 00076 REAL :: ZNODATA ! value below which data are not considered 00077 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00078 ! 00079 !------------------------------------------------------------------------------- 00080 ! 00081 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:READ_GAUSS_CONF',0,ZHOOK_HANDLE) 00082 YFILEHDR =ADJUSTL(ADJUSTR(HFILE)//'.hdr') 00083 CALL OPEN_NAMELIST(HPROGRAM,IGLBHDR,YFILEHDR) 00084 ! 00085 CALL READHEAD(IGLBHDR,ZGLBLATMIN,ZGLBLATMAX,ZGLBLONMIN,ZGLBLONMAX, & 00086 INBLINE,INBCOL,ZNODATA,PDLAT,PDLON,PLAT,PLON,IERR) 00087 IF (IERR/=0) CALL ABOR1_SFX('READ_GAUSS_CONF: PB IN FILE HEADER') 00088 ! 00089 CALL CLOSE_NAMELIST(HPROGRAM,IGLBHDR) 00090 ! 00091 !------------------------------------------------------------------------------- 00092 ! 00093 KDIM = INBLINE*INBCOL 00094 KNLON = INBCOL 00095 KNLAT = INBLINE 00096 ! 00097 SELECT CASE (KDIM) 00098 CASE (21600*43200) 00099 HRES='1km' 00100 HINDEX=HINDEX_1KM 00101 CASE (2160*4320) 00102 HRES='10km' 00103 HINDEX=HINDEX_10KM 00104 CASE (216*432) 00105 HRES='100km' 00106 HINDEX=HINDEX_100KM 00107 CASE DEFAULT 00108 CALL ABOR1_SFX('READ_GAUSS_CONF: RESOLUTION NOT KNOW') 00109 END SELECT 00110 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:READ_GAUSS_CONF',1,ZHOOK_HANDLE) 00111 ! 00112 !############################################################################ 00113 END SUBROUTINE READ_GAUSS_CONF 00114 !############################################################################ 00115 ! 00116 !------------------------------------------------------------------------------------------- 00117 !------------------------------------------------------------------------------------------- 00118 ! 00119 !###################################################################################### 00120 SUBROUTINE MESH_INDEX_GAUSS(KGRID_PAR,KL,PGRID_PAR,PLAT,PLON,KINDEX,KSSO,KISSOX,KISSOY) 00121 !###################################################################################### 00122 ! 00123 !!**** *MESH_INDEX_GAUSS* get the grid mesh where point (lat,lon) is located 00124 !! 00125 !! PURPOSE 00126 !! ------- 00127 !! 00128 !! AUTHOR 00129 !! ------ 00130 !! 00131 !! V. Masson Meteo-France 00132 !! 00133 !! MODIFICATION 00134 !! ------------ 00135 !! 00136 !! Original 12/09/95 00137 !! 00138 !! B. Decharme 04/2009 use XY_GAUSS only if rotated pole and/or stretching 00139 !! for fast CPU time 00140 !! 00141 !---------------------------------------------------------------------------- 00142 ! 00143 !* 0. DECLARATION 00144 ! ----------- 00145 ! 00146 USE MODD_GET_MESH_INDEX_GAUSS, ONLY : XXCEN, XYCEN, XYINF, XYSUP, XXINF, XXSUP, & 00147 NNLATI, NNLOPA, XLAPO, XLOPO, XCODIL, & 00148 LROTSTRETCH, XXMAX 00149 00150 ! 00151 USE MODE_GRIDTYPE_GAUSS 00152 ! 00153 IMPLICIT NONE 00154 ! 00155 !* 0.1 Declaration of arguments 00156 ! ------------------------ 00157 ! 00158 INTEGER, INTENT(IN) :: KGRID_PAR ! size of PGRID_PAR 00159 INTEGER, INTENT(IN) :: KL ! number of points 00160 REAL, DIMENSION(KGRID_PAR), INTENT(IN) :: PGRID_PAR ! grid parameters 00161 REAL, DIMENSION(KL), INTENT(IN) :: PLAT ! latitude of the point (degrees) 00162 REAL, DIMENSION(KL), INTENT(IN) :: PLON ! longitude of the point (degrees) 00163 INTEGER, DIMENSION(KL), INTENT(OUT) :: KINDEX ! index of the grid mesh where the point is 00164 ! 00165 INTEGER, OPTIONAL, INTENT(IN) :: KSSO ! number of subgrid mesh in each direction 00166 INTEGER, DIMENSION(KL), OPTIONAL, INTENT(OUT) :: KISSOX ! X index of the subgrid mesh 00167 INTEGER, DIMENSION(KL), OPTIONAL, INTENT(OUT) :: KISSOY ! Y index of the subgrid mesh 00168 ! 00169 !* 0.2 Declaration of other local variables 00170 ! ------------------------------------ 00171 ! 00172 REAL :: ZX, ZXX ! pseudo longitude of input point 00173 REAL :: ZY ! pseudo latitude of input point 00174 INTEGER :: ILGRID ! number of grid points 00175 ! 00176 INTEGER :: JI ! loop counter in x 00177 INTEGER :: JJ ! loop counter in y 00178 INTEGER :: JL ! loop counter on input points 00179 INTEGER :: JGRID ! loop counter on grid points 00180 ! 00181 INTEGER :: ISSO 00182 LOGICAL :: LFOUND 00183 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00184 ! 00185 !---------------------------------------------------------------------------- 00186 ! 00187 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:MESH_INDEX_GAUSS',0,ZHOOK_HANDLE) 00188 KINDEX = -999 00189 IF(PRESENT(KSSO))THEN 00190 ISSO = KSSO 00191 KISSOX = -999 00192 KISSOY = -999 00193 ELSE 00194 ISSO = 0 00195 ENDIF 00196 ! 00197 ! 00198 IF (.NOT. ALLOCATED(NNLOPA)) THEN 00199 ! 00200 !* 1. Gets parameters of the projection 00201 ! --------------------------------- 00202 ! 00203 CALL GET_GRIDTYPE_GAUSS(PGRID_PAR,NNLATI,KL=ILGRID) 00204 ! 00205 ALLOCATE(NNLOPA(NNLATI)) 00206 ALLOCATE(XXCEN(ILGRID)) 00207 ALLOCATE(XYCEN(ILGRID)) 00208 CALL GET_GRIDTYPE_GAUSS(PGRID_PAR,NNLATI,XLAPO,XLOPO,XCODIL,NNLOPA(:), & 00209 ILGRID,PLAT_XY=XYCEN,PLON_XY=XXCEN ) 00210 ! 00211 !* 2. Limits of grid meshes in x and y 00212 ! -------------------------------- 00213 ! 00214 ALLOCATE(XXINF(ILGRID)) 00215 ALLOCATE(XYINF(ILGRID)) 00216 ALLOCATE(XXSUP(ILGRID)) 00217 ALLOCATE(XYSUP(ILGRID)) 00218 ! 00219 CALL GAUSS_GRID_LIMITS(NNLATI,NNLOPA,XXINF,XXSUP,XYINF,XYSUP) 00220 ! 00221 ALLOCATE(XXMAX(NNLATI)) 00222 JGRID = 0 00223 DO JJ=1,NNLATI 00224 DO JI=1,NNLOPA(JJ) 00225 JGRID=JGRID+1 00226 XXMAX(JJ)=XXSUP(JGRID) 00227 ENDDO 00228 ENDDO 00229 ! 00230 ! 00231 !* 3. Find if rotated pole and/or stretching to improve CPU time 00232 ! ---------------------------------------------------------- 00233 ! 00234 LROTSTRETCH=.TRUE. 00235 IF(XCODIL==1.0.AND.XLAPO==90.0.AND.XLOPO==0.0)LROTSTRETCH=.FALSE. 00236 ! 00237 END IF 00238 ! 00239 !------------------------------------------------------------------------------- 00240 !* loop on input points 00241 DO JL=1,KL 00242 !------------------------------------------------------------------------------- 00243 ! 00244 !* 4. Projection of input points into pseudo coordinates 00245 ! -------------------------------------------------- 00246 ! 00247 IF(LROTSTRETCH)THEN 00248 CALL XY_GAUSS(XLAPO,XLOPO,XCODIL,PLAT(JL),PLON(JL),ZY,ZX) 00249 ELSE 00250 ZX=PLON(JL) 00251 ZY=PLAT(JL) 00252 ENDIF 00253 ! 00254 JJ = 0 00255 JGRID = 0 00256 LFOUND= .FALSE. 00257 ! 00258 !* loop on grid points: latitude 00259 DO WHILE(.NOT.LFOUND) 00260 JJ=JJ+1 00261 IF(JJ>NNLATI)THEN 00262 CALL ABOR1_SFX('MESH_INDEX_GAUSS: input data point is not on a gauss latitude') 00263 ENDIF 00264 ! 00265 !* input data point is not on this circle of latitude : go to the next one 00266 IF(ZY<XYINF(JGRID+1).OR.ZY>=XYSUP(JGRID+1))THEN 00267 JGRID = JGRID + NNLOPA(JJ) 00268 ELSE 00269 ! 00270 !* loop on longitudes 00271 DO JI=1,NNLOPA(JJ) 00272 JGRID = JGRID + 1 00273 !*Reshifts the longitudes with respect to center of grid mesh 00274 ZXX = ZX+NINT((XXCEN(JGRID)-ZX)/360.)*360. 00275 IF(ZXX>=XXMAX(JJ)) ZXX=ZXX-360. 00276 !* imput point is in this grid mesh 00277 IF(ZXX>=XXINF(JGRID).AND.ZXX<XXSUP(JGRID))THEN 00278 KINDEX(JL) = JGRID 00279 ! 00280 !* 6. Localisation of the data points on in the subgrid of this mesh 00281 ! -------------------------------------------------------------- 00282 ! 00283 IF (KSSO/=0) THEN 00284 KISSOX(JL) = 1 + INT( FLOAT(KSSO) * (ZXX-XXINF(JGRID))/(XXSUP(JGRID)-XXINF(JGRID)) ) 00285 KISSOY(JL) = 1 + INT( FLOAT(KSSO) * (ZY -XYINF(JGRID))/(XYSUP(JGRID)-XYINF(JGRID)) ) 00286 END IF 00287 ! 00288 LFOUND=.TRUE. 00289 EXIT 00290 ! 00291 END IF 00292 ! 00293 END DO 00294 ! 00295 END IF 00296 ! 00297 END DO 00298 ! 00299 !------------------------------------------------------------------------------- 00300 END DO 00301 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:MESH_INDEX_GAUSS',1,ZHOOK_HANDLE) 00302 !------------------------------------------------------------------------------- 00303 ! 00304 !###################################################################################### 00305 END SUBROUTINE MESH_INDEX_GAUSS 00306 !############################################################################ 00307 ! 00308 !------------------------------------------------------------------------------------------- 00309 !------------------------------------------------------------------------------------------- 00310 ! 00311 !################################################################### 00312 SUBROUTINE GET_INDEX_GAUSS(KLUOUT,PLON,PLAT,KINDEX,KSSO,KSSOX,KSSOY) 00313 !################################################################### 00314 ! 00315 !!**** *GET_INDEX_GAUSS* - routine to read asked dimenssion 00316 !! 00317 !! AUTHOR 00318 !! ------ 00319 !! B. Decharme *Meteo France* 00320 !! 00321 !! MODIFICATIONS 00322 !! ------------- 00323 !! Original 02/2010 00324 !------------------------------------------------------------------------------- 00325 ! 00326 !* 0. DECLARATIONS 00327 ! ------------ 00328 ! 00329 USE MODD_GET_MESH_INDEX_GAUSS, ONLY : IINDEX_1KM,IINDEX_10KM,IINDEX_100KM, & 00330 IISSOX_1KM,IISSOX_10KM,IISSOX_100KM, & 00331 IISSOY_1KM,IISSOY_10KM,IISSOY_100KM 00332 00333 ! 00334 USE MODD_PGD_GRID, ONLY : CGRID, XGRID_PAR, NGRID_PAR 00335 ! 00336 IMPLICIT NONE 00337 ! 00338 ! 00339 !* 0.1 Declarations of arguments 00340 ! ------------------------- 00341 ! 00342 INTEGER, INTENT(IN) :: KLUOUT ! output listing 00343 REAL, DIMENSION(:), INTENT(IN) :: PLON ! longitude of the point 00344 REAL, DIMENSION(:), INTENT(IN) :: PLAT ! latitude of the point 00345 INTEGER, DIMENSION(:), INTENT(OUT) :: KINDEX ! index of the grid mesh where the point is 00346 INTEGER, OPTIONAL, INTENT(IN) :: KSSO ! number of subgrid mesh in each direction 00347 INTEGER, DIMENSION(:), OPTIONAL, INTENT(OUT) :: KSSOX ! X index of the subgrid mesh where the point is 00348 INTEGER, DIMENSION(:), OPTIONAL, INTENT(OUT) :: KSSOY ! Y index of the subgrid mesh where the point is 00349 ! 00350 ! 00351 !* 0.2 Declarations of local variables 00352 ! ------------------------------- 00353 ! 00354 REAL, DIMENSION(:), ALLOCATABLE :: ZLON,ZLON_W 00355 REAL, DIMENSION(:), ALLOCATABLE :: ZLAT 00356 ! 00357 INTEGER, DIMENSION(:), ALLOCATABLE :: ISSOX 00358 INTEGER, DIMENSION(:), ALLOCATABLE :: ISSOY 00359 ! 00360 REAL :: ZGLBLONMIN ! minimum longitude of data box in the file 00361 REAL :: ZGLBLONMAX ! maximum longitude of data box in the file 00362 ! 00363 INTEGER :: ISSO 00364 ! 00365 INTEGER :: JLOOP ! loop index 00366 INTEGER :: JLINE ! index of line 00367 INTEGER :: JCOL ! index of column 00368 INTEGER, DIMENSION(2) :: ICOL1, ICOL2 ! limits of index of columns 00369 INTEGER :: ILINE1,ILINE2! limits of index of lines 00370 INTEGER :: ICOL ! number of columns in mask domain 00371 INTEGER :: ICOLINDEX ! column index in record 00372 ! 00373 INTEGER :: JLON, JLAT, IWORK ! loop counters 00374 REAL :: ZLONMIN ! minimum longitude of mask mesh 00375 REAL :: ZLONMAX ! maximum longitude of mask mesh 00376 REAL :: ZLATMIN ! minimum latitude of mask mesh 00377 REAL :: ZLATMAX ! maximum latitude of mask mesh 00378 REAL :: ZSHIFT ! shift on longitudes 00379 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00380 ! 00381 !------------------------------------------------------------------------------- 00382 ! 00383 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:GET_INDEX_GAUSS',0,ZHOOK_HANDLE) 00384 IF (PRESENT(KSSO) .AND. PRESENT(KSSOX) .AND. PRESENT(KSSOY)) THEN 00385 ISSO = KSSO 00386 ALLOCATE(ISSOX(SIZE(KINDEX))) 00387 ALLOCATE(ISSOY(SIZE(KINDEX))) 00388 ELSE 00389 ISSO = 0 00390 ENDIF 00391 ! 00392 !------------------------------------------------------------------------------- 00393 ! 00394 ZGLBLONMIN=-180.0 00395 ZGLBLONMAX=180.0 00396 ! 00397 ALLOCATE(ZLAT(SIZE(KINDEX))) 00398 ALLOCATE(ZLON(SIZE(KINDEX))) 00399 ALLOCATE(ZLON_W(SIZE(PLON))) 00400 ! 00401 ZLON_W(:) = PLON(:) 00402 ! 00403 !---------------------------------------------------------------------------- 00404 ! 00405 IWORK = 0 00406 ! 00407 DO JLAT=1,360 00408 ! 00409 ZLATMIN = (JLAT-180)/2. - 0.5 00410 ZLATMAX = (JLAT-180)/2. 00411 ! 00412 ILINE1=COUNT(PLAT(:)> ZLATMAX)+1 00413 ILINE2=COUNT(PLAT(:)>=ZLATMIN) 00414 IF ( .NOT. ANY(PLAT(:)<ZLATMAX .AND. PLAT(:)>=ZLATMIN) ) CYCLE 00415 ! 00416 JLINE = ILINE1 00417 00418 DO 00419 ! 00420 DO JLON=1,720 00421 ! 00422 ZLONMIN = JLON /2. - 0.5 00423 ZLONMAX = JLON /2. 00424 ! 00425 ZSHIFT = 360. * NINT((ZLONMIN-ZGLBLONMIN-180.+1.E-10)/360.) 00426 ! 00427 ZGLBLONMIN = ZGLBLONMIN + ZSHIFT 00428 ZGLBLONMAX = ZGLBLONMAX + ZSHIFT 00429 00430 ! 00431 ZLON_W(:) = ZLON_W(:) + ZSHIFT 00432 ! 00433 ICOL1(1)=COUNT(ZLON_W(:)< ZLONMIN )+1 00434 ICOL2(1)=COUNT(ZLON_W(:)<=ZLONMAX) 00435 ! 00436 ICOL1(2)=1 00437 ICOL2(2)=COUNT(ZLON_W(:)+360.<=ZLONMAX) 00438 ! 00439 DO JLOOP=1,2 00440 ! 00441 ICOL = ICOL2(JLOOP) - ICOL1(JLOOP) + 1 00442 ! 00443 IF (ICOL<1) CYCLE 00444 ! 00445 DO JCOL=1,ICOL 00446 ! 00447 ICOLINDEX = JCOL+ICOL1(JLOOP)-1 00448 ! 00449 IWORK = IWORK + 1 00450 ZLAT(IWORK) = PLAT(JLINE) 00451 ZLON(IWORK) = ZLON_W(ICOLINDEX) 00452 ! 00453 END DO 00454 ! 00455 END DO 00456 ! 00457 END DO 00458 ! 00459 JLINE = JLINE + 1 00460 IF (JLINE==ILINE2+1) EXIT 00461 END DO 00462 ! 00463 END DO 00464 ! 00465 DEALLOCATE(ZLON_W) 00466 ! 00467 !------------------------------------------------------------------------------- 00468 ! 00469 IF (PRESENT(KSSO) .AND. PRESENT(KSSOX) .AND. PRESENT(KSSOY)) THEN 00470 ! 00471 CALL MESH_INDEX_GAUSS(NGRID_PAR,SIZE(KINDEX),XGRID_PAR,ZLAT,ZLON,KINDEX,KSSO,ISSOX,ISSOY) 00472 ! 00473 SELECT CASE (SIZE(KINDEX)) 00474 CASE (21600*43200) 00475 ALLOCATE(IINDEX_1KM(SIZE(KINDEX))) 00476 ALLOCATE(IISSOX_1KM(SIZE(KINDEX))) 00477 ALLOCATE(IISSOY_1KM(SIZE(KINDEX))) 00478 IINDEX_1KM(:)=KINDEX(:) 00479 IISSOX_1KM(:)=ISSOX(:) 00480 IISSOY_1KM(:)=ISSOY(:) 00481 CASE (2160*4320) 00482 ALLOCATE(IINDEX_10KM(SIZE(KINDEX))) 00483 ALLOCATE(IISSOX_10KM(SIZE(KINDEX))) 00484 ALLOCATE(IISSOY_10KM(SIZE(KINDEX))) 00485 IINDEX_10KM(:)=KINDEX(:) 00486 IISSOX_10KM(:)=ISSOX(:) 00487 IISSOY_10KM(:)=ISSOY(:) 00488 CASE (216*432) 00489 ALLOCATE(IINDEX_100KM(SIZE(KINDEX))) 00490 ALLOCATE(IISSOX_100KM(SIZE(KINDEX))) 00491 ALLOCATE(IISSOY_100KM(SIZE(KINDEX))) 00492 IINDEX_100KM(:)=KINDEX(:) 00493 IISSOX_100KM(:)=ISSOX(:) 00494 IISSOY_100KM(:)=ISSOY(:) 00495 CASE DEFAULT 00496 CALL ABOR1_SFX('READ_GAUSS_CONF: RESOLUTION NOT KNOW') 00497 END SELECT 00498 ! 00499 ELSE 00500 ! 00501 CALL MESH_INDEX_GAUSS(NGRID_PAR,SIZE(KINDEX),XGRID_PAR,ZLAT,ZLON,KINDEX) 00502 ! 00503 SELECT CASE (SIZE(KINDEX)) 00504 CASE (21600*43200) 00505 ALLOCATE(IINDEX_1KM(SIZE(KINDEX))) 00506 IINDEX_1KM(:)=KINDEX(:) 00507 CASE (2160*4320) 00508 ALLOCATE(IINDEX_10KM(SIZE(KINDEX))) 00509 IINDEX_10KM(:)=KINDEX(:) 00510 CASE (216*432) 00511 ALLOCATE(IINDEX_100KM(SIZE(KINDEX))) 00512 IINDEX_100KM(:)=KINDEX(:) 00513 CASE DEFAULT 00514 CALL ABOR1_SFX('READ_GAUSS_CONF: RESOLUTION NOT KNOW') 00515 END SELECT 00516 ! 00517 ENDIF 00518 ! 00519 !------------------------------------------------------------------------------- 00520 ! 00521 DEALLOCATE(ZLON) 00522 DEALLOCATE(ZLAT) 00523 ! 00524 IF (PRESENT(KSSO) .AND. PRESENT(KSSOX) .AND. PRESENT(KSSOY)) THEN 00525 KSSOX(:) = ISSOX(:) 00526 KSSOY(:) = ISSOY(:) 00527 DEALLOCATE(ISSOX) 00528 DEALLOCATE(ISSOY) 00529 ENDIF 00530 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:GET_INDEX_GAUSS',1,ZHOOK_HANDLE) 00531 ! 00532 !############################################################################ 00533 END SUBROUTINE GET_INDEX_GAUSS 00534 !############################################################################ 00535 ! 00536 !------------------------------------------------------------------------------------------- 00537 !------------------------------------------------------------------------------------------- 00538 ! 00539 !########################################################################## 00540 SUBROUTINE READ_INDEX_GAUSS(HPROGRAM,HINDEX,KNLON,KNLAT,KINDEX,KSSOX,KSSOY) 00541 !########################################################################## 00542 ! 00543 !!**** *READ_INDEX_GAUSS* read the grid mesh where point (lat,lon) is located 00544 !! in a binary file 00545 !! 00546 !! PURPOSE 00547 !! ------- 00548 !! 00549 !! AUTHOR 00550 !! ------ 00551 !! 00552 !! B. Decharme Meteo-France 00553 !! 00554 !! MODIFICATION 00555 !! ------------ 00556 !! 00557 !! Original 02/2010 00558 !------------------------------------------------------------------------------- 00559 ! 00560 !* 0. DECLARATION 00561 ! ----------- 00562 ! 00563 USE MODD_GET_MESH_INDEX_GAUSS, ONLY : IINDEX_1KM,IINDEX_10KM,IINDEX_100KM, & 00564 IISSOX_1KM,IISSOX_10KM,IISSOX_100KM, & 00565 IISSOY_1KM,IISSOY_10KM,IISSOY_100KM 00566 00567 ! 00568 USE MODI_OPEN_FILE 00569 USE MODI_CLOSE_FILE 00570 ! 00571 IMPLICIT NONE 00572 ! 00573 !* 0.1 Declaration of arguments 00574 ! ------------------------ 00575 ! 00576 CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM 00577 CHARACTER(LEN=28), INTENT(IN) :: HINDEX ! Index file 00578 INTEGER, INTENT(IN) :: KNLON ! number of longitude rows in file 00579 INTEGER, INTENT(IN) :: KNLAT ! number of longitude rows in file 00580 INTEGER, DIMENSION(:), INTENT(OUT) :: KINDEX ! mesh index of all input points 00581 ! 00582 INTEGER, DIMENSION(:), OPTIONAL, INTENT(OUT) :: KSSOX ! X submesh index in their mesh of all input points 00583 INTEGER, DIMENSION(:), OPTIONAL, INTENT(OUT) :: KSSOY ! Y submesh index in their mesh of all input points 00584 ! 00585 !* 0.2 Declaration of other local variables 00586 ! ------------------------------------ 00587 ! 00588 CHARACTER(LEN=28) :: YFILE 00589 ! 00590 INTEGER (KIND=4), DIMENSION(:), ALLOCATABLE :: IVALUE ! value of a data point 00591 ! 00592 INTEGER :: JLON, JLAT ! loop counters 00593 INTEGER :: IGLB ! record unit 00594 INTEGER :: IRECLENGTH ! record length 00595 INTEGER :: IREC ! record number 00596 INTEGER :: IREC_SSOX ! record number 00597 INTEGER :: IREC_SSOY ! record number 00598 INTEGER :: IBITS ! number of bits of a record in the 00599 ! ! direct access file 00600 ! 00601 INTEGER :: I,J,IERR 00602 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00603 ! 00604 !------------------------------------------------------------------------------- 00605 ! 00606 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:READ_INDEX_GAUSS',0,ZHOOK_HANDLE) 00607 IBITS = 32 00608 IRECLENGTH = IBITS/8 * KNLON 00609 ! 00610 YFILE=ADJUSTL(HINDEX(:LEN_TRIM(HINDEX))//'.bin') 00611 ! 00612 ALLOCATE (IVALUE(KNLON)) 00613 ! 00614 !------------------------------------------------------------------------------- 00615 00616 CALL OPEN_FILE(HPROGRAM,IGLB,YFILE,'UNFORMATTED', & 00617 HACTION='READ',HACCESS='DIRECT',KRECL=IRECLENGTH ) 00618 ! 00619 !------------------------------------------------------------------------------- 00620 ! 00621 I=0 00622 IREC=0 00623 DO JLAT=1,KNLAT 00624 ! 00625 IREC=JLAT 00626 ! 00627 READ(IGLB,REC=IREC,IOSTAT=IERR) IVALUE(:) 00628 IF(IERR/=0)CALL ABOR1_SFX('READ_INDEX_GAUSS: PROBLEME READING INPUT INDEX FILE') 00629 ! 00630 J=0 00631 DO JLON=1,KNLON 00632 J=J+1 00633 I=I+1 00634 KINDEX(I)=IVALUE(J) 00635 ENDDO 00636 ! 00637 ENDDO 00638 ! 00639 SELECT CASE (SIZE(KINDEX)) 00640 CASE (21600*43200) 00641 ALLOCATE(IINDEX_1KM(SIZE(KINDEX))) 00642 IINDEX_1KM(:)=KINDEX(:) 00643 CASE (2160*4320) 00644 ALLOCATE(IINDEX_10KM(SIZE(KINDEX))) 00645 IINDEX_10KM(:)=KINDEX(:) 00646 CASE (216*432) 00647 ALLOCATE(IINDEX_100KM(SIZE(KINDEX))) 00648 IINDEX_100KM(:)=KINDEX(:) 00649 CASE DEFAULT 00650 CALL ABOR1_SFX('READ_INDEX_GAUSS: RESOLUTION NOT KNOW') 00651 END SELECT 00652 ! 00653 !------------------------------------------------------------------------------- 00654 ! 00655 IF(PRESENT(KSSOX).AND.PRESENT(KSSOY))THEN 00656 ! 00657 I=0 00658 IREC_SSOX=0 00659 DO JLAT=1,KNLAT 00660 ! 00661 IREC_SSOX=IREC+JLAT 00662 ! 00663 READ(IGLB,REC=IREC_SSOX,IOSTAT=IERR) IVALUE(:) 00664 IF(IERR/=0)CALL ABOR1_SFX('READ_INDEX_GAUSS: NO INDEX SSOX IN INPUT INDEX FILE') 00665 00666 ! 00667 J=0 00668 DO JLON=1,KNLON 00669 J=J+1 00670 I=I+1 00671 KSSOX(I)=IVALUE(J) 00672 ENDDO 00673 ! 00674 ENDDO 00675 ! 00676 I=0 00677 IREC_SSOY=0 00678 DO JLAT=1,KNLAT 00679 ! 00680 IREC_SSOY=IREC_SSOX+JLAT 00681 ! 00682 READ(IGLB,REC=IREC_SSOY,IOSTAT=IERR) IVALUE(:) 00683 IF(IERR/=0)CALL ABOR1_SFX('READ_INDEX_GAUSS: NO INDEX SSOY IN INPUT INDEX FILE') 00684 ! 00685 J=0 00686 DO JLON=1,KNLON 00687 J=J+1 00688 I=I+1 00689 KSSOY(I)=IVALUE(J) 00690 ENDDO 00691 ! 00692 ENDDO 00693 ! 00694 SELECT CASE (SIZE(KINDEX)) 00695 CASE (21600*43200) 00696 ALLOCATE(IISSOX_1KM(SIZE(KINDEX))) 00697 ALLOCATE(IISSOY_1KM(SIZE(KINDEX))) 00698 IISSOX_1KM(:)=KSSOX(:) 00699 IISSOY_1KM(:)=KSSOY(:) 00700 CASE (2160*4320) 00701 ALLOCATE(IISSOX_10KM(SIZE(KINDEX))) 00702 ALLOCATE(IISSOY_10KM(SIZE(KINDEX))) 00703 IISSOX_10KM(:)=KSSOX(:) 00704 IISSOY_10KM(:)=KSSOY(:) 00705 CASE (216*432) 00706 ALLOCATE(IISSOX_100KM(SIZE(KINDEX))) 00707 ALLOCATE(IISSOY_100KM(SIZE(KINDEX))) 00708 IISSOX_100KM(:)=KSSOX(:) 00709 IISSOY_100KM(:)=KSSOY(:) 00710 CASE DEFAULT 00711 CALL ABOR1_SFX('READ_GAUSS_CONF: RESOLUTION NOT KNOW FOR SSO') 00712 END SELECT 00713 ! 00714 ENDIF 00715 ! 00716 DEALLOCATE (IVALUE) 00717 ! 00718 !------------------------------------------------------------------------------- 00719 ! 00720 CALL CLOSE_FILE(HPROGRAM,IGLB) 00721 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:READ_INDEX_GAUSS',1,ZHOOK_HANDLE) 00722 ! 00723 !###################################################################################### 00724 END SUBROUTINE READ_INDEX_GAUSS 00725 !############################################################################ 00726 ! 00727 !########################################################################## 00728 SUBROUTINE STORE_INDEX_GAUSS(HPROGRAM,HRES,KNLON,KNLAT,KINDEX,KSSOX,KSSOY) 00729 !########################################################################## 00730 ! 00731 !!**** *STORE_INDEX_GAUSS* store the grid mesh where point (lat,lon) is located 00732 !! in a binary file 00733 !! 00734 !! PURPOSE 00735 !! ------- 00736 !! 00737 !! AUTHOR 00738 !! ------ 00739 !! 00740 !! B. Decharme Meteo-France 00741 !! 00742 !! MODIFICATION 00743 !! ------------ 00744 !! 00745 !! Original 02/2010 00746 !------------------------------------------------------------------------------- 00747 ! 00748 !* 0. DECLARATION 00749 ! ----------- 00750 ! 00751 USE MODD_SURF_ATM_GRID_n, ONLY : XGRID_PAR 00752 ! 00753 USE MODI_OPEN_FILE 00754 USE MODI_CLOSE_FILE 00755 ! 00756 USE MODE_GRIDTYPE_GAUSS 00757 ! 00758 IMPLICIT NONE 00759 ! 00760 !* 0.1 Declaration of arguments 00761 ! ------------------------ 00762 ! 00763 CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM 00764 CHARACTER(LEN=5), INTENT(IN) :: HRES ! Resolution 00765 INTEGER, INTENT(IN) :: KNLON ! number of longitude rows in file 00766 INTEGER, INTENT(IN) :: KNLAT ! number of longitude rows in file 00767 INTEGER, DIMENSION(:), INTENT(IN) :: KINDEX ! mesh index of all input points 00768 ! 00769 INTEGER, DIMENSION(:), OPTIONAL, INTENT(IN) :: KSSOX ! X submesh index in their mesh of all input points 00770 INTEGER, DIMENSION(:), OPTIONAL, INTENT(IN) :: KSSOY ! Y submesh index in their mesh of all input points 00771 ! 00772 !* 0.2 Declaration of other local variables 00773 ! ------------------------------------ 00774 ! 00775 INTEGER (KIND=4), DIMENSION(:), ALLOCATABLE :: IVALUE ! value of a data point 00776 ! 00777 CHARACTER(LEN=28) :: YFILENAME, YNLATI 00778 ! 00779 INTEGER :: INLATI 00780 ! 00781 INTEGER :: JLON, JLAT ! loop counters 00782 INTEGER :: IGLB ! record unit 00783 INTEGER :: IRECLENGTH ! record length 00784 INTEGER :: IREC ! record number 00785 INTEGER :: IREC_SSOX ! record number 00786 INTEGER :: IREC_SSOY ! record number 00787 INTEGER :: IBITS ! number of bits of a record in the 00788 ! ! direct access file 00789 ! 00790 INTEGER :: I,J 00791 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00792 ! 00793 !------------------------------------------------------------------------------- 00794 ! 00795 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:STORE_INDEX_GAUSS',0,ZHOOK_HANDLE) 00796 IBITS = 32 00797 IRECLENGTH = IBITS/8 * KNLON 00798 ! 00799 CALL GET_GRIDTYPE_GAUSS(XGRID_PAR,KNLATI=INLATI) 00800 ! 00801 WRITE(YNLATI,'(I28)')(INLATI-1) 00802 YFILENAME='index_'//ADJUSTL(HRES(:LEN_TRIM(HRES)))//'_to_t'//ADJUSTL(YNLATI(:LEN_TRIM(YNLATI))//'.bin') 00803 ! 00804 ALLOCATE (IVALUE(KNLON)) 00805 ! 00806 !------------------------------------------------------------------------------- 00807 00808 CALL OPEN_FILE(HPROGRAM,IGLB,YFILENAME,'UNFORMATTED', & 00809 HACTION='WRITE',HACCESS='DIRECT',KRECL=IRECLENGTH ) 00810 ! 00811 !------------------------------------------------------------------------------- 00812 ! 00813 I=0 00814 IREC=0 00815 DO JLAT=1,KNLAT 00816 ! 00817 J=0 00818 IREC=JLAT 00819 DO JLON=1,KNLON 00820 J=J+1 00821 I=I+1 00822 IVALUE(J)=KINDEX(I) 00823 ENDDO 00824 ! 00825 WRITE(IGLB,REC=IREC) IVALUE(:) 00826 ! 00827 ENDDO 00828 ! 00829 !------------------------------------------------------------------------------- 00830 ! 00831 IF(PRESENT(KSSOX).AND.PRESENT(KSSOY))THEN 00832 ! 00833 I=0 00834 IREC_SSOX=0 00835 DO JLAT=1,KNLAT 00836 ! 00837 J=0 00838 IREC_SSOX=IREC+JLAT 00839 DO JLON=1,KNLON 00840 J=J+1 00841 I=I+1 00842 IVALUE(J)=KSSOX(I) 00843 ENDDO 00844 ! 00845 WRITE(IGLB,REC=IREC_SSOX) IVALUE(:) 00846 ! 00847 ENDDO 00848 ! 00849 I=0 00850 IREC_SSOY=0 00851 DO JLAT=1,KNLAT 00852 ! 00853 J=0 00854 IREC_SSOY=IREC_SSOX+JLAT 00855 DO JLON=1,KNLON 00856 J=J+1 00857 I=I+1 00858 IVALUE(J)=KSSOY(I) 00859 ENDDO 00860 ! 00861 WRITE(IGLB,REC=IREC_SSOY) IVALUE(:) 00862 ! 00863 ENDDO 00864 ! 00865 ENDIF 00866 ! 00867 DEALLOCATE (IVALUE) 00868 ! 00869 !------------------------------------------------------------------------------- 00870 ! 00871 CALL CLOSE_FILE(HPROGRAM,IGLB) 00872 IF (LHOOK) CALL DR_HOOK('MODE_GAUSS_INDEX:STORE_INDEX_GAUSS',1,ZHOOK_HANDLE) 00873 ! 00874 !###################################################################################### 00875 END SUBROUTINE STORE_INDEX_GAUSS 00876 !############################################################################ 00877 ! 00878 END MODULE MODE_GAUSS_INDEX 00879
1.8.0
