ecearth3/sources/nemo-3.6/EXTERNAL/IOIPSL/tools/ncregular.f90

PROGRAM ncregular
!
!$Id: ncregular.f90 2281 2010-10-15 14:21:13Z smasson $
!-
! This software is governed by the CeCILL license
! See IOIPSL/IOIPSL_License_CeCILL.txt
!---------------------------------------------------------------------
!- This code replaces a 2D surface grid by vectors.
!- Obviously it only works if you have a regular grid.
!-
!- Jan Polcher (polcher@lmd.jussieu.fr)
!- Jacques Bellier (jacques.bellier@cea.fr)
!---------------------------------------------------------------------
  USE netcdf
!-
  IMPLICIT NONE
!-
  INTEGER :: iread, if, in, iv, sz
  INTEGER :: ier, nb_files, iret, ndims, nvars, nb_glat
  INTEGER :: lon_dim_id, lat_dim_id
  INTEGER :: lon_len, lat_len, lon_id, lat_id
  INTEGER :: nav_lon_id, nav_lat_id
  INTEGER :: alloc_stat_lon, alloc_stat_lat
!-
  INTEGER,ALLOCATABLE ::  file_id(:), tax_id(:)
  CHARACTER(LEN=80),ALLOCATABLE :: names(:)
  CHARACTER(LEN=80) :: dim_name
  CHARACTER(LEN=80) :: varname
  CHARACTER(LEN=20) :: xname, yname, lonname, latname
  LOGICAL :: check, regular
!-
  REAL,ALLOCATABLE :: lon(:), lat(:), lon2(:), lat2(:)
  REAL,ALLOCATABLE :: del_lon(:), del_lat(:)
!-
  INTEGER iargc, getarg
  EXTERNAL iargc, getarg
!---------------------------------------------------------------------
  alloc_stat_lon = 0
  alloc_stat_lat = 0
!-
  iread = iargc()
!-
  ALLOCATE (names(iread),stat=ier)
  IF (ier /= 0) THEN
    WRITE (*,*) ' Could not allocate names of size ', iread
    STOP 'nctax'
  ENDIF
!-
  CALL nct_getarg (iread, nb_files, names, check, &
 &                 xname, yname, lonname, latname)
!-
! Allocate space
!-
  ALLOCATE (file_id(nb_files),stat=ier)
  IF (ier /= 0) THEN
    WRITE (*,*) ' Could not allocate file_id of size ', nb_files
    STOP 'nctax'
  ENDIF
!-
  ALLOCATE (tax_id(nb_files),stat=ier)
  IF (ier /= 0) THEN
    WRITE (*,*) ' Could not allocate tax_id of size ', nb_files
    STOP 'nctax'
  ENDIF
!-
  DO if=1,nb_files
!---
    IF (check) THEN
      WRITE(*,*) 'ncregular : ', if,  names(if)
    ENDIF
!---
    iret = NF90_OPEN (names(if),NF90_WRITE,file_id(if))
    iret = NF90_INQUIRE (file_id(if),ndims,nvars,nb_glat,tax_id(if))
!---
!-- Get the IDs of the variables
!---
    lon_len = -9999
    lat_len = -9999
    DO in=1,ndims
!-----
      iret = NF90_INQUIRE_DIMENSION (file_id(if), in, dim_name, sz)
!-----
      IF (     (LEN_TRIM(dim_name) == 1) &
 &        .AND.(INDEX(dim_name,TRIM(xname)) == 1) ) THEN
        lon_dim_id = in
        lon_len = sz
      ENDIF
!-----
      IF (     (LEN_TRIM(dim_name) == 1) &
 &        .AND.(INDEX(dim_name,TRIM(yname)) == 1) ) THEN
        lat_dim_id = in
        lat_len = sz
      ENDIF
!-----
    ENDDO
!---
    IF ( (lon_len == -9999).OR.(lat_len == -9999) ) THEN
      WRITE(*,*) 'ncregular : The specified dimensions were not'
      WRITE(*,*) 'found in file : ',names(if)
      iret = NF90_CLOSE (file_id(if))
      STOP
    ENDIF
!---
    IF (check) THEN
      WRITE(*,*) 'ncregular : lon_dim_id, lon_len',lon_dim_id,lon_len
      WRITE(*,*) 'ncregular : lat_dim_id, lat_len',lat_dim_id,lat_len
    ENDIF
!---
!-- Look for the right variables
!---
    nav_lon_id = -9999
    nav_lat_id = -9999
    DO iv=1,nvars
      iret = NF90_INQUIRE_VARIABLE (file_id(if),iv,name=varname)
      IF (INDEX(varname,TRIM(lonname)) > 0) THEN
        nav_lon_id = iv
      ENDIF
      IF (INDEX(varname,TRIM(latname)) > 0) THEN
        nav_lat_id = iv
      ENDIF
    ENDDO
!---
    IF ( (nav_lon_id == -9999).OR.(nav_lat_id == -9999) ) THEN
      WRITE(*,*) 'ncregular : The specified coordinate fields'
      WRITE(*,*) 'were not found in file : ',names(if)
      iret = NF90_CLOSE (file_id(if))
      STOP
    ENDIF
!---
    IF (check) THEN
      WRITE(*,*) 'ncregular : nav_lon_id :', nav_lon_id
      WRITE(*,*) 'ncregular : nav_lat_id :', nav_lat_id
    ENDIF
!---
!-- Read variables from file and check if regular
!---
!-- Do we have the variable to read the
!---
    IF ( alloc_stat_lon < lon_len) THEN
      IF ( alloc_stat_lon > 0) THEN
        deallocate(lon)
        deallocate(lon2)
        deallocate(del_lon)
      ENDIF
      allocate(lon(lon_len))
      allocate(lon2(lon_len))
      allocate(del_lon(lon_len))
      alloc_stat_lon = lon_len
    ENDIF
!---
    IF ( alloc_stat_lat < lat_len) THEN
      IF ( alloc_stat_lat > 0) THEN
        deallocate(lat)
        deallocate(lat2)
        deallocate(del_lat)
      ENDIF
      allocate(lat(lat_len))
      allocate(lat2(lat_len))
      allocate(del_lat(lat_len))
      alloc_stat_lat = lat_len
    ENDIF
!---
!-- Read data
!---
    iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon, &
 & start=(/1,1/),count=(/lon_len,1/),stride=(/1,1/))
    iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon2, &
 & start=(/1,int(lat_len/2)/),count=(/lon_len,1/),stride=(/1,1/))
    del_lon = lon-lon2
!-
    iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat, &
 & start=(/1,1/),count=(/1,lat_len/),stride=(/lon_len,1/))
    iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat2, &
 & start=(/int(lon_len/2),1/),count=(/1,lat_len/),stride=(/lon_len,1/))
    del_lat = lat-lat2
!-
    regular = (    (MAXVAL(del_lon) < 0.001) &
 &             .OR.(MAXVAL(del_lat) < 0.001) )
!---
!-- Create the new variables
!---
    IF (regular) THEN
      IF (check) THEN
        WRITE(*,*) 'Regular case'
      ENDIF
      iret = NF90_REDEF (file_id(if))
      iret = NF90_RENAME_DIM (file_id(if), lon_dim_id, 'lon')
      iret = NF90_RENAME_DIM (file_id(if), lat_dim_id, 'lat')
      IF (check) THEN
        WRITE(*,*) 'Dimensions renamed'
      ENDIF
      iret = NF90_DEF_VAR (file_id(if), 'lon', NF90_FLOAT, &
 &                         lon_dim_id, lon_id)
      iret = NF90_DEF_VAR (file_id(if), 'lat', NF90_FLOAT, &
 &                         lat_dim_id, lat_id)
      IF (check) THEN
        WRITE(*,*) 'New variables defined'
      ENDIF
!-----
!---- Copy attributes
!-----
      iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'units', &
 &                          file_id(if),lon_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'title', &
 &                          file_id(if),lon_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_max', &
 &                          file_id(if),lon_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_min', &
 &                          file_id(if),lon_id)
!-----
      iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'units', &
 &                          file_id(if),lat_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'title', &
 &                          file_id(if),lat_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_max', &
 &                          file_id(if),lat_id)
      iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_min', &
 &                          file_id(if),lat_id)
!-----
!---- Go into write mode
!-----
      iret = NF90_ENDDEF (file_id(if))
!-----
!---- Write data
!-----
      iret = NF90_PUT_VAR (file_id(if),lon_id,lon(1:lon_len))
      iret = NF90_PUT_VAR (file_id(if),lat_id,lat(1:lat_len))
!-
      iret = NF90_CLOSE (file_id(if))
    ELSE
      WRITE(*,*) 'ncregular : Your grid is not regular'
      WRITE(*,*) names(if), 'remains unchanged'
      iret = NF90_CLOSE (file_id(if))
    ENDIF
!-
  ENDDO
!--------------------
END PROGRAM ncregular
!-
!===
!-
SUBROUTINE nct_getarg (argx, nb_files, names, check, &
 &                     xname, yname, lonname, latname)
!---------------------------------------------------------------------
!- Read the arguments of nctax.
!---------------------------------------------------------------------
  INTEGER,INTENT(in) :: argx
  INTEGER, INTENT(out) :: nb_files
  CHARACTER(LEN=80),INTENT(out) :: names(argx)
  CHARACTER(LEN=20) :: xname, yname, lonname, latname
!-
  CHARACTER(LEN=80) :: tmp, tmp_arg
  LOGICAL :: check
!---------------------------------------------------------------------
  check = .FALSE.
!-
! Get the number of arguments
!-
  nb_files = 0
!-
  xname = 'x'
  yname = 'y'
  lonname = 'nav_lon'
  latname = 'nav_lat'
!-
! Go through the arguments and analyse them one by one
!-
  IF (check) WRITE(*,*) 'Start going through the arguments'
!-
  IF (argx == 0) THEN
    WRITE(*,*) 'To get usage : nctax -h '
    STOP
  ENDIF
!-
  iread = 1
  DO WHILE (iread <= argx)
    iret = getarg(iread,tmp)
    IF (check) WRITE(*,*) ' iread, tmp :', iread, tmp
    SELECTCASE(tmp)
      CASE('-d')
        WRITE(*,*) 'DEBUG MODE SELECTED'
        check = .TRUE.
        iread = iread+1
      CASE('-h')
        WRITE(*,*) 'Usage : nregular [options] file1 [file2 ...]'
        WRITE(*,*) '    -d : Verbose mode'
        WRITE(*,*) '    -h : This output'
        STOP
      CASE('-dim_lon')
        iread = iread+1
        iret  = getarg(iread,tmp_arg)
        xname = TRIM(tmp_arg)
        iread = iread+1
      CASE('-dim_lat')
        iread = iread+1
        iret  = getarg(iread,tmp_arg)
        yname = TRIM(tmp_arg)
        iread = iread+1
      CASE('-coo_lon')
        iread = iread+1
        iret  = getarg(iread,tmp_arg)
        lonname = TRIM(tmp_arg)
        iread = iread+1
      CASE('-coo_lat')
        iread = iread+1
        iret  = getarg(iread,tmp_arg)
        latname = TRIM(tmp_arg)
        iread = iread+1
      CASE DEFAULT
        IF (check) WRITE(*,*) 'nct_getarg : CASE default'
        IF (INDEX(tmp,'-') /= 1) THEN
          nb_files = nb_files+1
          names(nb_files) = tmp
          iread = iread+1
        ELSE
          WRITE(*,*) "WARNING Unknown option ",tmp
          WRITE(*,*) "For ore information : nctax -h"
        ENDIF
    END SELECT
  ENDDO
!-
  IF (check) THEN
    WRITE(*,*) ' nct_getarg : output >> '
    WRITE(*,*) '>> nb_files : ', nb_files
    WRITE(*,*) '>> names :', (names(ii), ii=1,nb_files)
  ENDIF
!------------------------
END SUBROUTINE nct_getarg