psmile_io_utils.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
! !MODULE:
Module psmile_io_utils
! !INTERFACE:
    Interface psmile_io_fileunit
          module procedure psmile_io_fileunit
        End Interface 
    Interface combine_with_date
          module procedure combine_with_date
        End Interface
    Interface extract_date
          module procedure extract_date
        End Interface
    Interface psmile_io_get_initial_date
          module procedure psmile_io_get_initial_date 
        End Interface
    Interface psmile_io_get_jobstart_date
          module procedure psmile_io_get_jobstart_date 
        End Interface
    Interface psmile_io_get_jobend_date
          module procedure psmile_io_get_jobend_date 
        End Interface
        Interface psmile_io_check_basename
          module procedure  psmile_io_check_basename 
        End Interface
!        Interface indexi
!          module procedure indexi
!        End Interface
! !DESCRIPTION:
!
! psmile_io_fileunit returns automatically an unused FORTRAN IO unit
! at the time when this routine is called.
!
! combine_with_date combines a file anme <name>.nc with the
! extensions _in or _out followed with the suffix .<date in ISO format>.nc
!
! extract_date returns the date from a string 
! 'SeCond siNce 2003-05-13 15:21:52'  as a PRISM_Time_Struct and optionally 
! as an integer array of 6 elements.
!
! psmile_io_check_basename checks if a given file name contains a certain 
! suffix. If a suffix is present the filename is no basename and the
! result is .false.
! 
! psmile_io_get_jobstart_date returns the Gregorian date of the job start
! and optionally on an integer array
!
! psmile_io_get_jobend_date returns the Gregorian date of the job end
! and optionally on an integer array
!
! psmile_io_get_initial_date returns the Gregorian date of the experiment
! and optionally on an integer array
!
! indexi performs a sort by ranking 
!
! !REVISION HISTORY:
! 
!   Date      Programmer    Description
! ----------  -----------   -----------
! 31.10.2003  vogelsang     File unit search
! 09.12.2003  vogelsang     added psmile_io_get_jobstart_date and
!                            psmile_io_get_initial_date
! 27.08.2004  vogelsang     Added the procedure psmile_io_get_jobend_date
!
!EOP
! ---------------------------------------------------------------------
contains
  subroutine psmile_io_fileunit(id_varid,id_unit,ierror)
  use psmile
  implicit none
  include 'prism.inc'
  integer,intent(in)    :: id_varid
  integer,intent(out)   :: id_unit
  integer,intent(out)   :: ierror

  logical :: l_open
  integer :: i,ierrp(2)

   Character(len=len_cvs_string), save :: mycvs_io_utils = 
   '$Id: psmile_io_utils.F90 2325 2010-04-21 15:00:07Z valcke $'
#ifdef __PSMILE_WITH_IO
        l_open=.true.
        do i=7, PSMILE_IO_MAX_UNIT
           if(.not.any(i.eq.IO_res_units(1:PSMILE_IO_MAX_RESERVED_UNITS))) &
             inquire(unit=i,opened=l_open)
           if(.not.l_open) exit
        end do

        if(i== PSMILE_IO_MAX_UNIT+1)then
            ierror=PRISM_Error_Internal
            call psmile_error ( ierror, 'Cound not find free I/O unit!', &
                             ierrp, 0, __FILE__, __LINE__ )

        else
            id_unit = i
        endif
#endif

        return
   end subroutine psmile_io_fileunit
!
      subroutine combine_with_date(cd_in,cd_mode,id_initial_date,cd_on)
!-------------------------------------------------------------
!     use mod_kinds_model
      character(len=*),intent(in)::cd_in
      character(len=*),intent(in)::cd_mode
      character(len=*),intent(out)::cd_on
      integer,intent(in)::id_initial_date(:)
!Local
      integer,parameter::il_nsuffixes=2
      integer::leni,leno,lens,lenb,il_i
      character(len=8)::suffixes(il_nsuffixes),suffix
      character(len=len(cd_in))::cl_basename
      character(len=4)::cl_year
      character(len=2)::cl_date(1:size(id_initial_date)-1)
     
      suffixes(1)='.nc'
      suffixes(2)='.grib'
     
      leni=len(trim(cd_in))
      leno=len(cd_on)

      cl_basename=''
     
      do il_i=1,il_nsuffixes
     
        suffix=suffixes(il_i)
        lens=len(trim(suffix))

        if(leni.gt.0.and.leni.lt.lens) then
          cl_basename(1:leni)=cd_in(1:leni)
          lenb=leni
          suffix='.nc'
        else if(cd_in(leni-lens+1:leni).eq.suffix(1:lens)) then
          cl_basename(1:leni-lens)=cd_in(1:leni-lens)
          lenb=leni-lens
          EXIT
        else
          cl_basename(1:leni)=cd_in(1:leni)
          lenb=leni
          suffix='.nc'
        endif
     
      enddo
     
     
      write(cl_year,'(i4.4)')id_initial_date(1)

      do il_i=2,size(id_initial_date)

        write(cl_date(il_i-1),'(i2.2)')id_initial_date(il_i)

      enddo
     
      if(trim(cd_mode) .eq. 'since' ) then
      cd_on=trim(cl_basename(1:lenb))//' '//trim(cd_mode)//' ' &
                                     //cl_year//'-'//cl_date(1)//'-' &
                                     //cl_date(2)//' ' &
                                     //cl_date(3)//':' &
                                     //cl_date(4)//':' &
                                     //cl_date(5)
      else
      cd_on=trim(cl_basename(1:lenb))//'_'//trim(cd_mode)//'.' &
                                     //cl_year//'-'//cl_date(1)//'-' &
                                     //cl_date(2)//'T' &
                                     //cl_date(3)//'_' &
                                     //cl_date(4)//'_' &
                                     //cl_date(5)//suffix
      endif
     
      return
      end subroutine combine_with_date
!
      subroutine extract_date(time_unit,curdate,id_date)
      use PRISM_Constants
      use PSMILE
      implicit none
!
!     Arguments
!
      character(len=*),intent(in)::time_unit
      Type(PRISM_Time_Struct),intent(inout):: curdate
      integer,dimension(6),intent(out),optional::id_date
!
!     Local variables
!      
      integer::i,j,iloc,ierrp(2),ierror
      character(len=max_name)::tmp_unit
      character(len=1)::tmp_char
      
      
!
!Pack input string and convert to small letters
!
      
      iloc=1
      do i=1,len(trim(time_unit))
      if(time_unit(i:i) .ne. ' ') then
      j=ichar(time_unit(i:i))
      if(j.ge.65 .and. j.le.90) then
      tmp_char=char(j+32)
      else
      tmp_char=char(j)
      endif
      tmp_unit(iloc:iloc)=tmp_char
      iloc=iloc+1
      endif
      enddo
!
      if(len(trim(tmp_unit))-4.lt.1) then
         ierror = PRISM_Error_Internal
         call psmile_error ( ierror, 'Invalid unit of time axis!', &
                             ierrp, 0, __FILE__, __LINE__ )
      endif
      
!
! Search for the string 'since'
!
      do i=1,len(trim(tmp_unit))-4
      if(tmp_unit(i:i+4).eq.'since') exit
      enddo

      if(i.eq.len(trim(tmp_unit))-4) then
         ierror = PRISM_Error_Internal
         call psmile_error ( ierror, 'Time axis has no time origin!', &
                             ierrp, 0, __FILE__, __LINE__ )
      endif
      
!
! The date starts here
!
      i=i+5
      
      read(tmp_unit(i:i+3),'(i4)')curdate%year
      
!
! Shift to the next position skipping separator
!
      i=i+5
      
      read(tmp_unit(i:i+1),'(i2)')curdate%month
      
!
! Shift to the next position skipping separator
!
      i=i+3
      
      read(tmp_unit(i:i+3),'(i2)')curdate%day
      
!
! Shift to the next position .
!
      i=i+2
      
!
! Separator between day and hour ?
!
      if(ichar(tmp_unit(i:i)).lt.48 .or. ichar(tmp_unit(i:i)).gt.57) i=i+1
!
      read(tmp_unit(i:i+1),'(i2)')curdate%hour
!
! Shift to the next position skipping separator
!
      i=i+3
      read(tmp_unit(i:i+1),'(i2)')curdate%minute
!
! Shift to the next position skipping separator
!
      i=i+3
      read(tmp_unit(i:i+1),'(i2)') j
      curdate%second=dble(j)
      
      if(present(id_date)) then
                id_date(1)=curdate%year
                id_date(2)=curdate%month
                id_date(3)=curdate%day
                id_date(4)=curdate%hour
                id_date(5)=curdate%minute
                id_date(6)=curdate%second
      endif
      
      end subroutine extract_date


      subroutine psmile_io_get_jobstart_date(id_jobstart_date,id_date,ierror)
      USE PRISM, only : PRISM_Jobstart_date
      USE PRISM_Constants
      USE PSMILe
      USE prism_calendar
      implicit none

      integer,intent(out) :: ierror
      Type(PRISM_Time_Struct),intent(out) :: id_jobstart_date
      integer,intent(out),optional:: id_date(:)
!Local
!RV Warning: Workarounad
!      Type(PRISM_Time_Struct) :: prism_jobstart_date

      ierror=0
!RV, Workaround
!      prism_jobstart_date%year=0
!      prism_jobstart_date%month=0
!      prism_jobstart_date%day=0
!      prism_jobstart_date%hour=0
!      prism_jobstart_date%minute=0
!      prism_jobstart_date%second=0
      id_jobstart_date= PRISM_jobstart_date
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_io_get_jobstart_date: date',id_jobstart_date
#endif
      if(present(id_date))then
          id_date(1)=id_jobstart_date%year
          id_date(2)=id_jobstart_date%month
          id_date(3)=id_jobstart_date%day
          id_date(4)=id_jobstart_date%hour
          id_date(5)=id_jobstart_date%minute
          id_date(6)=id_jobstart_date%second
      endif
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_io_get_jobstart_date: end'
      call psmile_flushstd
#endif
      return
      end subroutine psmile_io_get_jobstart_date

      subroutine psmile_io_get_jobend_date(id_jobend_date,id_date,ierror)
      USE PRISM, only : PRISM_jobend_date
      USE PRISM_Constants
      USE PSMILe
      USE prism_calendar
      implicit none

      integer,intent(out) :: ierror
      Type(PRISM_Time_Struct),intent(out) :: id_jobend_date
      integer,intent(out),optional:: id_date(:)
!Local
!RV Warning: Workarounad
!      Type(PRISM_Time_Struct) :: prism_jobend_date

      ierror=0
!RV, Workaround
!      prism_jobend_date%year=0
!      prism_jobend_date%month=0
!      prism_jobend_date%day=0
!      prism_jobend_date%hour=0
!      prism_jobend_date%minute=0
!      prism_jobend_date%second=0
      id_jobend_date= PRISM_jobend_date
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_io_get_jobend_date: date',id_jobend_date
      call psmile_flushstd
#endif
      if(present(id_date))then
          id_date(1)=id_jobend_date%year
          id_date(2)=id_jobend_date%month
          id_date(3)=id_jobend_date%day
          id_date(4)=id_jobend_date%hour
          id_date(5)=id_jobend_date%minute
          id_date(6)=id_jobend_date%second
      endif
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_io_get_jobend_date: end'
      call psmile_flushstd
#endif
      return
      end subroutine psmile_io_get_jobend_date

      subroutine psmile_io_get_initial_date(id_initial_date,id_date,ierror)
      USE PRISM_Constants
      USE PSMILe
      USE prism_calendar
      implicit none

      integer,intent(out) :: ierror
      Type(PRISM_Time_Struct),intent(out) :: id_initial_date
      integer,intent(out),optional:: id_date(:)

      ierror=0
!      id_initial_date= PRISM_initial_date
      call psmile_get_initial_date(id_initial_date,ierror)
      if(present(id_date))then
          id_date(1)=id_initial_date%year
          id_date(2)=id_initial_date%month
          id_date(3)=id_initial_date%day
          id_date(4)=id_initial_date%hour
          id_date(5)=id_initial_date%minute
          id_date(6)=id_initial_date%second
      endif
#ifdef VERBOSE
      print*,trim(ch_id),' : psmile_io_get_jobstart_date: end'
      call psmile_flushstd
#endif
      return
      end subroutine psmile_io_get_initial_date

      subroutine psmile_io_check_basename(cd_filename,cd_suffix &
                                         ,ld_base,id_error)
      implicit none
      character(len=*),intent(in)         :: cd_filename
      character(len=*),intent(in)         :: cd_suffix
      logical,intent(out)                 :: ld_base
      integer,intent(out)                 :: id_error

!Local variables
      integer                             :: il_flsuffl,il_flnamel

      id_error=0

      ld_base=.TRUE.
      il_flnamel=len(trim(cd_filename))
      il_flsuffl=len(trim(cd_suffix))

      if(il_flnamel.lt.il_flsuffl) return

      if(cd_filename(il_flnamel-il_flsuffl+1:il_flnamel).eq.trim(cd_suffix)) &
        ld_base=.false.

      end subroutine psmile_io_check_basename

      
       subroutine indexi(n,arr,indx)
!---------------------------------------------------------------------
! Generates a list indx which sorts arr in ascending order.
! This is called sorting by indexing.
! Code taken from 'Numerical Recipes'
!---------------------------------------------------------------------
      INTEGER,intent(in):: n
      INTEGER,intent(out)::indx(*)
      integer,intent(in):: arr(*)
!Local
      integer,PARAMETER:: M=7,NSTACK=128
      INTEGER:: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK)
      integer:: a

      do 11 j=1,n
        indx(j)=j
11    continue
      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do 13 j=l+1,ir
          indxt=indx(j)
          a=arr(indxt)
          do 12 i=j-1,1,-1
            if(arr(indx(i)).le.a)goto 2
            indx(i+1)=indx(i)
12        continue
          i=0
2         indx(i+1)=indxt
13      continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        itemp=indx(k)
        indx(k)=indx(l+1)
        indx(l+1)=itemp
        if(arr(indx(l+1)).gt.arr(indx(ir)))then
          itemp=indx(l+1)
          indx(l+1)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l)).gt.arr(indx(ir)))then
          itemp=indx(l)
          indx(l)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l+1)).gt.arr(indx(l)))then
          itemp=indx(l+1)
          indx(l+1)=indx(l)
          indx(l)=itemp
        endif
        i=l+1
        j=ir
        indxt=indx(l)
        a=arr(indxt)
3       continue
          i=i+1
        if(arr(indx(i)).lt.a)goto 3
4       continue
          j=j-1
        if(arr(indx(j)).gt.a)goto 4
        if(j.lt.i)goto 5
        itemp=indx(i)
        indx(i)=indx(j)
        indx(j)=itemp
        goto 3
5       indx(l)=indx(j)
        indx(j)=indxt
        jstack=jstack+2
        if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx'
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      END subroutine indexi


End Module psmile_io_utils