182 lines
5.4 KiB
Fortran
182 lines
5.4 KiB
Fortran
c =====================================================================
|
|
c pgm: uffch (chin,iptr,iwidth,chout,nxt,istat)
|
|
c
|
|
c in: chin .... character input array
|
|
c in: iptr .... beginning position in chin
|
|
c in: iwidth .... number of characters in output array
|
|
c out: chout .... character output array
|
|
c out: nxt .... starting position for next field
|
|
c out: istat .... completion status:
|
|
c 0 = valid field
|
|
c 1 = no field
|
|
c 2 = null field
|
|
c =====================================================================
|
|
c
|
|
subroutine uffch (chin,iptr,iwidth,chout,nxt,istat)
|
|
c
|
|
c......................................................................
|
|
c.
|
|
c Decode and move free format character field starting at position
|
|
c iptr in character input array chin to character output array chout
|
|
c of width iwidth. Starting position of next field is nxt.
|
|
c
|
|
c delimiters:
|
|
c fields with no embedded spaces (sp) and with
|
|
c or without slash / or apostrophe ': spaces, comma, or colon
|
|
c fields with embedded spaces: ' or : or / or []
|
|
c
|
|
c delimiter allowed characters
|
|
c no embedded spaces sp , : / '
|
|
c
|
|
c with embedded spaces: ' apos / , : [] sp
|
|
c / '
|
|
c , comma / ' : [] sp
|
|
c : / ' [] sp
|
|
c [] / ' , : sp
|
|
c.......................................................................
|
|
c initially written by
|
|
c Tim Sweeney, HRL March 1996
|
|
c
|
|
c added comma and colon delimiter
|
|
c Tim Sweeney, HRL May 2000
|
|
|
|
c.......................................................................
|
|
c
|
|
include 'ffg_inc/iuws'
|
|
c
|
|
character*1 iap/''''/
|
|
character chin*(*),chout*(*)
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob72/wfo_rfc/precip_proc/source/gribit/src/RCS/uffch.f,v $
|
|
. $', '
|
|
.$Id: uffch.f,v 1.1 2006/05/03 13:43:59 gsood Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
C
|
|
c
|
|
call prbug ('uffch',1,4,ibug)
|
|
ccc ibug = 1
|
|
c
|
|
if (ibug.eq.1) write (iutw,*) 'enter uffch'
|
|
c
|
|
c initial values
|
|
i = iptr
|
|
k = 0
|
|
is = 0
|
|
iapos = 0
|
|
islnt = 0
|
|
icomma = 0
|
|
icolon = 0
|
|
ibrac = 0
|
|
ident = 0
|
|
istat = 0
|
|
non = 10
|
|
c
|
|
10 if (i.gt.60) non = iwidth
|
|
c
|
|
if (chin(i:i).eq.' ') then
|
|
if (k.eq.0) then
|
|
ident = ident + 1
|
|
i = i + 1
|
|
if (ibug.eq.1) write (iutw,*) 'in uffch - ident=',ident
|
|
if (ident.le.non) go to 10
|
|
nxt = i
|
|
istat = 1
|
|
go to 60
|
|
else if (k.ne.0) then
|
|
if (is.eq.0) go to 40
|
|
if (is.eq.1) go to 20
|
|
endif
|
|
else if (chin(i:i).eq.iap.and.iapos.eq.0) then
|
|
is = is + 1
|
|
islnt = 1
|
|
icomma = 1
|
|
icolon = 1
|
|
ibrac = 1
|
|
else if (chin(i:i).eq.'/'.and.islnt.eq.0) then
|
|
is = is + 1
|
|
iapos = 1
|
|
else if (chin(i:i).eq.','.and.icomma.eq.0) then
|
|
if (k.eq.0) then
|
|
is = 1
|
|
iapos = 1
|
|
islnt = 1
|
|
icolon = 1
|
|
ibrac = 1
|
|
else
|
|
is = 2
|
|
i = i - 1
|
|
endif
|
|
else if (chin(i:i).eq.':'.and.icolon.eq.0) then
|
|
if (k.eq.0) then
|
|
is = 1
|
|
iapos = 1
|
|
islnt = 1
|
|
icomma = 1
|
|
ibrac = 1
|
|
else
|
|
is = 2
|
|
i = i - 1
|
|
endif
|
|
else if (chin(i:i).eq.'['.and.ibrac.eq.0) then
|
|
is = 1
|
|
iapos = 1
|
|
islnt = 1
|
|
else if (chin(i:i).eq.']'.and.ibrac.eq.0) then
|
|
is = is + 1
|
|
else
|
|
go to 20
|
|
endif
|
|
c
|
|
c the k.eq.0 to handle embedded ' or / with no embedded spaces
|
|
if (is.eq.1.and.k.eq.0) go to 30
|
|
if (is.eq.2) go to 40
|
|
c
|
|
c valid character
|
|
20 k = k + 1
|
|
if (ibug.eq.1) write (iutw,*) 'in uffch - k=',k
|
|
chout(k:k) = chin(i:i)
|
|
ident = 0
|
|
c
|
|
c increment position in input array
|
|
30 if (k.lt.iwidth) then
|
|
i = i + 1
|
|
go to 10
|
|
endif
|
|
c
|
|
40 nxt = i + 1
|
|
if (chin(i+1:i+1).eq.iap) nxt = nxt + 1
|
|
if (ibug.eq.1) write (iutw,*) 'in uffch - k=',k,' iwidth=',iwidth
|
|
if (k.ge.iwidth) go to 60
|
|
c
|
|
c fill right with spaces
|
|
if (k.gt.0) then
|
|
ixs = 0
|
|
k = k + 1
|
|
do 50 j=k,iwidth
|
|
chout(j:j) = ' '
|
|
c search for next non-blank character for next field
|
|
i = i + 1
|
|
if (ixs.gt.0) go to 50
|
|
if (chin(i:i).eq.' ') then
|
|
nxt = i
|
|
else
|
|
nxt = i
|
|
ixs = 1
|
|
endif
|
|
50 continue
|
|
else
|
|
c null field
|
|
istat = 2
|
|
endif
|
|
c
|
|
60 if (ibug.eq.1) write (iutw,*) 'exit uffch - iptr=',iptr,
|
|
+ ' iwidth=',iwidth,' nxt=',nxt,' chout=',chout(1:iwidth),
|
|
+ ' istat=',istat
|
|
c
|
|
return
|
|
c
|
|
end
|