GX_
- evaluate a GrADS style string template
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
character(len=*), | intent(out) | :: | str | |||
character(len=*), | intent(in) | :: | tmpl | |||
character(len=*), | intent(in), | optional | :: | xid | ||
integer, | intent(in), | optional | :: | nymd | ||
integer, | intent(in), | optional | :: | nhms | ||
integer, | intent(out), | optional | :: | stat |
subroutine GX_(str,tmpl,xid,nymd,nhms,stat) 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 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 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 !________________________________________ 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 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)=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 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 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 get_environment_variable(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_