ecearth3/sources/oasis3-mct/lib/mct/mpeu/m_StrTemplate.F90

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
! CVS m_StrTemplate.F90,v 1.6 2004-04-21 22:54:46 jacob Exp
! CVS MCT_2_8_0  
!BOP -------------------------------------------------------------------
!
! !MODULE: m_StrTemplate - A template formatting a string with variables
!
! !DESCRIPTION:
!
!	A template resolver formatting a string with a string variable
!   and time variables.  The format descriptors are similar to those
!   used in the GrADS.
!
!	"%y4"	substitute with a 4 digit year
!	"%y2"	a 2 digit year
!	"%m1"	a 1 or 2 digit month
!	"%m2"	a 2 digit month
!	"%mc"	a 3 letter month in lower cases
!	"%Mc"	a 3 letter month with a leading letter in upper case
!	"%MC"	a 3 letter month in upper cases
!	"%d1"	a 1 or 2 digit day
!	"%d2"	a 2 digit day
!	"%h1"	a 1 or 2 digit hour
!	"%h2"	a 2 digit hour
!	"%h3"	a 3 digit hour (?)
!	"%n2"	a 2 digit minute
!	"%s"	a string variable
!	"%%"	a "%"
!
! !INTERFACE:

    module m_StrTemplate
      implicit none
      private	! except

      public :: StrTemplate	! Substitute variables in a template

      interface StrTemplate
	module procedure strTemplate_
      end interface

! !REVISION HISTORY:
! 	01Jun99	- Jing Guo <guo@dao.gsfc.nasa.gov>
!		- initial prototype/prolog/code
! 	19Jan01	- Jay Larson <larson@mcs.anl.gov> - removed numerous
!                 double-quote characters appearing inside single-quote
!                 blocks.  This was done to comply with pgf90.  Also,
!                 numerous double-quote characters were removed from
!                 within comment blocks because pgf90 kept trying to
!                 interpret them (spooky).
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname='MCT(MPEU)::m_StrTemplate'

  character(len=3),parameter,dimension(12) :: mon_lc =	(/	&
	'jan','feb','mar','apr','may','jun',	&
	'jul','aug','sep','oct','nov','dec'	/)

  character(len=3),parameter,dimension(12) :: mon_wd =	(/	&
	'Jan','Feb','Mar','Apr','May','Jun',	&
	'Jul','Aug','Sep','Oct','Nov','Dec'	/)

  character(len=3),parameter,dimension(12) :: mon_uc =	(/	&
	'JAN','FEB','MAR','APR','MAY','JUN',	&
	'JUL','AUG','SEP','OCT','NOV','DEC'	/)

contains
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: strTemplate_ - expanding a format template to a string
!
! !DESCRIPTION:
!
! !INTERFACE:

    subroutine strTemplate_(str,tmpl,class,xid,nymd,nhms,stat)
      use m_chars, only : uppercase
      use m_stdio, only : stderr
      use m_die,   only : die
      implicit none

      character(len=*),intent(out) :: str	! the output

      character(len=*),intent(in ) :: tmpl	! a "format"

      character(len=*),intent(in ),optional :: class
			! choose a UNIX or a GrADS(defulat) type format

      character(len=*),intent(in ),optional :: xid
			! a string substituting a '%s'.  Trailing
			! spaces will be ignored

      integer,intent(in ),optional :: nymd
			! yyyymmdd, substituting '%y4', '%y2', '%m1',
			! '%m2', '%mc', '%Mc', and '%MC'

      integer,intent(in ),optional :: nhms
			! hhmmss, substituting '%h1', '%h2', '%h3',
			! and '%n2'

      integer,intent(out),optional :: stat
			! error code

! !REVISION HISTORY:
! 	03Jun99	- Jing Guo <guo@dao.gsfc.nasa.gov>
!		- initial prototype/prolog/code
!       08Jan03 - R. Jacob <jacob@mcs.anl.gov>  Small change to get
!          around IBM compiler bug.  Cant have character valued functions
!          in case statements.  Fix found by Everest Ong.
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::strTemplate_'
  character(len=16) :: tmpl_class
  character(len=16) :: tmp_upper

  tmpl_class="GX"
  if(present(class)) tmpl_class=class

  tmp_upper = uppercase(tmpl_class)
  select case(tmp_upper)

  case("GX","GRADS")
    call GX_(str,tmpl,xid,nymd,nhms,stat)

  !case("UX","UNIX")	! yet to be implemented
  !  call UX_(str,tmpl,xid,nymd,nhms,stat)

  case default
    write(stderr,'(4a)') myname_,': unknown class:  ',	&
	trim(tmpl_class),'.'
    if(.not.present(stat)) call die(myname_)
    stat=-1
    return
  end select

end subroutine strTemplate_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: GX_ - evaluate a GrADS style string template
!
! !DESCRIPTION:
!
! !INTERFACE:

    subroutine GX_(str,tmpl,xid,nymd,nhms,stat)
      use m_stdio,only : stderr
      use m_die,  only : die,perr
      implicit none
      character(len=*),intent(out) :: str
      character(len=*),intent(in ) :: tmpl
      character(len=*),optional,intent(in) :: xid
      integer,optional,intent(in)  :: nymd
      integer,optional,intent(in)  :: nhms
      integer,optional,intent(out) :: stat

! !REVISION HISTORY:
! 	01Jun99	- Jing Guo <guo@dao.gsfc.nasa.gov>
!		- initial prototype/prolog/code
!       19Jan01 - Jay Larson <larson@mcs.anl.gov> - added
!                 variable c1c2, to store c1//c2, which pgf90
!                 would not allow as an argument to the 'select case'
!                 statement.
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::GX_'

  integer :: iy4,iy2,imo,idy
  integer :: ihr,imn
  integer :: i,i1,i2,m,k
  integer :: ln_tmpl,ln_str
  integer :: istp,kstp

  character(len=1) :: c0,c1,c2
  character(len=2) :: c1c2
  character(len=4) :: sbuf
!________________________________________
	! Determine iyr, imo, and idy
  iy4=-1
  iy2=-1
  imo=-1
  idy=-1
  if(present(nymd)) then
	if(nymd < 0) then
	  call perr(myname_,'nymd < 0',nymd)
	  if(.not.present(stat)) call die(myname_)
	  stat=1
	  return
	endif

    i=nymd
    iy4=i/10000
    iy2=mod(iy4,100)
      i=mod(i,10000)
    imo=i/100
      i=mod(i,100)
    idy=i
  endif
!________________________________________
	! Determine ihr and imn
  ihr=-1
  imn=-1
  if(present(nhms)) then
	if(nhms < 0) then
	  call perr(myname_,'nhms < 0',nhms)
	  if(.not.present(stat)) call die(myname_)
	  stat=1
	  return
	endif

    i=nhms
    ihr=i/10000
      i=mod(i,10000)
    imn=i/100
  endif
!________________________________________

  ln_tmpl=len_trim(tmpl)	! size of the format template
  ln_str =len(str)		! size of the output string
!________________________________________

  if(present(stat)) stat=0

str=""

i=0; istp=1
k=1; kstp=1

do while( i+istp <= ln_tmpl )	! A loop over all tokens in (tmpl)

  if(k>ln_Str) exit	! truncate the output here.

  i=i+istp
  c0=tmpl(i:i)

  select case(c0)
  case ("%")
	!________________________________________

    c1=""
    i1=i+1
    if(i1 <= ln_Tmpl) c1=tmpl(i1:i1)
	!________________________________________

    select case(c1)

    case("s")
      if(.not.present(xid)) then
	write(stderr,'(2a)') myname_,	&
		': optional argument expected, "xid="'
	if(.not.present(stat)) call die(myname_)
	stat=1
	return
      endif

      istp=2
      m=min(k+len_trim(xid)-1,ln_str)
      str(k:m)=xid
      k=m+1
      cycle

    case("%")

      istp=2
      str(k:k)="%"
      k=k+1	! kstp=1
      cycle

    case default

      c2=""
      i2=i+2
      if(i2 <= ln_Tmpl) c2=tmpl(i2:i2)
	!________________________________________

      c1c2 = c1 // c2
      select case(c1c2)

      case("y4","y2","m1","m2","mc","Mc","MC","d1","d2")
        if(.not.present(nymd)) then
	  write(stderr,'(2a)') myname_,	&
		': optional argument expected, "nymd="'
	  if(.not.present(stat)) call die(myname_)
	  stat=1
	  return
        endif
        istp=3

      case("h1","h2","h3","n2")
        if(.not.present(nhms)) then
	  write(stderr,'(2a)') myname_,	&
		': optional argument expected, "nhms="'
	  if(.not.present(stat)) call die(myname_)
	  stat=1
	  return
        endif
        istp=3

      case default

        write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
        if(.not.present(stat)) call die(myname_)
        stat=2
        return

      end select	  ! case(c1//c2)
    end select		! case(c1)
	!________________________________________

    select case(c1)

    case("y")
      select case(c2)
      case("2")
	write(sbuf,'(i2.2)') iy2
	kstp=2
      case("4")
	write(sbuf,'(i4.4)') iy4
	kstp=4
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case("m")
      select case(c2)
      case("1")
	if(imo < 10) then
	  write(sbuf,'(i1)') imo
	  kstp=1
	else
	  write(sbuf,'(i2)') imo
	  kstp=2
	endif
      case("2")
	write(sbuf,'(i2.2)') imo
	kstp=2
      case("c")
	sbuf=mon_lc(imo)
	kstp=3
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case("M")
      select case(c2)
      case("c")
	sbuf=mon_wd(imo)
	kstp=3
      case("C")
	sbuf=mon_uc(imo)
	kstp=3
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case("d")
      select case(c2)
      case("1")
	if(idy < 10) then
	  write(sbuf,'(i1)') idy
	  kstp=1
	else
	  write(sbuf,'(i2)') idy
	  kstp=2
	endif
      case("2")
	write(sbuf,'(i2.2)') idy
	kstp=2
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case("h")
      select case(c2)
      case("1")
	if(ihr < 10) then
	  write(sbuf,'(i1)') ihr
	  kstp=1
	else
	  write(sbuf,'(i2)') ihr
	  kstp=2
	endif
      case("2")
	write(sbuf,'(i2.2)') ihr
	kstp=2
      case("3")
	write(sbuf,'(i3.3)') ihr
	kstp=3
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case("n")
      select case(c2)
      case("2")
	write(sbuf,'(i2.2)') imn
	kstp=2
      case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
	return
      end select

    case default
	write(stderr,'(4a)') myname_,	&
	  ': invalid template entry:  ',trim(tmpl(i:)),'.'
	if(.not.present(stat)) call die(myname_)
	stat=2
      return
    end select	! case(c1)

    m=min(k+kstp-1,ln_Str)
    str(k:m)=sbuf
    k=m+1

  case default

    istp=1
    str(k:k)=tmpl(i:i)
    k=k+1

  end select	! case(c0)
end do

end subroutine GX_
end module m_StrTemplate