! +-======-+ ! Copyright (c) 2003-2018 United States Government as represented by ! the Admistrator of the National Aeronautics and Space Administration. ! All Rights Reserved. ! ! THIS OPEN SOURCE AGREEMENT ("AGREEMENT") DEFINES THE RIGHTS OF USE, ! REPRODUCTION, DISTRIBUTION, MODIFICATION AND REDISTRIBUTION OF CERTAIN ! COMPUTER SOFTWARE ORIGINALLY RELEASED BY THE UNITED STATES GOVERNMENT AS ! REPRESENTED BY THE GOVERNMENT AGENCY LISTED BELOW ("GOVERNMENT AGENCY"). ! THE UNITED STATES GOVERNMENT, AS REPRESENTED BY GOVERNMENT AGENCY, IS AN ! INTENDED THIRD-PARTY BENEFICIARY OF ALL SUBSEQUENT DISTRIBUTIONS OR ! REDISTRIBUTIONS OF THE SUBJECT SOFTWARE. ANYONE WHO USES, REPRODUCES, ! DISTRIBUTES, MODIFIES OR REDISTRIBUTES THE SUBJECT SOFTWARE, AS DEFINED ! HEREIN, OR ANY PART THEREOF, IS, BY THAT ACTION, ACCEPTING IN FULL THE ! RESPONSIBILITIES AND OBLIGATIONS CONTAINED IN THIS AGREEMENT. ! ! Government Agency: National Aeronautics and Space Administration ! Government Agency Original Software Designation: GSC-15354-1 ! Government Agency Original Software Title: GEOS-5 GCM Modeling Software ! User Registration Requested. Please Visit http://opensource.gsfc.nasa.gov ! Government Agency Point of Contact for Original Software: ! Dale Hithon, SRA Assistant, (301) 286-2691 ! ! +-======-+ !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !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: ! 22Jun11 - Jing Guo ! - Added optional PRESERVE= argument to preserve any ! unknown %-macro or any %-macro with missing value. ! 19Dec06 - Jing Guo ! - Merged changes between 1.1.2.6 and 1.1.2.9 to 1.2, ! including a fix at bug nymd==0 and environment ! variable ($env or ${env}) support if getenv() is ! available from the system. ! 01Jun99 - Jing Guo ! - initial prototype/prolog/code !EOP ___________________________________________________________________ character(len=*),parameter :: myname='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,preserve) 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 logical,intent(in ),optional :: preserve ! preserve macro if there is no corresponding input ! !REVISION HISTORY: ! 03Jun99 - Jing Guo ! - initial prototype/prolog/code ! 08Jan01 - da Silva: moved uppercase() to outside select() to ! avoid coredump on Linux/PGI. !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::strTemplate_' character(len=16) :: tmpl_class,uc_class tmpl_class="GX" if(present(class)) tmpl_class=class uc_class=uppercase(tmpl_class) select case(uc_class) case("GX","GRADS") call GX_(str,tmpl,xid=xid,nymd=nymd,nhms=nhms,stat=stat,preserve=preserve) !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,preserve) 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 logical,optional,intent(in ) :: preserve ! preserve macro if there is no corresponding input ! !REVISION HISTORY: ! 01Jun99 - Jing Guo ! - initial prototype/prolog/code !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 integer :: ier logical :: preserve_ character(len=1) :: c0,c1,c2 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 !________________________________________ preserve_=.false. if(present(preserve)) preserve_=preserve !________________________________________ 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 ("$") call genv_(tmpl,ln_tmpl,i,istp,str,ln_str,k,ier) if(ier/=0) then call perr(myname_,'genv_("'//tmpl(i:ln_tmpl)//'"',ier) if(.not.present(stat)) call die(myname_) stat=1 return endif case ("%") !________________________________________ c1="" i1=i+1 if(i1 <= ln_Tmpl) c1=tmpl(i1:i1) !________________________________________ select case(c1) case("s") if(.not.present(xid)) then if(preserve_) then istp=2 m=k+len(c1) str(k:m)=c0//c1 k=m+1 cycle endif 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("%","$") if(preserve_) then istp=2 m=k+len(c1) str(k:m)=c0//c1 k=m+1 cycle endif istp=2 str(k:k)=c1 k=k+1 ! kstp=1 cycle case default c2="" i2=i+2 if(i2 <= ln_Tmpl) c2=tmpl(i2:i2) !________________________________________ select case(c1//c2) case("y4","y2","m1","m2","mc","Mc","MC","d1","d2") if(.not.present(nymd)) then if(preserve_) then istp=3 m=k+len(c1)+len(c2) str(k:m)=c0//c1//c2 k=m+1 cycle endif 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 if(preserve_) then istp=3 m=k+len(c1)+len(c2) str(k:m)=c0//c1//c2 k=m+1 cycle endif write(stderr,'(2a)') myname_, & ': optional argument expected, "nhms="' if(.not.present(stat)) call die(myname_) stat=1 return endif istp=3 case default if(preserve_) then istp=2 m=k+len(c1) str(k:m)=c0//c1 k=m+1 cycle endif 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 contains subroutine genv_(tmpl,lnt,i,istp,str,lns,k,ier) implicit none character(len=*),intent(in) :: tmpl integer,intent(in) :: lnt integer,intent(in) :: i integer,intent(out) :: istp character(len=*),intent(inout) :: str integer ,intent(in) :: lns integer ,intent(inout) :: k integer,intent(out) :: ier integer :: j,jb,je integer :: l,m logical :: bracket,more character(len=256) :: env j=i+1 ! skip "$" ier=0 if(j>lnt) then ier=1 return endif bracket = tmpl(j:j)=='{' if(bracket) j=j+1 ! There is at least one a letter (including "_") to start a ! variable name select case(tmpl(j:j)) case ("A":"Z","a":"z","_") case default ier=2 return end select jb=j je=j if(bracket) then more=.true. do while(more) select case(tmpl(j:j)) case ("A":"Z","a":"z","_","0":"9") je=j j=j+1 case ("}") ! End if "}" or eos j=j+1 exit case default ier=3 return end select more=j<=lnt enddo else more=.true. do while(more) select case(tmpl(j:j)) case ("A":"Z","a":"z","_","0":"9") je=j j=j+1 case default exit end select more=j<=lnt enddo endif istp=j-i call getenv(tmpl(jb:je),env) l=len_trim(env) m=min(k+l-1,lns) str(k:m)=env k=m+1 end subroutine genv_ end subroutine GX_ end module m_StrTemplate