|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 MODULE rotations 00002 !----------------------------------------------------------------------- 00003 00004 USE kinds_mod ! defines common data types 00005 USE constants ! defines common constants 00006 USE mod_parameter 00007 USE grids 00008 USE mod_unitncdf 00009 USE vector 00010 00011 IMPLICIT NONE 00012 00013 !!#include <netcdf.inc> ! include done in module vector 00014 00015 REAL (KIND=dbl_kind), PARAMETER :: 00016 rp_deg2rad = pi/180. ! Conversion from degrees to radians 00017 00018 ! 00019 ! This module contains necessary routines for transformations between 00020 ! the referentials Cartesian, spheric and streched spheric. 00021 ! 00022 00023 ! History: 00024 ! -------- 00025 ! E. Rapaport 2004/03 Created 00026 ! J. Ghattas 2006/02 Modified and added write of matrix to remapping file 00027 ! 00028 00029 CONTAINS 00030 00031 !----------------------------------------------------------------------- 00032 00033 SUBROUTINE angel(cd_grd_name,id_grd_size,rda_sin_alpha,rda_cos_alpha) 00034 00035 CHARACTER (LEN=8), INTENT(in) :: cd_grd_name ! grid name 00036 00037 INTEGER (KIND=int_kind), INTENT(in) :: id_grd_size ! grid size 00038 00039 CHARACTER(LEN=8) :: name_ang ! name of the angle valew in grids.nc 00040 00041 REAL (KIND=dbl_kind), DIMENSION (:), ALLOCATABLE :: rla_alpha 00042 ! the angel between the direction j in streched and the 00043 ! north-south in spheric coordonate system 00044 00045 INTEGER (KIND=int_kind) :: 00046 il_stat, il_varid, il_vtype, ! netcdf variables 00047 icount, ilenstr, i 00048 00049 !RETURN VALUE: 00050 00051 REAL (KIND=dbl_kind), DIMENSION(id_grd_size), INTENT(out) :: 00052 rda_sin_alpha, ! the sinus and cosinus for the angel between the 00053 rda_cos_alpha ! direction j in streched and the north-south 00054 ! in spheric 00055 00056 ! !DESCRIPTION: 00057 ! 00058 ! This routine finds the cosinus and sinus of the angle between the 00059 ! north-south direction in a spheric referential and the direction 00060 ! of gridlines j in a streched spheric referential. 00061 ! If there is no angel information in file grids.nc we stop. 00062 ! 00063 00064 IF (nlogprt .GE. 2) THEN 00065 WRITE (UNIT = nulou,FMT = *) ' ' 00066 WRITE (UNIT = nulou,FMT = *) ' Entering ROUTINE angel' 00067 WRITE (UNIT = nulou,FMT = *) ' ' 00068 CALL FLUSH(nulou) 00069 ENDIF 00070 00071 IF (lncdfgrd) THEN 00072 icount = ilenstr(cd_grd_name,jpeight) 00073 name_ang = cd_grd_name(1:icount)//'.ang' 00074 00075 CALL hdlerr & 00076 (NF_OPEN('grids.nc',NF_NOWRITE,nc_grdid),'angel') 00077 00078 il_stat = NF_INQ_VARID(nc_grdid, name_ang, il_varid) 00079 00080 IF (il_stat < 0) THEN 00081 WRITE (UNIT = nulou,FMT = *) & 00082 'File grids.nc contains no angle information,' 00083 WRITE (UNIT = nulou,FMT = *) & 00084 'OASIS will stop' 00085 STOP 00086 ELSE IF (il_stat == 0) THEN 00087 ! 00088 !** Get angle information from file grids.nc 00089 ! 00090 ALLOCATE(rla_alpha(id_grd_size)) 00091 00092 CALL hdlerr(NF_GET_VAR_DOUBLE & 00093 (nc_grdid, il_varid, rla_alpha),'angel') 00094 00095 rda_sin_alpha(:) = SIN(rp_deg2rad*rla_alpha(:)) 00096 rda_cos_alpha(:) = COS(rp_deg2rad*rla_alpha(:)) 00097 00098 DEALLOCATE(rla_alpha) 00099 END IF 00100 00101 CALL hdlerr (NF_CLOSE(nc_grdid),'angel') 00102 ELSE 00103 il_stat = -1 00104 END IF 00105 00106 IF (nlogprt .GE. 2) THEN 00107 WRITE (UNIT = nulou,FMT = *) ' ' 00108 WRITE (UNIT = nulou,FMT = *) ' Leaving routine angel ' 00109 CALL FLUSH (nulou) 00110 ENDIF 00111 00112 END SUBROUTINE angel 00113 ! 00114 !----------------------------------------------------------------------- 00115 ! 00116 SUBROUTINE loc2spher(cd_grd_name, id_grd_size, rda_trans, nc_fileid) 00117 00118 CHARACTER (LEN=8),INTENT(in) :: 00119 cd_grd_name ! grid name 00120 00121 INTEGER (KIND=int_kind), INTENT(in) :: 00122 id_grd_size, ! grid size 00123 nc_fileid ! id of open netcdf remapping file 00124 00125 ! !RETURN VALUE: 00126 00127 REAL (KIND=dbl_kind), DIMENSION(id_grd_size,2,2), INTENT(out) :: 00128 rda_trans 00129 00130 ! Local variables: 00131 REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: 00132 rla_sin_alpha, ! the sinus and cosinus for the angel between the 00133 rla_cos_alpha ! direction j in streched and the north-south 00134 ! in spheric 00135 00136 INTEGER(KIND=int_kind) :: dimid_src, dim2_id, var_id, stat 00137 INTEGER(KIND=int_kind), DIMENSION(3) :: dim_id 00138 00139 ! !DESCRIPTION: 00140 ! 00141 ! This routine finds the transformation matrix between a local stretched 00142 ! spheric referential and a regulier spheric referential. 00143 ! The matrix is returned and written to open file with id nc_fileid 00144 ! 00145 00146 IF (nlogprt .GE. 2) THEN 00147 WRITE (UNIT = nulou,FMT = *) ' ' 00148 WRITE (UNIT = nulou,FMT = *) ' Entering ROUTINE loc2spher ' 00149 CALL FLUSH(nulou) 00150 ENDIF 00151 ! 00152 !*Find the angle between the two referentials 00153 ! 00154 CALL angel(cd_grd_name, id_grd_size, & 00155 rla_sin_alpha, rla_cos_alpha) 00156 00157 rda_trans(:,1,1) = rla_cos_alpha 00158 rda_trans(:,2,1) = rla_sin_alpha 00159 rda_trans(:,1,2) = -rla_sin_alpha 00160 rda_trans(:,2,2) = rla_cos_alpha 00161 00162 00163 ! 00164 !*Write matrix to remapping file 00165 ! 00166 00167 CALL hdlerr(NF_REDEF(nc_fileid), 'loc2spher') 00168 00169 CALL hdlerr(NF_INQ_DIMID & 00170 (nc_fileid,'src_grid_size',dimid_src), 'loc2spher') 00171 00172 stat=NF_INQ_DIMID(nc_fileid,'dim_2',dim2_id) 00173 00174 IF (stat .NE. NF_NOERR) THEN 00175 CALL hdlerr(NF_DEF_DIM & 00176 (nc_fileid,'dim_2',2,dim2_id), 'loc2spher') 00177 ENDIF 00178 00179 dim_id(1) = dimid_src 00180 dim_id(2) = dim2_id 00181 dim_id(3) = dim2_id 00182 00183 CALL hdlerr(NF_DEF_VAR & 00184 (nc_fileid,'Mat_src_loc2sph',NF_DOUBLE,3,dim_id,var_id), 'loc2spher') 00185 00186 CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,var_id, 'matrix',& 00187 55,'Transformation matrix for source grid local to spheric'),& 00188 'loc2spher') 00189 00190 CALL hdlerr(NF_ENDDEF(nc_fileid), 'loc2spher') 00191 00192 CALL hdlerr(NF_PUT_VAR_DOUBLE & 00193 (nc_fileid,var_id,rda_trans),'loc2spher') 00194 00195 00196 IF (nlogprt .GE. 2) THEN 00197 WRITE (UNIT = nulou,FMT = *) & 00198 ' --------- Leaving routine loc2spher ---------' 00199 WRITE (UNIT = nulou,FMT = *) ' ' 00200 CALL FLUSH(nulou) 00201 ENDIF 00202 00203 END SUBROUTINE loc2spher 00204 ! 00205 !----------------------------------------------------------------------- 00206 ! 00207 SUBROUTINE spher2loc(cd_grd_name, id_grd_size, rda_trans, nc_fileid) 00208 00209 !* Input variables 00210 CHARACTER (LEN=8),INTENT(in) :: 00211 cd_grd_name ! grid name 00212 00213 INTEGER (KIND=int_kind), INTENT(in) :: 00214 id_grd_size, ! grid size 00215 nc_fileid ! id of open netcdf remapping file 00216 00217 !*RETURN VALUE: 00218 REAL (KIND=dbl_kind), DIMENSION(id_grd_size,2,2), INTENT(out) :: rda_trans 00219 00220 !*Local variables 00221 REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: 00222 rla_sin_alpha, ! the sinus and cosinus for the angel between the 00223 rla_cos_alpha ! direction j in streched and the north-south in spheric 00224 00225 INTEGER(KIND=int_kind) :: dimid_dst, dim2_id, var_id, stat 00226 INTEGER(KIND=int_kind), DIMENSION(3) :: dim_id 00227 00228 !*DESCRIPTION: 00229 ! Finds the transformation matrix between a spheric and a stretched 00230 ! spheric referential. 00231 ! 00232 00233 IF (nlogprt .GE. 2) THEN 00234 WRITE (UNIT = nulou,FMT = *) ' ' 00235 WRITE (UNIT = nulou,FMT = *) ' Entering ROUTINE spher2loc ' 00236 CALL FLUSH(nulou) 00237 ENDIF 00238 ! 00239 !*Find the angle between the two referentials 00240 ! 00241 CALL angel(cd_grd_name, id_grd_size, & 00242 rla_sin_alpha, rla_cos_alpha) 00243 00244 rda_trans(:,1,1) = rla_cos_alpha 00245 rda_trans(:,2,1) = -rla_sin_alpha 00246 rda_trans(:,1,2) = rla_sin_alpha 00247 rda_trans(:,2,2) = rla_cos_alpha 00248 00249 ! 00250 !*Write matrix to remapping file 00251 ! 00252 00253 CALL hdlerr(NF_REDEF(nc_fileid), 'spher2loc') 00254 00255 CALL hdlerr(NF_INQ_DIMID & 00256 (nc_fileid,'dst_grid_size',dimid_dst), 'spher2loc') 00257 00258 stat=NF_INQ_DIMID(nc_fileid,'dim_2',dim2_id) 00259 00260 IF (stat .NE. NF_NOERR) THEN 00261 CALL hdlerr(NF_DEF_DIM & 00262 (nc_fileid,'dim_2',2,dim2_id), 'spher2loc') 00263 ENDIF 00264 00265 dim_id(1) = dimid_dst 00266 dim_id(2) = dim2_id 00267 dim_id(3) = dim2_id 00268 00269 CALL hdlerr(NF_DEF_VAR & 00270 (nc_fileid,'Mat_dst_sph2loc',NF_DOUBLE,3,dim_id,var_id), 'spher2loc') 00271 00272 CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,var_id, 'matrix',& 00273 55,'Transformation matrix for target grid spheric to local'),& 00274 'spher2loc') 00275 00276 CALL hdlerr(NF_ENDDEF(nc_fileid), 'spher2loc') 00277 00278 CALL hdlerr(NF_PUT_VAR_DOUBLE & 00279 (nc_fileid,var_id,rda_trans),'spher2loc') 00280 00281 00282 00283 IF (nlogprt .GE. 2) THEN 00284 WRITE (UNIT = nulou,FMT = *) & 00285 ' --------- Leaving routine spher2loc ---------' 00286 WRITE (UNIT = nulou,FMT = *) ' ' 00287 CALL FLUSH(nulou) 00288 ENDIF 00289 00290 END SUBROUTINE spher2loc 00291 ! 00292 !----------------------------------------------------------------------- 00293 ! 00294 SUBROUTINE spher2car(rda_grd_lon, rda_grd_lat, id_grd_size, rda_trans, nc_fileid) 00295 00296 INTEGER (KIND=int_kind), INTENT(in) :: 00297 id_grd_size, ! grid size 00298 nc_fileid ! id of open netcdf remapping file 00299 00300 REAL (KIND=dbl_kind), DIMENSION(id_grd_size),INTENT(in) :: 00301 rda_grd_lon, ! grid longitudes 00302 rda_grd_lat ! grid latitudes 00303 00304 ! !RETURN VALUE: 00305 00306 REAL (KIND=dbl_kind), DIMENSION(id_grd_size,3,2), INTENT(out) :: rda_trans 00307 00308 ! Local variables 00309 00310 REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: 00311 rla_sin_lon, rla_cos_lon, ! sinus and cosinus for longitudes 00312 rla_sin_lat, rla_cos_lat ! sinus and cosinus for latitudes 00313 00314 INTEGER(KIND=int_kind) :: dimid_src, dim2_id, dim3_id, var_id, stat 00315 INTEGER(KIND=int_kind), DIMENSION(3) :: dim_id 00316 00317 00318 00319 ! !DESCRIPTION: 00320 ! Finds the rotation matrix between a spheric and cartesien referentails. 00321 ! 00322 00323 IF (nlogprt .GE. 2) THEN 00324 WRITE (UNIT = nulou,FMT = *) ' ' 00325 WRITE (UNIT = nulou,FMT = *) ' Entering ROUTINE - spher2car' 00326 WRITE (UNIT = nulou,FMT = *) ' ' 00327 CALL FLUSH(nulou) 00328 ENDIF 00329 00330 rla_sin_lon(:) = SIN(rda_grd_lon(:) * rp_deg2rad) 00331 rla_cos_lon(:) = COS(rda_grd_lon(:) * rp_deg2rad) 00332 rla_sin_lat(:) = SIN(rda_grd_lat(:) * rp_deg2rad) 00333 rla_cos_lat(:) = COS(rda_grd_lat(:) * rp_deg2rad) 00334 00335 rda_trans(:,1,1) = -rla_sin_lon(:) 00336 rda_trans(:,1,2) = -rla_sin_lat(:) * rla_cos_lon(:) 00337 rda_trans(:,2,1) = rla_cos_lon(:) 00338 rda_trans(:,2,2) = -rla_sin_lat(:) * rla_sin_lon(:) 00339 rda_trans(:,3,1) = 0. 00340 rda_trans(:,3,2) = rla_cos_lat(:) 00341 00342 ! 00343 !*Write matrix to remapping file 00344 ! 00345 00346 CALL hdlerr(NF_REDEF(nc_fileid), 'spher2car') 00347 00348 CALL hdlerr(NF_INQ_DIMID & 00349 (nc_fileid,'src_grid_size',dimid_src), 'spher2car') 00350 00351 stat=NF_INQ_DIMID(nc_fileid,'dim_2',dim2_id) 00352 00353 IF (stat .NE. NF_NOERR) THEN 00354 CALL hdlerr(NF_DEF_DIM & 00355 (nc_fileid,'dim_2',2,dim2_id), 'spher2car') 00356 ENDIF 00357 00358 stat=NF_INQ_DIMID(nc_fileid,'dim_3',dim3_id) 00359 00360 IF (stat .NE. NF_NOERR) THEN 00361 CALL hdlerr(NF_DEF_DIM & 00362 (nc_fileid,'dim_3',3,dim3_id), 'spher2car') 00363 ENDIF 00364 00365 dim_id(1) = dimid_src 00366 dim_id(2) = dim3_id 00367 dim_id(3) = dim2_id 00368 00369 CALL hdlerr(NF_DEF_VAR & 00370 (nc_fileid,'Mat_src_sph2car',NF_DOUBLE,3,dim_id,var_id), 'spher2car') 00371 00372 CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,var_id, 'matrix',& 00373 60,'Transformation matrix for source grid spheric to cartesian'),& 00374 'spher2car') 00375 00376 CALL hdlerr(NF_ENDDEF(nc_fileid), 'spher2car') 00377 00378 CALL hdlerr(NF_PUT_VAR_DOUBLE & 00379 (nc_fileid,var_id,rda_trans),'spher2car') 00380 00381 00382 00383 IF (nlogprt .GE. 2) THEN 00384 WRITE (UNIT = nulou,FMT = *) ' ' 00385 WRITE (UNIT = nulou,FMT = *) & 00386 ' --------- Leaving routine spher2car ---------' 00387 CALL FLUSH (nulou) 00388 ENDIF 00389 00390 END SUBROUTINE spher2car 00391 ! 00392 !----------------------------------------------------------------------- 00393 ! 00394 SUBROUTINE car2spher(rda_grd_lon, rda_grd_lat, id_grd_size, rda_trans, nc_fileid) 00395 00396 INTEGER (KIND=int_kind), INTENT(in) :: 00397 id_grd_size, ! grid size 00398 nc_fileid ! id of open netcdf remapping file 00399 00400 REAL (KIND=dbl_kind), DIMENSION(id_grd_size),INTENT(in) :: 00401 rda_grd_lon, ! grid longitudes 00402 rda_grd_lat ! grid latitudes 00403 00404 ! !RETURN VALUE: 00405 00406 REAL (KIND=dbl_kind), DIMENSION(id_grd_size,3,3), INTENT(out) :: rda_trans 00407 00408 ! Local variables 00409 00410 REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: 00411 rla_sin_lon, rla_cos_lon, ! sinus and cosinu for longitudes 00412 rla_sin_lat, rla_cos_lat ! sinus and cosinu for latitudes 00413 00414 INTEGER(KIND=int_kind) :: dimid_dst, dim3_id, var_id, stat 00415 INTEGER(KIND=int_kind), DIMENSION(3) :: dim_id 00416 00417 ! !DESCRIPTION: 00418 ! Finds the rotation matrix between a cartesien and a spheric referential. 00419 ! 00420 00421 IF (nlogprt .GE. 2) THEN 00422 WRITE (UNIT = nulou,FMT = *) ' ' 00423 WRITE (UNIT = nulou,FMT = *) ' Entering ROUTINE - car2spher' 00424 WRITE (UNIT = nulou,FMT = *) ' ' 00425 CALL FLUSH(nulou) 00426 ENDIF 00427 00428 rla_sin_lon(:) = SIN(rda_grd_lon(:) * rp_deg2rad) 00429 rla_cos_lon(:) = COS(rda_grd_lon(:) * rp_deg2rad) 00430 rla_sin_lat(:) = SIN(rda_grd_lat(:) * rp_deg2rad) 00431 rla_cos_lat(:) = COS(rda_grd_lat(:) * rp_deg2rad) 00432 00433 rda_trans(:,1,1) = -rla_sin_lon(:) 00434 rda_trans(:,1,2) = rla_cos_lon(:) 00435 rda_trans(:,1,3) = 0. 00436 rda_trans(:,2,1) = -rla_sin_lat(:) * rla_cos_lon(:) 00437 rda_trans(:,2,2) = -rla_sin_lat(:) * rla_sin_lon(:) 00438 rda_trans(:,2,3) = rla_cos_lat(:) 00439 rda_trans(:,3,1) = rla_cos_lat(:) * rla_cos_lon(:) 00440 rda_trans(:,3,2) = rla_cos_lat(:) * rla_sin_lon(:) 00441 rda_trans(:,3,3) = rla_sin_lat(:) 00442 00443 ! 00444 !*Write matrix to remapping file 00445 ! 00446 00447 CALL hdlerr(NF_REDEF(nc_fileid), 'car2spher') 00448 00449 CALL hdlerr(NF_INQ_DIMID & 00450 (nc_fileid,'dst_grid_size',dimid_dst), 'car2spher') 00451 00452 stat=NF_INQ_DIMID(nc_fileid,'dim_3',dim3_id) 00453 00454 IF (stat .NE. NF_NOERR) THEN 00455 CALL hdlerr(NF_DEF_DIM & 00456 (nc_fileid,'dim_3',3,dim3_id), 'car2spher') 00457 ENDIF 00458 00459 dim_id(1) = dimid_dst 00460 dim_id(2) = dim3_id 00461 dim_id(3) = dim3_id 00462 00463 CALL hdlerr(NF_DEF_VAR & 00464 (nc_fileid,'Mat_dst_car2sph',NF_DOUBLE,3,dim_id,var_id), 'car2spher') 00465 00466 CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,var_id, 'matrix',& 00467 60,'Transformation matrix for target grid cartesian to spheric'),& 00468 'car2spher') 00469 00470 CALL hdlerr(NF_ENDDEF(nc_fileid), 'car2spher') 00471 00472 CALL hdlerr(NF_PUT_VAR_DOUBLE & 00473 (nc_fileid,var_id,rda_trans),'car2spher') 00474 00475 00476 IF (nlogprt .GE. 2) THEN 00477 WRITE (UNIT = nulou,FMT = *) ' ' 00478 WRITE (UNIT = nulou,FMT = *) & 00479 ' --------- Leaving routine car2spher ---------' 00480 CALL FLUSH (nulou) 00481 ENDIF 00482 00483 END SUBROUTINE car2spher 00484 00485 00486 00487 END MODULE rotations
1.7.4 
