Ignore:
Timestamp:
2015-07-15T17:46:12+02:00 (5 years ago)
Author:
andrewryan
Message:

merged in latest version of trunk alongside changes to SAO_SRC to be compatible with latest OBS

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r5034 r5600  
    3333   USE icb_oce, ONLY :   nclasses, class_num       !  !: iceberg classes 
    3434#if defined key_lim3 
    35    USE par_ice 
     35   USE ice    , ONLY :   jpl 
    3636#elif defined key_lim2 
    3737   USE par_ice_2 
     
    6161#if defined key_iomput 
    6262   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 
    63    PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
     63   PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 
    6464# endif 
    6565 
     
    9898      CHARACTER(len=10) :: clname 
    9999      INTEGER           ::   ji 
    100       !!---------------------------------------------------------------------- 
     100      ! 
     101      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
     102      !!---------------------------------------------------------------------- 
     103 
     104      ALLOCATE( z_bnds(jpk,2) ) 
    101105 
    102106      clname = cdname 
    103107      IF( TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) 
    104 # if defined key_mpp_mpi 
    105108      CALL xios_context_initialize(TRIM(clname), mpi_comm_opa) 
    106 # else 
    107       CALL xios_context_initialize(TRIM(clname), 0) 
    108 # endif 
    109109      CALL iom_swap( cdname ) 
    110110 
     
    121121      CALL set_scalar 
    122122 
    123       IF( TRIM(cdname) == "nemo" ) THEN   
     123      IF( TRIM(cdname) == TRIM(cxios_context) ) THEN   
    124124         CALL set_grid( "T", glamt, gphit )  
    125125         CALL set_grid( "U", glamu, gphiu ) 
    126126         CALL set_grid( "V", glamv, gphiv ) 
    127127         CALL set_grid( "W", glamt, gphit ) 
    128       ENDIF 
    129  
    130       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   
    131143         CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    132144         ! 
     
    135147         CALL set_grid( "V", glamv_crs, gphiv_crs )  
    136148         CALL set_grid( "W", glamt_crs, gphit_crs )  
     149         CALL set_grid_znl( gphit_crs ) 
    137150          ! 
    138151         CALL dom_grid_glo   ! Return to parent grid domain 
    139       ENDIF 
    140  
     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 
    141164 
    142165      ! vertical grid definition 
     
    145168      CALL iom_set_axis_attr( "depthv", gdept_1d ) 
    146169      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 
    147183# if defined key_floats 
    148184      CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 
     
    152188#endif 
    153189      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) /) ) 
    154192       
    155193      ! automatic definitions of some of the xml attributs 
     
    162200       
    163201      CALL xios_update_calendar(0) 
     202 
     203      DEALLOCATE( z_bnds ) 
     204 
    164205#endif 
    165206       
     
    543584   END SUBROUTINE iom_g1d 
    544585 
    545    SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     586   SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    546587      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file 
    547588      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read 
     
    551592      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading  
    552593      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) 
    553598      ! 
    554599      IF( kiomid > 0 ) THEN 
    555600         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   & 
    556               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     601              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     602              &                                                     lrowattr=lrowattr ) 
    557603      ENDIF 
    558604   END SUBROUTINE iom_g2d 
    559605 
    560    SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     606   SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    561607      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file 
    562608      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read 
     
    566612      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading  
    567613      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) 
    568618      ! 
    569619      IF( kiomid > 0 ) THEN 
    570620         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   & 
    571               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     621              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     622              &                                                     lrowattr=lrowattr ) 
    572623      ENDIF 
    573624   END SUBROUTINE iom_g3d 
     
    576627   SUBROUTINE iom_get_123d( kiomid, kdom  , cdvar ,   & 
    577628         &                  pv_r1d, pv_r2d, pv_r3d,   & 
    578          &                  ktime , kstart, kcount  ) 
     629         &                  ktime , kstart, kcount,   & 
     630         &                  lrowattr                ) 
    579631      !!----------------------------------------------------------------------- 
    580632      !!                  ***  ROUTINE  iom_get_123d  *** 
     
    593645      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis  
    594646      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) 
    595651      ! 
    596652      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 
    597655      INTEGER                        ::   jl          ! loop on number of dimension  
    598656      INTEGER                        ::   idom        ! type of domain 
     
    604662      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes 
    605663      INTEGER                        ::   ji, jj      ! loop counters 
    606       INTEGER                        ::   irankpv       !  
     664      INTEGER                        ::   irankpv     !  
    607665      INTEGER                        ::   ind1, ind2  ! substring index 
    608666      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis 
     
    628686      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 
    629687      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 
    630705 
    631706      ! Search for the variable in the data base (eventually actualize data) 
     
    701776            ELSE  
    702777               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array 
    703                   IF(     idom == jpdom_data    ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /)  ! icnt(1:2) done bellow 
    704                   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 
    705786                  ENDIF 
    706787                  ! we do not read the overlap                     -> we start to read at nldi, nldj 
     
    10671148 
    10681149   SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj,   & 
    1069       &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 
    1070       CHARACTER(LEN=*)                 , INTENT(in) ::   cdid 
    1071       INTEGER                , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj 
    1072       INTEGER                , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
    1073       INTEGER                , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj 
    1074       REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    1075       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 
    10761159 
    10771160      IF ( xios_is_valid_domain     (cdid) ) THEN 
     
    10791162            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    10801163            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1081             &    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 ) 
    10821166      ENDIF 
    10831167 
     
    10861170            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    10871171            &    zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj,                       & 
    1088             &    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 ) 
    10891174      ENDIF 
    10901175      CALL xios_solve_inheritance() 
     
    10931178 
    10941179 
    1095    SUBROUTINE iom_set_axis_attr( cdid, paxis ) 
     1180   SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 
    10961181      CHARACTER(LEN=*)      , INTENT(in) ::   cdid 
    1097       REAL(wp), DIMENSION(:), INTENT(in) ::   paxis 
    1098       IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=size(paxis),value=paxis ) 
    1099       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 ) 
    11001190      CALL xios_solve_inheritance() 
    11011191   END SUBROUTINE iom_set_axis_attr 
     
    11601250      CALL iom_swap( cdname )   ! swap to cdname context 
    11611251      CALL xios_update_calendar(kt) 
    1162       IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1252      IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    11631253      ! 
    11641254   END SUBROUTINE iom_setkt 
     
    11701260         CALL iom_swap( cdname )   ! swap to cdname context 
    11711261         CALL xios_context_finalize() ! finalize the context 
    1172          IF( cdname /= "nemo" ) CALL iom_swap( "nemo" )   ! return back to nemo context 
     1262         IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
    11731263      ENDIF 
    11741264      ! 
     
    12021292         CASE('T')   ;   zmask(:,:,:)       = tmask(:,:,:) 
    12031293         CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( zmask, 'U', 1. ) 
    1204          CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpi,:)   ;   CALL lbc_lnk( zmask, 'V', 1. ) 
     1294         CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)   ;   CALL lbc_lnk( zmask, 'V', 1. ) 
    12051295         CASE('W')   ;   zmask(:,:,2:jpk  ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk)   ;   zmask(:,:,1) = tmask(:,:,1) 
    12061296         END SELECT 
     
    12131303 
    12141304 
     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 
    12151443   SUBROUTINE set_scalar 
    12161444      !!---------------------------------------------------------------------- 
     
    12201448      !! 
    12211449      !!---------------------------------------------------------------------- 
    1222       REAL(wp), DIMENSION(1) ::   zz = 1. 
     1450      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    12231451      !!---------------------------------------------------------------------- 
    12241452      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
    12251453      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
     1454       
    12261455      zz=REAL(narea,wp) 
    12271456      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
     
    12961525      zlatpira = (/ -19.0, -14.0,  -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 
    12971526      CALL set_mooring( zlonpira, zlatpira ) 
     1527 
    12981528       
    12991529   END SUBROUTINE set_xmlatt 
Note: See TracChangeset for help on using the changeset viewer.