Changeset 5837 for branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
- Timestamp:
- 2015-10-26T15:59:39+01:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r4650 r5837 32 32 USE trc_oce, ONLY : nn_dttrc ! !: frequency of step on passive tracers 33 33 USE icb_oce, ONLY : nclasses, class_num ! !: iceberg classes 34 #if defined key_lim3 35 USE ice , ONLY : jpl 36 #elif defined key_lim2 37 USE par_ice_2 38 #endif 34 39 USE domngb ! ocean space and time domain 35 40 USE phycst ! physical constants … … 49 54 #endif 50 55 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_gettime, iom_rstput, iom_put 51 PUBLIC iom_getatt, iom_ context_finalize56 PUBLIC iom_getatt, iom_use, iom_context_finalize 52 57 53 58 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d … … 56 61 #if defined key_iomput 57 62 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 58 PRIVATE set_grid, set_ scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate63 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 59 64 # endif 60 65 … … 93 98 CHARACTER(len=10) :: clname 94 99 INTEGER :: ji 95 !!---------------------------------------------------------------------- 100 ! 101 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 102 !!---------------------------------------------------------------------- 103 104 ALLOCATE( z_bnds(jpk,2) ) 96 105 97 106 clname = cdname 98 107 IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) 99 # if defined key_mpp_mpi100 108 CALL xios_context_initialize(TRIM(clname), mpi_comm_opa) 101 # else102 CALL xios_context_initialize(TRIM(clname), 0)103 # endif104 109 CALL iom_swap( cdname ) 105 110 … … 116 121 CALL set_scalar 117 122 118 IF( TRIM(cdname) == "nemo") THEN123 IF( TRIM(cdname) == TRIM(cxios_context) ) THEN 119 124 CALL set_grid( "T", glamt, gphit ) 120 125 CALL set_grid( "U", glamu, gphiu ) 121 126 CALL set_grid( "V", glamv, gphiv ) 122 127 CALL set_grid( "W", glamt, gphit ) 123 ENDIF 124 125 IF( TRIM(cdname) == "nemo_crs" ) THEN 128 CALL set_grid_znl( gphit ) 129 ! 130 IF( ln_cfmeta ) THEN ! Add additional grid metadata 131 CALL iom_set_domain_attr("grid_T", area = e12t(nldi:nlei, nldj:nlej)) 132 CALL iom_set_domain_attr("grid_U", area = e12u(nldi:nlei, nldj:nlej)) 133 CALL iom_set_domain_attr("grid_V", area = e12v(nldi:nlei, nldj:nlej)) 134 CALL iom_set_domain_attr("grid_W", area = e12t(nldi:nlei, nldj:nlej)) 135 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 136 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 137 CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 138 CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 139 ENDIF 140 ENDIF 141 142 IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN 126 143 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 127 144 ! … … 130 147 CALL set_grid( "V", glamv_crs, gphiv_crs ) 131 148 CALL set_grid( "W", glamt_crs, gphit_crs ) 149 CALL set_grid_znl( gphit_crs ) 132 150 ! 133 151 CALL dom_grid_glo ! Return to parent grid domain 134 ENDIF 135 152 ! 153 IF( ln_cfmeta ) THEN ! Add additional grid metadata 154 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 155 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) 156 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) 157 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 158 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 159 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) 160 CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) 161 CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 162 ENDIF 163 ENDIF 136 164 137 165 ! vertical grid definition … … 140 168 CALL iom_set_axis_attr( "depthv", gdept_1d ) 141 169 CALL iom_set_axis_attr( "depthw", gdepw_1d ) 170 171 ! Add vertical grid bounds 172 z_bnds(: ,1) = gdepw_1d(:) 173 z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 174 z_bnds(jpk: ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 175 CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 176 CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 177 CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 178 z_bnds(: ,2) = gdept_1d(:) 179 z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 180 z_bnds(1 ,1) = gdept_1d(1) - e3w_1d(1) 181 CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 182 142 183 # if defined key_floats 143 184 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 144 185 # endif 186 #if defined key_lim3 || defined key_lim2 187 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 188 #endif 145 189 CALL iom_set_axis_attr( "icbcla", class_num ) 190 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 191 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 146 192 147 193 ! automatic definitions of some of the xml attributs … … 154 200 155 201 CALL xios_update_calendar(0) 202 203 DEALLOCATE( z_bnds ) 204 156 205 #endif 157 206 … … 535 584 END SUBROUTINE iom_g1d 536 585 537 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )586 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 538 587 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 539 588 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 543 592 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 544 593 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 594 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 595 ! look for and use a file attribute 596 ! called open_ocean_jstart to set the start 597 ! value for the 2nd dimension (netcdf only) 545 598 ! 546 599 IF( kiomid > 0 ) THEN 547 600 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 548 & ktime=ktime, kstart=kstart, kcount=kcount ) 601 & ktime=ktime, kstart=kstart, kcount=kcount, & 602 & lrowattr=lrowattr ) 549 603 ENDIF 550 604 END SUBROUTINE iom_g2d 551 605 552 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )606 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 553 607 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 554 608 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 558 612 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 559 613 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 614 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 615 ! look for and use a file attribute 616 ! called open_ocean_jstart to set the start 617 ! value for the 2nd dimension (netcdf only) 560 618 ! 561 619 IF( kiomid > 0 ) THEN 562 620 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 563 & ktime=ktime, kstart=kstart, kcount=kcount ) 621 & ktime=ktime, kstart=kstart, kcount=kcount, & 622 & lrowattr=lrowattr ) 564 623 ENDIF 565 624 END SUBROUTINE iom_g3d … … 568 627 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 569 628 & pv_r1d, pv_r2d, pv_r3d, & 570 & ktime , kstart, kcount ) 629 & ktime , kstart, kcount, & 630 & lrowattr ) 571 631 !!----------------------------------------------------------------------- 572 632 !! *** ROUTINE iom_get_123d *** … … 585 645 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 586 646 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 647 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 648 ! look for and use a file attribute 649 ! called open_ocean_jstart to set the start 650 ! value for the 2nd dimension (netcdf only) 587 651 ! 588 652 LOGICAL :: llnoov ! local definition to read overlap 653 LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute 654 INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute 589 655 INTEGER :: jl ! loop on number of dimension 590 656 INTEGER :: idom ! type of domain … … 596 662 INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes 597 663 INTEGER :: ji, jj ! loop counters 598 INTEGER :: irankpv 664 INTEGER :: irankpv ! 599 665 INTEGER :: ind1, ind2 ! substring index 600 666 INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis … … 620 686 IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 621 687 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 688 689 luse_jattr = .false. 690 IF( PRESENT(lrowattr) ) THEN 691 IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 692 IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. 693 ENDIF 694 IF( luse_jattr ) THEN 695 SELECT CASE (iom_file(kiomid)%iolib) 696 CASE (jpioipsl, jprstdimg ) 697 CALL ctl_warn(trim(clinfo), 'lrowattr present and true but this only works with netcdf (jpnf90)') 698 luse_jattr = .false. 699 CASE (jpnf90 ) 700 ! Ok 701 CASE DEFAULT 702 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 703 END SELECT 704 ENDIF 622 705 623 706 ! Search for the variable in the data base (eventually actualize data) … … 693 776 ELSE 694 777 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 695 IF( idom == jpdom_data ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /) ! icnt(1:2) done bellow 696 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done bellow 778 IF( idom == jpdom_data ) THEN 779 jstartrow = 1 780 IF( luse_jattr ) THEN 781 CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 782 jstartrow = MAX(1,jstartrow) 783 ENDIF 784 istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below 785 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 697 786 ENDIF 698 787 ! we do not read the overlap -> we start to read at nldi, nldj … … 1015 1104 CHARACTER(LEN=*), INTENT(in) :: cdname 1016 1105 REAL(wp) , INTENT(in) :: pfield0d 1106 REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1017 1107 #if defined key_iomput 1018 CALL xios_send_field(cdname, (/pfield0d/)) 1108 zz(:,:)=pfield0d 1109 CALL xios_send_field(cdname, zz) 1110 !CALL xios_send_field(cdname, (/pfield0d/)) 1019 1111 #else 1020 1112 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings … … 1056 1148 1057 1149 SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, & 1058 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 1059 CHARACTER(LEN=*) , INTENT(in) :: cdid 1060 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1061 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1062 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj 1063 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1064 LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) :: mask 1150 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & 1151 & nvertex, bounds_lon, bounds_lat, area ) 1152 CHARACTER(LEN=*) , INTENT(in) :: cdid 1153 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1154 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1155 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1156 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1157 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1158 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1065 1159 1066 1160 IF ( xios_is_valid_domain (cdid) ) THEN … … 1068 1162 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1069 1163 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1070 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1164 & lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon, & 1165 & bounds_lat=bounds_lat, area=area ) 1071 1166 ENDIF 1072 1167 … … 1075 1170 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1076 1171 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1077 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1172 & lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon, & 1173 & bounds_lat=bounds_lat, area=area ) 1078 1174 ENDIF 1079 1175 CALL xios_solve_inheritance() … … 1082 1178 1083 1179 1084 SUBROUTINE iom_set_axis_attr( cdid, paxis )1180 SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 1085 1181 CHARACTER(LEN=*) , INTENT(in) :: cdid 1086 REAL(wp), DIMENSION(:), INTENT(in) :: paxis 1087 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=size(paxis),value=paxis ) 1088 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis ) 1182 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis 1183 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds 1184 IF ( PRESENT(paxis) ) THEN 1185 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=SIZE(paxis), value=paxis ) 1186 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 1187 ENDIF 1188 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1189 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 1089 1190 CALL xios_solve_inheritance() 1090 1191 END SUBROUTINE iom_set_axis_attr … … 1149 1250 CALL iom_swap( cdname ) ! swap to cdname context 1150 1251 CALL xios_update_calendar(kt) 1151 IF( cdname /= "nemo" ) CALL iom_swap( "nemo") ! return back to nemo context1252 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1152 1253 ! 1153 1254 END SUBROUTINE iom_setkt … … 1155 1256 SUBROUTINE iom_context_finalize( cdname ) 1156 1257 CHARACTER(LEN=*), INTENT(in) :: cdname 1157 ! 1158 CALL iom_swap( cdname ) ! swap to cdname context 1159 CALL xios_context_finalize() ! finalize the context 1160 IF( cdname /= "nemo" ) CALL iom_swap( "nemo" ) ! return back to nemo context 1258 ! 1259 IF( xios_is_valid_context(cdname) ) THEN 1260 CALL iom_swap( cdname ) ! swap to cdname context 1261 CALL xios_context_finalize() ! finalize the context 1262 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1263 ENDIF 1161 1264 ! 1162 1265 END SUBROUTINE iom_context_finalize … … 1189 1292 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1190 1293 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( zmask, 'U', 1. ) 1191 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jp i,:) ; CALL lbc_lnk( zmask, 'V', 1. )1294 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( zmask, 'V', 1. ) 1192 1295 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1193 1296 END SELECT … … 1200 1303 1201 1304 1305 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) 1306 !!---------------------------------------------------------------------- 1307 !! *** ROUTINE set_grid_bounds *** 1308 !! 1309 !! ** Purpose : define horizontal grid corners 1310 !! 1311 !!---------------------------------------------------------------------- 1312 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1313 ! 1314 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 1315 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coordinates of the point of cell (i,j) 1316 ! 1317 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1318 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1319 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1320 ! 1321 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1322 ! ! represents the bottom-left corner of cell (i,j) 1323 INTEGER :: ji, jj, jn, ni, nj 1324 1325 ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) 1326 1327 ! Offset of coordinate representing bottom-left corner 1328 SELECT CASE ( TRIM(cdgrd) ) 1329 CASE ('T', 'W') 1330 icnr = -1 ; jcnr = -1 1331 CASE ('U') 1332 icnr = 0 ; jcnr = -1 1333 CASE ('V') 1334 icnr = -1 ; jcnr = 0 1335 END SELECT 1336 1337 ni = nlei-nldi+1 ; nj = nlej-nldj+1 ! Dimensions of subdomain interior 1338 1339 z_fld(:,:) = 1._wp 1340 CALL lbc_lnk( z_fld, cdgrd, -1. ) ! Working array for location of northfold 1341 1342 ! Cell vertices that can be defined 1343 DO jj = 2, jpjm1 1344 DO ji = 2, jpim1 1345 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1346 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1347 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1348 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1349 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1350 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1351 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1352 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1353 END DO 1354 END DO 1355 1356 ! Cell vertices on boundries 1357 DO jn = 1, 4 1358 CALL lbc_lnk( z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 1359 CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 1360 END DO 1361 1362 ! Zero-size cells at closed boundaries if cell points provided, 1363 ! otherwise they are closed cells with unrealistic bounds 1364 IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 1365 IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1366 DO jn = 1, 4 ! (West or jpni = 1), closed E-W 1367 z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) 1368 END DO 1369 ENDIF 1370 IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1371 DO jn = 1, 4 ! (East or jpni = 1), closed E-W 1372 z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 1373 END DO 1374 ENDIF 1375 IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 1376 DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) 1377 z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) 1378 END DO 1379 ENDIF 1380 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN 1381 DO jn = 1, 4 ! (North or jpnj = 1), no north fold 1382 z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 1383 END DO 1384 ENDIF 1385 ENDIF 1386 1387 ! Rotate cells at the north fold 1388 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN 1389 DO jj = 1, jpj 1390 DO ji = 1, jpi 1391 IF( z_fld(ji,jj) == -1. ) THEN 1392 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 1393 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 1394 z_bnds(:,ji,jj,:) = z_rot(:,:) 1395 ENDIF 1396 END DO 1397 END DO 1398 1399 ! Invert cells at the symmetric equator 1400 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 1401 DO ji = 1, jpi 1402 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 1403 z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 1404 z_bnds(:,ji,1,:) = z_rot(:,:) 1405 END DO 1406 ENDIF 1407 1408 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 1409 bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 1410 1411 DEALLOCATE( z_bnds, z_fld, z_rot ) 1412 1413 END SUBROUTINE set_grid_bounds 1414 1415 1416 SUBROUTINE set_grid_znl( plat ) 1417 !!---------------------------------------------------------------------- 1418 !! *** ROUTINE set_grid_znl *** 1419 !! 1420 !! ** Purpose : define grids for zonal mean 1421 !! 1422 !!---------------------------------------------------------------------- 1423 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1424 ! 1425 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 1426 INTEGER :: ni,nj, ix, iy 1427 1428 1429 ni=nlei-nldi+1 ; nj=nlej-nldj+1 ! define zonal mean domain (jpj*jpk) 1430 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0. 1431 1432 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 1433 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1434 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 1435 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1436 ! 1437 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1438 CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 1439 CALL iom_update_file_name('ptr') 1440 ! 1441 END SUBROUTINE set_grid_znl 1442 1202 1443 SUBROUTINE set_scalar 1203 1444 !!---------------------------------------------------------------------- … … 1207 1448 !! 1208 1449 !!---------------------------------------------------------------------- 1209 REAL(wp), DIMENSION(1 ,1):: zz = 1.1450 REAL(wp), DIMENSION(1) :: zz = 1. 1210 1451 !!---------------------------------------------------------------------- 1211 1452 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 1212 CALL iom_set_domain_attr('scalarpoint', data_dim=1) 1213 CALL iom_set_domain_attr('scalarpoint', lonvalue=(/ zz /), latvalue=(/ zz /)) 1453 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1454 1455 zz=REAL(narea,wp) 1456 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 1214 1457 1215 1458 END SUBROUTINE set_scalar … … 1226 1469 CHARACTER(len=256) :: clsuff ! suffix name 1227 1470 CHARACTER(len=1) :: cl1 ! 1 character 1228 CHARACTER(len=2) :: cl2 ! 1 character 1471 CHARACTER(len=2) :: cl2 ! 2 characters 1472 CHARACTER(len=3) :: cl3 ! 3 characters 1229 1473 INTEGER :: ji, jg ! loop counters 1230 1474 INTEGER :: ix, iy ! i-,j- index … … 1252 1496 WRITE(cl2,'(i2.2)') ji 1253 1497 CALL iom_update_file_name('file'//cl2) 1498 END DO 1499 DO ji = 1, 999 1500 WRITE(cl3,'(i3.3)') ji 1501 CALL iom_update_file_name('file'//cl3) 1254 1502 END DO 1255 1503 … … 1277 1525 zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 1278 1526 CALL set_mooring( zlonpira, zlatpira ) 1527 1279 1528 1280 1529 END SUBROUTINE set_xmlatt … … 1499 1748 1500 1749 #endif 1750 1751 LOGICAL FUNCTION iom_use( cdname ) 1752 CHARACTER(LEN=*), INTENT(in) :: cdname 1753 #if defined key_iomput 1754 iom_use = xios_field_is_active( cdname ) 1755 #else 1756 iom_use = .FALSE. 1757 #endif 1758 END FUNCTION iom_use 1501 1759 1502 1760 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
