- Timestamp:
- 2017-12-13T15:58:53+01:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r8698 r9019 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 : jpl 36 #elif defined key_lim2 37 USE par_ice_2 36 USE ice , ONLY : jpl 38 37 #endif 39 38 USE domngb ! ocean space and time domain … … 82 81 83 82 !!---------------------------------------------------------------------- 84 !! NEMO/OPA 3.3 , NEMO Consortium (2010)83 !! NEMO/OPA 4.0 , NEMO Consortium (2017) 85 84 !! $Id$ 86 85 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 87 86 !!---------------------------------------------------------------------- 88 89 87 CONTAINS 90 88 … … 97 95 !!---------------------------------------------------------------------- 98 96 CHARACTER(len=*), INTENT(in) :: cdname 97 ! 99 98 #if defined key_iomput 100 99 ! 101 100 TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) 102 101 TYPE(xios_date) :: start_date … … 106 105 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 107 106 !!---------------------------------------------------------------------- 108 107 ! 109 108 ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) ) 110 109 ! 111 110 clname = cdname 112 111 IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) … … 127 126 ! horizontal grid definition 128 127 CALL set_scalar 129 128 ! 130 129 IF( TRIM(cdname) == TRIM(cxios_context) ) THEN 131 130 CALL set_grid( "T", glamt, gphit ) … … 146 145 ENDIF 147 146 ENDIF 148 147 ! 149 148 IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN 150 149 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain … … 169 168 ENDIF 170 169 ENDIF 171 170 ! 172 171 ! vertical grid definition 173 172 CALL iom_set_axis_attr( "deptht", gdept_1d ) … … 175 174 CALL iom_set_axis_attr( "depthv", gdept_1d ) 176 175 CALL iom_set_axis_attr( "depthw", gdepw_1d ) 177 176 ! 178 177 ! Add vertical grid bounds 179 178 jkmin = MIN(2,jpk) ! in case jpk=1 (i.e. sas2D) … … 188 187 CALL iom_set_axis_attr( "depthv", bounds=zt_bnds ) 189 188 CALL iom_set_axis_attr( "depthw", bounds=zw_bnds ) 190 191 189 ! 192 190 # if defined key_floats 193 191 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 194 192 # endif 195 # if defined key_lim3 || defined key_lim2193 # if defined key_lim3 196 194 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 197 #endif 195 ! SIMIP diagnostics (4 main arctic straits) 196 CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 197 # 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 207 CALL xios_set_timestep( dtime)207 CALL xios_set_timestep( dtime ) 208 208 CALL xios_close_context_definition() 209 210 CALL xios_update_calendar(0) 211 209 CALL xios_update_calendar( 0 ) 210 ! 212 211 DEALLOCATE( zt_bnds, zw_bnds ) 213 212 ! 214 213 #endif 215 214 ! 216 215 END SUBROUTINE iom_init 217 216 … … 239 238 240 239 241 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof )240 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof, kdlev ) 242 241 !!--------------------------------------------------------------------- 243 242 !! *** SUBROUTINE iom_open *** … … 252 251 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 253 252 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 254 253 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels 254 ! 255 255 CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] 256 256 CHARACTER(LEN=256) :: cltmpn ! tempory name to store clname (in writting mode) … … 405 405 IF( istop == nstop ) THEN ! no error within this routine 406 406 SELECT CASE (iolib) 407 CASE (jpnf90 ) ; CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar )407 CASE (jpnf90 ) ; CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev ) 408 408 CASE DEFAULT 409 409 CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed) ' ) … … 644 644 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 645 645 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 646 647 648 646 ! ! look for and use a file attribute 647 ! ! called open_ocean_jstart to set the start 648 ! ! value for the 2nd dimension (netcdf only) 649 649 ! 650 650 LOGICAL :: llnoov ! local definition to read overlap … … 672 672 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 673 673 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 674 INTEGER :: inlev ! number of levels for 3D data 674 675 !--------------------------------------------------------------------- 675 676 ! 677 inlev = -1 678 IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) 676 679 clname = iom_file(kiomid)%name ! esier to read 677 680 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) … … 775 778 776 779 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 777 istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 780 istart(1:idmspc) = kstart(1:idmspc) 781 icnt (1:idmspc) = kcount(1:idmspc) 778 782 ELSE 779 783 IF(idom == jpdom_unknown ) THEN … … 801 805 ENDIF 802 806 IF( PRESENT(pv_r3d) ) THEN 803 IF( idom == jpdom_data ) THEN ; icnt(3) = jpkglo804 ELSE IF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3);icnt(3) = kcount(3)805 ELSE ; icnt(3) = jpk807 IF( idom == jpdom_data ) THEN ; icnt(3) = inlev 808 ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3) 809 ELSE ; icnt(3) = inlev 806 810 ENDIF 807 811 ENDIF … … 886 890 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 887 891 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 888 IF( icnt(3) == jpk) THEN892 IF( icnt(3) == inlev ) THEN 889 893 CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) 890 894 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) … … 1135 1139 END SUBROUTINE iom_rp0d 1136 1140 1141 1137 1142 SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1138 1143 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1155 1160 END SUBROUTINE iom_rp1d 1156 1161 1162 1157 1163 SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1158 1164 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1175 1181 END SUBROUTINE iom_rp2d 1176 1182 1183 1177 1184 SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1178 1185 INTEGER , INTENT(in) :: kt ! ocean time-step … … 1236 1243 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1237 1244 #if defined key_iomput 1238 CALL xios_send_field( cdname, pfield3d)1245 CALL xios_send_field( cdname, pfield3d ) 1239 1246 #else 1240 1247 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1241 1248 #endif 1242 1249 END SUBROUTINE iom_p3d 1250 1251 #if defined key_iomput 1243 1252 !!---------------------------------------------------------------------- 1244 1245 #if defined key_iomput 1253 !! 'key_iomput' IOM interface 1254 !!---------------------------------------------------------------------- 1246 1255 1247 1256 SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, & 1248 1257 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & 1249 1258 & nvertex, bounds_lon, bounds_lat, area ) 1250 CHARACTER(LEN=*) , INTENT(in) :: cdid 1251 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1252 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1253 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1254 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1255 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1256 LOGICAL, DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1257 1258 1259 IF ( xios_is_valid_domain (cdid) ) THEN 1259 !!---------------------------------------------------------------------- 1260 !!---------------------------------------------------------------------- 1261 CHARACTER(LEN=*) , INTENT(in) :: cdid 1262 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1263 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1264 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1265 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1266 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1267 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1268 !!---------------------------------------------------------------------- 1269 ! 1270 IF( xios_is_valid_domain (cdid) ) THEN 1260 1271 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1261 1272 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & … … 1263 1274 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 1264 1275 ENDIF 1265 IF 1276 IF( xios_is_valid_domaingroup(cdid) ) THEN 1266 1277 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1267 1278 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & … … 1269 1280 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 1270 1281 ENDIF 1271 1282 ! 1272 1283 CALL xios_solve_inheritance() 1273 1284 ! 1274 1285 END SUBROUTINE iom_set_domain_attr 1275 1286 1276 1287 1277 SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 1278 CHARACTER(LEN=*) , INTENT(in) :: cdid 1279 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1280 1281 IF ( xios_is_valid_zoom_domain (cdid) ) THEN 1282 CALL xios_set_zoom_domain_attr ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, & 1283 & nj=nj) 1284 ENDIF 1288 SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj ) 1289 !!---------------------------------------------------------------------- 1290 !!---------------------------------------------------------------------- 1291 CHARACTER(LEN=*) , INTENT(in) :: cdid 1292 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1293 !!---------------------------------------------------------------------- 1294 IF( xios_is_valid_zoom_domain(cdid) ) CALL xios_set_zoom_domain_attr( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj ) 1285 1295 END SUBROUTINE iom_set_zoom_domain_attr 1286 1296 1287 1297 1288 1298 SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 1299 !!---------------------------------------------------------------------- 1300 !!---------------------------------------------------------------------- 1289 1301 CHARACTER(LEN=*) , INTENT(in) :: cdid 1290 1302 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis 1291 1303 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds 1292 1293 IF 1294 IF 1295 IF 1296 ENDIF 1297 IF 1298 IF 1304 !!---------------------------------------------------------------------- 1305 IF( PRESENT(paxis) ) THEN 1306 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1307 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1308 ENDIF 1309 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1310 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 1299 1311 CALL xios_solve_inheritance() 1300 1312 END SUBROUTINE iom_set_axis_attr … … 1302 1314 1303 1315 SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 1304 CHARACTER(LEN=*) , INTENT(in) :: cdid 1305 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_op 1306 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_offset 1307 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr & 1308 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1309 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr & 1310 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1316 !!---------------------------------------------------------------------- 1317 !!---------------------------------------------------------------------- 1318 CHARACTER(LEN=*) , INTENT(in) :: cdid 1319 TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_op 1320 TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_offset 1321 !!---------------------------------------------------------------------- 1322 IF( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1323 IF( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1311 1324 CALL xios_solve_inheritance() 1312 1325 END SUBROUTINE iom_set_field_attr … … 1314 1327 1315 1328 SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 1329 !!---------------------------------------------------------------------- 1330 !!---------------------------------------------------------------------- 1316 1331 CHARACTER(LEN=*) , INTENT(in) :: cdid 1317 1332 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: name, name_suffix 1318 IF ( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) 1319 IF ( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) 1333 !!---------------------------------------------------------------------- 1334 IF( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) 1335 IF( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) 1320 1336 CALL xios_solve_inheritance() 1321 1337 END SUBROUTINE iom_set_file_attr … … 1323 1339 1324 1340 SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 1341 !!---------------------------------------------------------------------- 1342 !!---------------------------------------------------------------------- 1325 1343 CHARACTER(LEN=*) , INTENT(in ) :: cdid 1326 1344 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix … … 1331 1349 IF( PRESENT( name_suffix ) ) name_suffix = '' 1332 1350 IF( PRESENT( output_freq ) ) output_freq = xios_duration(0,0,0,0,0,0) 1333 IF 1351 IF( xios_is_valid_file (cdid) ) THEN 1334 1352 CALL xios_solve_inheritance() 1335 1353 CALL xios_is_defined_file_attr ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) … … 1338 1356 IF(llexist3) CALL xios_get_file_attr ( cdid, output_freq = output_freq ) 1339 1357 ENDIF 1340 IF 1358 IF( xios_is_valid_filegroup(cdid) ) THEN 1341 1359 CALL xios_solve_inheritance() 1342 1360 CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) … … 1349 1367 1350 1368 SUBROUTINE iom_set_grid_attr( cdid, mask ) 1369 !!---------------------------------------------------------------------- 1370 !!---------------------------------------------------------------------- 1351 1371 CHARACTER(LEN=*) , INTENT(in) :: cdid 1352 1372 LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask 1353 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1354 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1373 !!---------------------------------------------------------------------- 1374 IF( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1375 IF( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1355 1376 CALL xios_solve_inheritance() 1356 1377 END SUBROUTINE iom_set_grid_attr 1357 1378 1358 1379 SUBROUTINE iom_setkt( kt, cdname ) 1380 !!---------------------------------------------------------------------- 1381 !!---------------------------------------------------------------------- 1359 1382 INTEGER , INTENT(in) :: kt 1360 1383 CHARACTER(LEN=*), INTENT(in) :: cdname 1361 ! 1384 !!---------------------------------------------------------------------- 1362 1385 CALL iom_swap( cdname ) ! swap to cdname context 1363 1386 CALL xios_update_calendar(kt) 1364 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1365 ! 1387 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1366 1388 END SUBROUTINE iom_setkt 1367 1389 1368 1390 SUBROUTINE iom_context_finalize( cdname ) 1391 !!---------------------------------------------------------------------- 1392 !!---------------------------------------------------------------------- 1369 1393 CHARACTER(LEN=*), INTENT(in) :: cdname 1370 ! 1394 !!---------------------------------------------------------------------- 1371 1395 IF( xios_is_valid_context(cdname) ) THEN 1372 1396 CALL iom_swap( cdname ) ! swap to cdname context … … 1374 1398 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1375 1399 ENDIF 1376 !1377 1400 END SUBROUTINE iom_context_finalize 1378 1401 … … 1383 1406 !! 1384 1407 !! ** Purpose : define horizontal grids 1385 !!1386 1408 !!---------------------------------------------------------------------- 1387 1409 CHARACTER(LEN=1) , INTENT(in) :: cdgrd … … 1389 1411 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1390 1412 ! 1413 INTEGER :: ni, nj 1391 1414 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask 1392 INTEGER :: ni,nj 1393 1394 ni=nlei-nldi+1 ; nj=nlej-nldj+1 1395 1415 !!---------------------------------------------------------------------- 1416 ! 1417 ni = nlei-nldi+1 1418 nj = nlej-nldj+1 1419 ! 1396 1420 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) 1397 1421 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1398 1422 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), & 1399 1423 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1400 1424 ! 1401 1425 IF ( ln_mskland ) THEN 1402 1426 ! mask land points, keep values on coast line -> specific mask for U, V and W points … … 1411 1435 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 1412 1436 ENDIF 1413 1437 ! 1414 1438 END SUBROUTINE set_grid 1415 1439 … … 1422 1446 !! 1423 1447 !!---------------------------------------------------------------------- 1424 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1425 ! 1426 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 1427 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coordinates of the point of cell (i,j) 1428 ! 1429 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1430 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1431 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1432 ! 1433 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1434 ! ! represents the bottom-left corner of cell (i,j) 1448 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1449 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coord. of a contiguous vertex of cell (i,j) 1450 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) 1451 ! 1435 1452 INTEGER :: ji, jj, jn, ni, nj 1436 1453 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1454 ! ! represents the bottom-left corner of cell (i,j) 1455 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1456 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1457 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1458 !!---------------------------------------------------------------------- 1459 ! 1437 1460 ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) 1438 1461 ! 1439 1462 ! Offset of coordinate representing bottom-left corner 1440 1463 SELECT CASE ( TRIM(cdgrd) ) 1441 CASE ('T', 'W') 1442 icnr = -1 ; jcnr = -1 1443 CASE ('U') 1444 icnr = 0 ; jcnr = -1 1445 CASE ('V') 1446 icnr = -1 ; jcnr = 0 1464 CASE ('T', 'W') ; icnr = -1 ; jcnr = -1 1465 CASE ('U') ; icnr = 0 ; jcnr = -1 1466 CASE ('V') ; icnr = -1 ; jcnr = 0 1447 1467 END SELECT 1448 1449 ni = nlei-nldi+1 ; nj = nlej-nldj+1 ! Dimensions of subdomain interior 1450 1468 ! 1469 ni = nlei-nldi+1 ! Dimensions of subdomain interior 1470 nj = nlej-nldj+1 1471 ! 1451 1472 z_fld(:,:) = 1._wp 1452 1473 CALL lbc_lnk( z_fld, cdgrd, -1. ) ! Working array for location of northfold 1453 1474 ! 1454 1475 ! Cell vertices that can be defined 1455 1476 DO jj = 2, jpjm1 … … 1465 1486 END DO 1466 1487 END DO 1467 1488 ! 1468 1489 ! Cell vertices on boundries 1469 1490 DO jn = 1, 4 … … 1471 1492 CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 1472 1493 END DO 1473 1494 ! 1474 1495 ! Zero-size cells at closed boundaries if cell points provided, 1475 1496 ! otherwise they are closed cells with unrealistic bounds … … 1496 1517 ENDIF 1497 1518 ENDIF 1498 1499 ! Rotate cells at the north fold 1500 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 1501 1521 DO jj = 1, jpj 1502 1522 DO ji = 1, jpi … … 1508 1528 END DO 1509 1529 END DO 1510 1511 ! Invert cells at the symmetric equator 1512 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 1530 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator 1513 1531 DO ji = 1, jpi 1514 1532 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) … … 1517 1535 END DO 1518 1536 ENDIF 1519 1537 ! 1520 1538 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 1521 1522 1539 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 1540 ! 1523 1541 DEALLOCATE( z_bnds, z_fld, z_rot ) 1524 1542 ! 1525 1543 END SUBROUTINE set_grid_bounds 1526 1544 … … 1535 1553 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1536 1554 ! 1555 INTEGER :: ni, nj, ix, iy 1537 1556 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 1538 INTEGER :: ni,nj, ix, iy1539 1540 1541 n i=nlei-nldi+1 ; nj=nlej-nldj+1 ! define zonal mean domain (jpj*jpk)1542 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0. 1543 1557 !!---------------------------------------------------------------------- 1558 ! 1559 ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk) 1560 nj=nlej-nldj+1 1561 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 1562 ! 1544 1563 CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 1564 ! CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1545 1565 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1546 1566 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) … … 1553 1573 END SUBROUTINE set_grid_znl 1554 1574 1575 1555 1576 SUBROUTINE set_scalar 1556 1577 !!---------------------------------------------------------------------- … … 1562 1583 REAL(wp), DIMENSION(1) :: zz = 1. 1563 1584 !!---------------------------------------------------------------------- 1564 1585 ! 1565 1586 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 1566 1587 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1567 1568 zz =REAL(narea,wp)1588 ! 1589 zz = REAL( narea, wp ) 1569 1590 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 1570 1591 ! 1571 1592 END SUBROUTINE set_scalar 1572 1593 … … 1596 1617 ! 1597 1618 ! frequency of the call of iom_put (attribut: freq_op) 1598 f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of)1599 f_op%timestep = 2 ; f_of%timestep = 0 ; CALL iom_set_field_attr('trendT_even' , freq_op=f_op, freq_offset=f_of)1600 f_op%timestep = 2 ; f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd' , freq_op=f_op, freq_offset=f_of)1601 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of)1602 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of)1603 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ptrc_T' , freq_op=f_op, freq_offset=f_of)1604 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('diad_T' , freq_op=f_op, freq_offset=f_of)1619 f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 1620 f_op%timestep = 2 ; f_of%timestep = 0 ; CALL iom_set_field_attr('trendT_even' , freq_op=f_op, freq_offset=f_of) 1621 f_op%timestep = 2 ; f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd' , freq_op=f_op, freq_offset=f_of) 1622 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) 1623 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) 1624 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ptrc_T' , freq_op=f_op, freq_offset=f_of) 1625 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('diad_T' , freq_op=f_op, freq_offset=f_of) 1605 1626 1606 1627 ! output file names (attribut: name) … … 1641 1662 zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 1642 1663 CALL set_mooring( zlonpira, zlatpira ) 1643 1644 1664 ! 1645 1665 END SUBROUTINE set_xmlatt 1646 1666 1647 1667 1648 SUBROUTINE set_mooring( plon, plat )1668 SUBROUTINE set_mooring( plon, plat ) 1649 1669 !!---------------------------------------------------------------------- 1650 1670 !! *** ROUTINE set_mooring *** … … 1653 1673 !! 1654 1674 !!---------------------------------------------------------------------- 1655 REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat! longitudes/latitudes oft the mooring1675 REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat ! longitudes/latitudes oft the mooring 1656 1676 ! 1657 1677 !!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name … … 1736 1756 TYPE(xios_duration) :: output_freq 1737 1757 !!---------------------------------------------------------------------- 1738 1739 DO jn = 1, 21740 1758 ! 1759 DO jn = 1, 2 1760 ! 1741 1761 output_freq = xios_duration(0,0,0,0,0,0) 1742 1762 IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = output_freq ) 1743 1763 IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) 1744 1764 ! 1745 1765 IF ( TRIM(clname) /= '' ) THEN 1746 1766 ! 1747 1767 idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') 1748 1768 DO WHILE ( idx /= 0 ) … … 1750 1770 idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') 1751 1771 END DO 1752 1772 ! 1753 1773 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1754 1774 DO WHILE ( idx /= 0 ) … … 1781 1801 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1782 1802 END DO 1783 1803 ! 1784 1804 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 1785 1805 DO WHILE ( idx /= 0 ) … … 1788 1808 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 1789 1809 END DO 1790 1810 ! 1791 1811 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') 1792 1812 DO WHILE ( idx /= 0 ) … … 1795 1815 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') 1796 1816 END DO 1797 1817 ! 1798 1818 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 1799 1819 DO WHILE ( idx /= 0 ) … … 1802 1822 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 1803 1823 END DO 1804 1824 ! 1805 1825 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1806 1826 DO WHILE ( idx /= 0 ) … … 1809 1829 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1810 1830 END DO 1811 1831 ! 1812 1832 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 1813 1833 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 1814 1834 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) 1815 1816 ENDIF 1817 1835 ! 1836 ENDIF 1837 ! 1818 1838 END DO 1819 1839 ! 1820 1840 END SUBROUTINE iom_update_file_name 1821 1841 … … 1826 1846 !! 1827 1847 !! ** Purpose : send back the date corresponding to the given julian day 1828 !! 1829 !!---------------------------------------------------------------------- 1830 REAL(wp), INTENT(in ) :: pjday ! julian day 1831 LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 1832 LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss 1848 !!---------------------------------------------------------------------- 1849 REAL(wp), INTENT(in ) :: pjday ! julian day 1850 LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 1851 LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss 1833 1852 ! 1834 1853 CHARACTER(LEN=20) :: iom_sdate … … 1837 1856 REAL(wp) :: zsec 1838 1857 LOGICAL :: ll24, llfull 1858 !!---------------------------------------------------------------------- 1839 1859 ! 1840 1860 IF( PRESENT(ld24) ) THEN ; ll24 = ld24 1841 1861 ELSE ; ll24 = .FALSE. 1842 1862 ENDIF 1843 1863 ! 1844 1864 IF( PRESENT(ldfull) ) THEN ; llfull = ldfull 1845 1865 ELSE ; llfull = .FALSE. 1846 1866 ENDIF 1847 1867 ! 1848 1868 CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) 1849 1869 isec = NINT(zsec) 1850 1870 ! 1851 1871 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 1852 1872 CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec ) 1853 1873 isec = 86400 1854 1874 ENDIF 1855 1875 ! 1856 1876 IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date 1857 1877 ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 1858 1878 ENDIF 1859 1879 ! 1860 1880 !$AGRIF_DO_NOT_TREAT 1861 ! Should be fixed in the conv1881 ! needed in the conv 1862 1882 IF( llfull ) THEN 1863 1883 clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" … … 1871 1891 ENDIF 1872 1892 !$AGRIF_END_DO_NOT_TREAT 1873 1893 ! 1874 1894 END FUNCTION iom_sdate 1875 1895 1876 1896 #else 1877 1897 !!---------------------------------------------------------------------- 1898 !! NOT 'key_iomput' a few dummy routines 1899 !!---------------------------------------------------------------------- 1878 1900 1879 1901 SUBROUTINE iom_setkt( kt, cdname ) … … 1891 1913 1892 1914 LOGICAL FUNCTION iom_use( cdname ) 1915 !!---------------------------------------------------------------------- 1916 !!---------------------------------------------------------------------- 1893 1917 CHARACTER(LEN=*), INTENT(in) :: cdname 1918 !!---------------------------------------------------------------------- 1894 1919 #if defined key_iomput 1895 1920 iom_use = xios_field_is_active( cdname )
Note: See TracChangeset
for help on using the changeset viewer.
