- Timestamp:
- 2017-11-27T12:03:07+01:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r8586 r8817 1 1 MODULE iom 2 !!===================================================================== 2 !!====================================================================== 3 3 !! *** MODULE iom *** 4 4 !! Input/Output manager : Library to read input files 5 !!==================================================================== 5 !!====================================================================== 6 6 !! History : 2.0 ! 2005-12 (J. Belier) Original code 7 7 !! 2.0 ! 2006-02 (S. Masson) Adaptation to NEMO … … 10 10 !! 3.6 ! 2014-15 DIMG format removed 11 11 !! 3.6 ! 2015-15 (J. Harle) Added procedure to read REAL attributes 12 !!-------------------------------------------------------------------- 13 14 !!-------------------------------------------------------------------- 12 !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields 13 !!---------------------------------------------------------------------- 14 15 !!---------------------------------------------------------------------- 15 16 !! iom_open : open a file read only 16 17 !! iom_close : close a file or all files opened by iom … … 19 20 !! iom_varid : get the id of a variable in a file 20 21 !! iom_rstput : write a field in a restart file (interfaced to several routines) 21 !!-------------------------------------------------------------------- 22 !!---------------------------------------------------------------------- 22 23 USE dom_oce ! ocean space and time domain 23 24 USE c1d ! 1D vertical configuration … … 29 30 USE lib_mpp ! MPP library 30 31 #if defined key_iomput 31 USE sbc_oce , ONLY : nn_fsbc ! ocean space and time domain32 USE trc_oce , ONLY : nn_dttrc ! !: frequency of step on passive tracers33 USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes32 USE sbc_oce , ONLY : nn_fsbc ! ocean space and time domain 33 USE trc_oce , ONLY : nn_dttrc ! !: frequency of step on passive tracers 34 USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes 34 35 #if defined key_lim3 35 USE ice , ONLY : jpl36 USE ice , ONLY : jpl 36 37 #endif 37 38 USE domngb ! ocean space and time domain … … 80 81 81 82 !!---------------------------------------------------------------------- 82 !! NEMO/OPA 3.3 , NEMO Consortium (2010)83 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 83 84 !! $Id$ 84 85 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 85 86 !!---------------------------------------------------------------------- 86 87 87 CONTAINS 88 88 … … 95 95 !!---------------------------------------------------------------------- 96 96 CHARACTER(len=*), INTENT(in) :: cdname 97 ! 97 98 #if defined key_iomput 98 99 ! 99 100 TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) 100 101 TYPE(xios_date) :: start_date … … 104 105 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 105 106 !!---------------------------------------------------------------------- 106 107 ! 107 108 ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) ) 108 109 ! 109 110 clname = cdname 110 111 IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) … … 125 126 ! horizontal grid definition 126 127 CALL set_scalar 127 128 ! 128 129 IF( TRIM(cdname) == TRIM(cxios_context) ) THEN 129 130 CALL set_grid( "T", glamt, gphit ) … … 144 145 ENDIF 145 146 ENDIF 146 147 ! 147 148 IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN 148 149 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain … … 167 168 ENDIF 168 169 ENDIF 169 170 ! 170 171 ! vertical grid definition 171 172 CALL iom_set_axis_attr( "deptht", gdept_1d ) … … 173 174 CALL iom_set_axis_attr( "depthv", gdept_1d ) 174 175 CALL iom_set_axis_attr( "depthw", gdepw_1d ) 175 176 ! 176 177 ! Add vertical grid bounds 177 178 jkmin = MIN(2,jpk) ! in case jpk=1 (i.e. sas2D) … … 186 187 CALL iom_set_axis_attr( "depthv", bounds=zt_bnds ) 187 188 CALL iom_set_axis_attr( "depthw", bounds=zw_bnds ) 188 189 189 ! 190 190 # if defined key_floats 191 191 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 192 192 # endif 193 # if defined key_lim3193 # if defined key_lim3 194 194 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 195 195 ! SIMIP diagnostics (4 main arctic straits) 196 196 CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 197 # endif197 # endif 198 198 CALL iom_set_axis_attr( "icbcla", class_num ) 199 199 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) … … 202 202 ! automatic definitions of some of the xml attributs 203 203 CALL set_xmlatt 204 204 ! 205 205 ! end file definition 206 206 dtime%second = rdt … … 209 209 210 210 CALL xios_update_calendar(0) 211 211 ! 212 212 DEALLOCATE( zt_bnds, zw_bnds ) 213 213 ! 214 214 #endif 215 215 ! 216 216 END SUBROUTINE iom_init 217 217 … … 239 239 240 240 241 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof )241 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof, kdlev ) 242 242 !!--------------------------------------------------------------------- 243 243 !! *** SUBROUTINE iom_open *** … … 252 252 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 253 253 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 254 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels 254 255 255 256 CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] … … 405 406 IF( istop == nstop ) THEN ! no error within this routine 406 407 SELECT CASE (iolib) 407 CASE (jpnf90 ) ; CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar )408 CASE (jpnf90 ) ; CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev ) 408 409 CASE DEFAULT 409 410 CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed) ' ) … … 672 673 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 673 674 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 675 INTEGER :: inlev ! number of levels for 3D data 674 676 !--------------------------------------------------------------------- 675 677 ! 678 inlev = -1 679 IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) 676 680 clname = iom_file(kiomid)%name ! esier to read 677 681 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) … … 774 778 istart(idmspc+1) = itime 775 779 776 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 780 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 781 istart(1:idmspc) = kstart(1:idmspc) 782 icnt(1:idmspc) = kcount(1:idmspc) 777 783 ELSE 778 IF( idom == jpdom_unknown ) THEN ; icnt(1:idmspc) = idimsz(1:idmspc) 784 IF(idom == jpdom_unknown ) THEN 785 icnt(1:idmspc) = idimsz(1:idmspc) 779 786 ELSE 780 787 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array … … 799 806 ENDIF 800 807 IF( PRESENT(pv_r3d) ) THEN 801 IF( idom == jpdom_data ) THEN ; icnt(3) = jpkglo808 IF( idom == jpdom_data ) THEN ; icnt(3) = inlev 802 809 ELSE IF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3); icnt(3) = kcount(3) 803 ELSE ; icnt(3) = jpk810 ELSE ; icnt(3) = inlev 804 811 ENDIF 805 812 ENDIF … … 884 891 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 885 892 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 886 IF( icnt(3) == jpk) THEN893 IF( icnt(3) == inlev ) THEN 887 894 CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) 888 895 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) … … 1133 1140 END SUBROUTINE iom_rp0d 1134 1141 1142 1135 1143 SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1136 1144 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1153 1161 END SUBROUTINE iom_rp1d 1154 1162 1163 1155 1164 SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1156 1165 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1173 1182 END SUBROUTINE iom_rp2d 1174 1183 1184 1175 1185 SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1176 1186 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1234 1244 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1235 1245 #if defined key_iomput 1236 CALL xios_send_field( cdname, pfield3d)1246 CALL xios_send_field( cdname, pfield3d ) 1237 1247 #else 1238 1248 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1239 1249 #endif 1240 1250 END SUBROUTINE iom_p3d 1251 1252 #if defined key_iomput 1253 1241 1254 !!---------------------------------------------------------------------- 1242 1243 #if defined key_iomput 1255 !! 'key_iomput' IOM interface 1256 !!---------------------------------------------------------------------- 1244 1257 1245 1258 SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, & 1246 1259 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & 1247 1260 & nvertex, bounds_lon, bounds_lat, area ) 1248 CHARACTER(LEN=*) , INTENT(in) :: cdid 1249 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1250 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1251 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1252 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1253 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1254 LOGICAL, DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1255 1256 1257 IF ( xios_is_valid_domain (cdid) ) THEN 1261 !!---------------------------------------------------------------------- 1262 !!---------------------------------------------------------------------- 1263 CHARACTER(LEN=*) , INTENT(in) :: cdid 1264 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1265 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1266 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1267 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1268 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1269 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1270 !!---------------------------------------------------------------------- 1271 ! 1272 IF( xios_is_valid_domain (cdid) ) THEN 1258 1273 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1259 1274 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & … … 1261 1276 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 1262 1277 ENDIF 1263 IF 1278 IF( xios_is_valid_domaingroup(cdid) ) THEN 1264 1279 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1265 1280 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & … … 1267 1282 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 1268 1283 ENDIF 1269 1284 ! 1270 1285 CALL xios_solve_inheritance() 1271 1286 ! 1272 1287 END SUBROUTINE iom_set_domain_attr 1273 1288 1274 1289 1275 SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 1276 CHARACTER(LEN=*) , INTENT(in) :: cdid 1277 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1278 1279 IF ( xios_is_valid_zoom_domain (cdid) ) THEN 1280 CALL xios_set_zoom_domain_attr ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, & 1281 & nj=nj) 1282 ENDIF 1290 SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj ) 1291 !!---------------------------------------------------------------------- 1292 !!---------------------------------------------------------------------- 1293 CHARACTER(LEN=*) , INTENT(in) :: cdid 1294 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1295 !!---------------------------------------------------------------------- 1296 IF( xios_is_valid_zoom_domain(cdid) ) CALL xios_set_zoom_domain_attr( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj ) 1283 1297 END SUBROUTINE iom_set_zoom_domain_attr 1284 1298 1285 1299 1286 1300 SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 1301 !!---------------------------------------------------------------------- 1302 !!---------------------------------------------------------------------- 1287 1303 CHARACTER(LEN=*) , INTENT(in) :: cdid 1288 1304 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis 1289 1305 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds 1290 1291 IF 1292 IF 1293 IF 1294 ENDIF 1295 IF 1296 IF 1306 !!---------------------------------------------------------------------- 1307 IF( PRESENT(paxis) ) THEN 1308 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1309 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1310 ENDIF 1311 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1312 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 1297 1313 CALL xios_solve_inheritance() 1298 1314 END SUBROUTINE iom_set_axis_attr … … 1300 1316 1301 1317 SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 1302 CHARACTER(LEN=*) , INTENT(in) :: cdid 1303 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_op 1304 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_offset 1305 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr & 1306 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1307 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr & 1308 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1318 !!---------------------------------------------------------------------- 1319 !!---------------------------------------------------------------------- 1320 CHARACTER(LEN=*) , INTENT(in) :: cdid 1321 TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_op 1322 TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_offset 1323 !!---------------------------------------------------------------------- 1324 IF( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1325 IF( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1309 1326 CALL xios_solve_inheritance() 1310 1327 END SUBROUTINE iom_set_field_attr … … 1312 1329 1313 1330 SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 1331 !!---------------------------------------------------------------------- 1332 !!---------------------------------------------------------------------- 1314 1333 CHARACTER(LEN=*) , INTENT(in) :: cdid 1315 1334 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: name, name_suffix 1316 IF ( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) 1317 IF ( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) 1335 !!---------------------------------------------------------------------- 1336 IF( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) 1337 IF( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) 1318 1338 CALL xios_solve_inheritance() 1319 1339 END SUBROUTINE iom_set_file_attr … … 1321 1341 1322 1342 SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 1343 !!---------------------------------------------------------------------- 1344 !!---------------------------------------------------------------------- 1323 1345 CHARACTER(LEN=*) , INTENT(in ) :: cdid 1324 1346 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix … … 1329 1351 IF( PRESENT( name_suffix ) ) name_suffix = '' 1330 1352 IF( PRESENT( output_freq ) ) output_freq = xios_duration(0,0,0,0,0,0) 1331 IF 1353 IF( xios_is_valid_file (cdid) ) THEN 1332 1354 CALL xios_solve_inheritance() 1333 1355 CALL xios_is_defined_file_attr ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) … … 1336 1358 IF(llexist3) CALL xios_get_file_attr ( cdid, output_freq = output_freq ) 1337 1359 ENDIF 1338 IF 1360 IF( xios_is_valid_filegroup(cdid) ) THEN 1339 1361 CALL xios_solve_inheritance() 1340 1362 CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) … … 1347 1369 1348 1370 SUBROUTINE iom_set_grid_attr( cdid, mask ) 1371 !!---------------------------------------------------------------------- 1372 !!---------------------------------------------------------------------- 1349 1373 CHARACTER(LEN=*) , INTENT(in) :: cdid 1350 1374 LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask 1351 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1352 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1375 !!---------------------------------------------------------------------- 1376 IF( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1377 IF( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1353 1378 CALL xios_solve_inheritance() 1354 1379 END SUBROUTINE iom_set_grid_attr 1355 1380 1356 1381 SUBROUTINE iom_setkt( kt, cdname ) 1382 !!---------------------------------------------------------------------- 1383 !!---------------------------------------------------------------------- 1357 1384 INTEGER , INTENT(in) :: kt 1358 1385 CHARACTER(LEN=*), INTENT(in) :: cdname 1359 ! 1386 !!---------------------------------------------------------------------- 1360 1387 CALL iom_swap( cdname ) ! swap to cdname context 1361 1388 CALL xios_update_calendar(kt) 1362 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1363 ! 1389 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1364 1390 END SUBROUTINE iom_setkt 1365 1391 1366 1392 SUBROUTINE iom_context_finalize( cdname ) 1393 !!---------------------------------------------------------------------- 1394 !!---------------------------------------------------------------------- 1367 1395 CHARACTER(LEN=*), INTENT(in) :: cdname 1368 ! 1396 !!---------------------------------------------------------------------- 1369 1397 IF( xios_is_valid_context(cdname) ) THEN 1370 1398 CALL iom_swap( cdname ) ! swap to cdname context … … 1372 1400 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1373 1401 ENDIF 1374 !1375 1402 END SUBROUTINE iom_context_finalize 1376 1403 … … 1381 1408 !! 1382 1409 !! ** Purpose : define horizontal grids 1383 !!1384 1410 !!---------------------------------------------------------------------- 1385 1411 CHARACTER(LEN=1) , INTENT(in) :: cdgrd … … 1387 1413 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1388 1414 ! 1415 INTEGER :: ni,nj 1389 1416 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask 1390 INTEGER :: ni,nj1391 1417 !!---------------------------------------------------------------------- 1418 ! 1392 1419 ni=nlei-nldi+1 ; nj=nlej-nldj+1 1393 1420 ! 1394 1421 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1395 1422 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1396 1423 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), & 1397 1424 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1398 1425 ! 1399 1426 IF ( ln_mskland ) THEN 1400 1427 ! mask land points, keep values on coast line -> specific mask for U, V and W points … … 1409 1436 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 1410 1437 ENDIF 1411 1438 ! 1412 1439 END SUBROUTINE set_grid 1413 1440 … … 1420 1447 !! 1421 1448 !!---------------------------------------------------------------------- 1422 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1423 ! 1424 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 1425 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coordinates of the point of cell (i,j) 1426 ! 1427 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1428 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1429 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1430 ! 1431 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1432 ! ! represents the bottom-left corner of cell (i,j) 1449 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1450 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coord. of a contiguous vertex of cell (i,j) 1451 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) 1452 ! 1433 1453 INTEGER :: ji, jj, jn, ni, nj 1434 1454 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1455 ! ! represents the bottom-left corner of cell (i,j) 1456 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1457 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1458 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1459 !!---------------------------------------------------------------------- 1460 ! 1435 1461 ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) 1436 1462 ! 1437 1463 ! Offset of coordinate representing bottom-left corner 1438 1464 SELECT CASE ( TRIM(cdgrd) ) 1439 CASE ('T', 'W') 1440 icnr = -1 ; jcnr = -1 1441 CASE ('U') 1442 icnr = 0 ; jcnr = -1 1443 CASE ('V') 1444 icnr = -1 ; jcnr = 0 1465 CASE ('T', 'W') ; icnr = -1 ; jcnr = -1 1466 CASE ('U') ; icnr = 0 ; jcnr = -1 1467 CASE ('V') ; icnr = -1 ; jcnr = 0 1445 1468 END SELECT 1446 1469 ! 1447 1470 ni = nlei-nldi+1 ; nj = nlej-nldj+1 ! Dimensions of subdomain interior 1448 1471 ! 1449 1472 z_fld(:,:) = 1._wp 1450 1473 CALL lbc_lnk( z_fld, cdgrd, -1. ) ! Working array for location of northfold 1451 1474 ! 1452 1475 ! Cell vertices that can be defined 1453 1476 DO jj = 2, jpjm1 … … 1463 1486 END DO 1464 1487 END DO 1465 1488 ! 1466 1489 ! Cell vertices on boundries 1467 1490 DO jn = 1, 4 … … 1469 1492 CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 1470 1493 END DO 1471 1494 ! 1472 1495 ! Zero-size cells at closed boundaries if cell points provided, 1473 1496 ! otherwise they are closed cells with unrealistic bounds … … 1494 1517 ENDIF 1495 1518 ENDIF 1496 1497 ! Rotate cells at the north fold 1498 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN 1519 ! 1520 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold 1499 1521 DO jj = 1, jpj 1500 1522 DO ji = 1, jpi … … 1506 1528 END DO 1507 1529 END DO 1508 1509 ! Invert cells at the symmetric equator 1510 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 1530 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator 1511 1531 DO ji = 1, jpi 1512 1532 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) … … 1515 1535 END DO 1516 1536 ENDIF 1517 1537 ! 1518 1538 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 1519 1520 1539 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 1540 ! 1521 1541 DEALLOCATE( z_bnds, z_fld, z_rot ) 1522 1542 ! 1523 1543 END SUBROUTINE set_grid_bounds 1524 1544 … … 1535 1555 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 1536 1556 INTEGER :: ni,nj, ix, iy 1537 1538 1557 !!---------------------------------------------------------------------- 1558 ! 1539 1559 ni=nlei-nldi+1 ; nj=nlej-nldj+1 ! define zonal mean domain (jpj*jpk) 1540 1560 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0. 1541 1542 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1561 ! 1562 CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 1563 ! CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1543 1564 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1544 1565 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) … … 1551 1572 END SUBROUTINE set_grid_znl 1552 1573 1574 1553 1575 SUBROUTINE set_scalar 1554 1576 !!---------------------------------------------------------------------- … … 1560 1582 REAL(wp), DIMENSION(1) :: zz = 1. 1561 1583 !!---------------------------------------------------------------------- 1562 1584 ! 1563 1585 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 1564 1586 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1565 1566 zz =REAL(narea,wp)1587 ! 1588 zz = REAL( narea, wp ) 1567 1589 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 1568 1590 ! 1569 1591 END SUBROUTINE set_scalar 1570 1592 … … 1637 1659 zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 1638 1660 CALL set_mooring( zlonpira, zlatpira ) 1639 1640 1661 ! 1641 1662 END SUBROUTINE set_xmlatt 1642 1663 1643 1664 1644 SUBROUTINE set_mooring( plon, plat )1665 SUBROUTINE set_mooring( plon, plat ) 1645 1666 !!---------------------------------------------------------------------- 1646 1667 !! *** ROUTINE set_mooring *** … … 1649 1670 !! 1650 1671 !!---------------------------------------------------------------------- 1651 REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat! longitudes/latitudes oft the mooring1672 REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat ! longitudes/latitudes oft the mooring 1652 1673 ! 1653 1674 !!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name … … 1798 1819 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 1799 1820 END DO 1800 1821 ! 1801 1822 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1802 1823 DO WHILE ( idx /= 0 ) … … 1805 1826 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1806 1827 END DO 1807 1828 ! 1808 1829 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 1809 1830 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 1810 1831 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) 1811 1812 ENDIF 1813 1832 ! 1833 ENDIF 1834 ! 1814 1835 END DO 1815 1836 ! 1816 1837 END SUBROUTINE iom_update_file_name 1817 1838 … … 1822 1843 !! 1823 1844 !! ** Purpose : send back the date corresponding to the given julian day 1824 !!1825 1845 !!---------------------------------------------------------------------- 1826 1846 REAL(wp), INTENT(in ) :: pjday ! julian day … … 1833 1853 REAL(wp) :: zsec 1834 1854 LOGICAL :: ll24, llfull 1855 !!---------------------------------------------------------------------- 1835 1856 ! 1836 1857 IF( PRESENT(ld24) ) THEN ; ll24 = ld24 1837 1858 ELSE ; ll24 = .FALSE. 1838 1859 ENDIF 1839 1860 ! 1840 1861 IF( PRESENT(ldfull) ) THEN ; llfull = ldfull 1841 1862 ELSE ; llfull = .FALSE. 1842 1863 ENDIF 1843 1864 ! 1844 1865 CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) 1845 1866 isec = NINT(zsec) 1846 1867 ! 1847 1868 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 1848 1869 CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec ) 1849 1870 isec = 86400 1850 1871 ENDIF 1851 1872 ! 1852 1873 IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date 1853 1874 ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 1854 1875 ENDIF 1855 1876 ! 1856 1877 !$AGRIF_DO_NOT_TREAT 1857 ! Should be fixed in the conv1878 ! needed in the conv 1858 1879 IF( llfull ) THEN 1859 1880 clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" … … 1867 1888 ENDIF 1868 1889 !$AGRIF_END_DO_NOT_TREAT 1869 1890 ! 1870 1891 END FUNCTION iom_sdate 1871 1892 1872 1893 #else 1873 1874 1894 1875 1895 SUBROUTINE iom_setkt( kt, cdname )
Note: See TracChangeset
for help on using the changeset viewer.
