C Copyright(c) 1998, Space Science and Engineering Center, UW-Madison C Refer to "McIDAS Software Acquisition and Distribution Policies" C in the file mcidas/data/license.txt C *** $Id: readsort.f,v 1.20 2012/09/06 17:43:15 scottl Tst $ *** *$ Name: *$ m0readsort - read in the sort conditions and put them in *$ the appropriate sort array *$ *$ Interface: *$ INTEGER FUNCTION m0readsort (parms,numparm,nph,numderv, *$ thisderv,lev,numlev,levunit,numlevunit,vt,numvt, *$ numdays,days,numtime,times, *$ numsrc,src,fday,ftime,numpro,cpro,numens,ens,startgrid, *$ stopgrid,uvflag,getbygrid,holdnum,ngrids_toget) *$ *$ Input: *$ none *$ *$ Input and Output: *$ none *$ *$ Output: *$ parms ! array of parameter to search for *$ numparm ! number of entries in parms array *$ numparm_h ! number of entries in parms array (constant) *$ numderv ! number of parameters to derive *$ thisderv ! parameter to derive *$ lev ! array of level to search for *$ numlev ! number of entries in lev array *$ levunit ! array of level units to search for *$ numlevunit ! number of entries in levunit array *$ vt ! array of valid times (fhours) to search for *$ numvt ! number of entries in vt array *$ days ! array of days to search for *$ numdays ! number of entries in days array *$ times ! array of times to search for *$ numtimes ! number of entries in times array *$ src ! array of grid source to search for *$ numsrc ! number of entries in src array *$ fday ! forecast day to search for, or -1 if none *$ ftime ! forecast time to search for, or -1 if none *$ cpro ! array of projections to search for *$ numpro ! number of entries in cpro array *$ ens ! array of grid ensemble values to search for *$ numens ! number of entries in ens array *$ startgrid ! grid number to start search at (GRID=) *$ stopgrid ! grid number to end search at (GRID=) *$ uvflag ! set to 1 if (u,v) pair needed *$ getbygrid ! flag if GRID= is used *$ holdnum ! number of grids requested *$ ngrids_toget ! number of grids to get (altered if DER= used) *$ *$ *$ Return values: *$ 0 - success *$ -1 - failed reading in GRID keywords *$ -2 - Failed reading PARAMETER keyword *$ -4 - Failed reading DERIVED keyword *$ -5 - Unknown derivable parameter *$ -6 - Mixed DERIVED and PARM requests *$ -7 - Failed reading LEV keyword *$ -8 - Failed reading VT keyword *$ -9 - Failed reading FRANGE keyword *$ -10 - FRANGE input results in too many FHOURS *$ -11 - Failed reading DAY keyword *$ -12 - Failed reading DRANGE keyword *$ -13 - DRANGE input results in too many DAYS *$ -14 - Failed reading TIME keyword *$ -15 - Failed reading TRANGE keyword *$ -16 - TRANGE input results in too many TIMES *$ -17 - Failed reading SRC keyword *$ -18 - Failed reading FDAY keyword *$ -19 - Failed reading FTIME keyword *$ -20 - Number of parameters/levels/etc. exceeds maximum *$ -21 - Failed reading PRO keyword *$ -22 - Failed reading in NUM keyword *$ -23 - numlevunit not equal to numlev *$ -24 - could not re-sort level units *$ -25 - Failed reading in ENS keyword *$ *$ Remarks: *$ This function reads in the sort clauses from the command line *$ in the server and puts them in the arrays for subsequent use *$ in mcfndgrd. *$ *$ Categories: *$ grid INTEGER FUNCTION m0readsort (parms,numparm,numparm_h,numderv, & thisderv,lev,numlev,levunit,numlevunit,vt,numvt,numdays, & days,numtime,times, & numsrc,src,fday,ftime,numpro,cpro,numens,ens,startgrid, & stopgrid,uvflag,getbygrid,holdnum,ngrids_toget) implicit none include 'gridparm.inc' include 'm0gadde.inc' integer numuv parameter(numuv=3) integer maxfiles parameter(maxfiles=1000) character*12 parms(maxsort) ! array of parms to search character*12 src(maxsort) ! array of sources for search character*12 ens(maxsort) ! array of ensembles for search character*12 cpro(maxsort) ! projection(s) of grid, PRO keyword character*12 thisderv ! parameter to derive integer holdnum ! hold number integer numdays ! number of elements in day array integer numderv ! number of elements in derive array integer numens ! number of elements in ens array integer numlev ! number of elements in lev array integer numlevunit ! number of elements in levunit array integer numparm ! number of elements in parm array integer numparm_h ! number of elements in parm array integer numsrc ! number of elements in source array integer numtime ! number of elements in time array integer numpro ! number of elements in cpro array integer numvt ! number of elements in vt array integer getbygrid ! 0 if GRID= not used integer lev(maxsort) ! array of levels to search for integer levunit(maxsort) ! array of level units to search for integer days(maxday) ! array of days to search for integer times(maxtime) ! array to hold times for search integer vt(maxvt) ! array containing valid times integer ngrids_toget ! number of grids to get C**** External Functions **** character*12 cfr character*4 clit integer iftok ! get an integer token integer isdgch ! is char string a digit or character? integer lit ! integer representation of char string integer m0chkpar ! check parameters for derived qtys integer m0resort ! re-sort level units integer m0stndrd ! makes derived parameters standard integer mcargint ! integer arg fetcher integer mcargnum ! argument counter integer mccydtoiyd ! convert ccyyddd to yyyddd integer mcargstr ! string arg fetcher integer mcinctime ! increment a time integer mcincday ! increment a day integer mcstrtodbl C--local variables character*4 allval ! char value from ALL keyword character*8 uvchar(numuv) ! names of variables that need (u,v) character*12 clev ! character value of LEV keyword character*12 dervp ! parameter to derive character*12 thisens ! ensemble being picked off argument list character*12 thisparm ! parm being picked off argument list character*12 thissrc ! source being picked off argument list character*256 argdum ! dummy string for arg fetchers integer allkey ! flag to indicate ALL was specified integer bday ! beginning day of range integer btime ! beginning time of range integer bvt ! beginning vt of range integer dinc ! increment for day range integer eday ! ending day of range integer etime ! ending time of range integer evt ! ending vt of range integer fday ! forecast day integer ftime ! forecast time integer i ! counter integer iret ! return status integer j ! counter integer levorig(maxsort) ! array of levels to search for integer rc ! value this function will return integer startgrid ! grid number to begin igget with integer stopgrid ! grid number to end igget with integer tdum ! dummy time for mcinctime call integer temp_day ! temporary day integer temp_fday ! temporary fday integer thisday ! day being picked off argument list integer thistime ! time being picked off argument list integer thisvt ! vt being picked off argument list integer tinc ! increment for time range integer uvflag ! flag = 1 if STREAML, WINDV, or WINDB integer vtinc ! increment for vt range integer ydum1 ! dummy julian day for mcinctime integer ydum2 ! dummy julian day for mcinctime double precision dval data uvchar/'STREAML ','WINDV ','WINDB '/ startgrid = 99999999 stopgrid = -999999990 getbygrid = 0 uvflag = 0 rc = 0 getbygrid=mcargnum(0, 'GRI.D') if (getbygrid .gt. 0) then C**** set a flag, then we can bypass mcfndgrd, and go right to C**** igget getbygrid=1 iret=mcargint(0,'GRI.D',1,1,1,0,startgrid,argdum) if (iret .lt. 0) then rc = -1 goto 2001 endif iret=mcargint(0,'GRI.D',2,startgrid,1,0,stopgrid,argdum) if (iret .lt. 0) then rc = -1 goto 2001 endif endif C**** PARM(s) numparm=mcargnum(0, 'PAR.M') numparm_h = numparm if (numparm .gt. maxsort) then rc = -20 goto 2001 endif if (numparm .gt. 0) then C**** Pick up the parameters and put them onto the parms array do 10 i=1,numparm iret=mcargstr(0, 'PAR.M', i, ' ', thisparm) if (iret .lt. 0) then rc = -2 goto 2001 endif parms(i)=thisparm C C C***** Check to see if PARM is STREAML, WINDB or WINDV; change parm string C***** and set uvflag if appropriate C do 8 j = 1,numuv if (thisparm(1:5) .eq. uvchar(j)(1:5)) then parms(i) = 'U ' uvflag = 1 endif 8 continue 10 continue endif C**** DERIVED parameter numderv=mcargnum(0, 'DER.IVE') if (numderv .gt. 1) then rc = -20 goto 2001 elseif (numderv .eq. 1) then i = 1 C**** Pick up the parameter and put it into the derv array iret=mcargstr(0, 'DER.IVE', 1, ' ', thisderv) if (iret .lt. 0) then rc = -4 goto 2001 endif iret = m0stndrd(thisderv, dervp) call m0sxtrce('server looks for '//dervp) if (iret .lt. 0) then rc = -5 goto 2001 endif thisderv = dervp C**** do not allow a PARM entry different from the DERIVE entry if (numparm.gt.1 .or. & (numparm.eq.1 .and. thisparm.ne.thisderv) ) then rc = -6 goto 2001 endif C**** call m0chkpar to determine constituent grids of derived parameter if (numparm.gt.0) then iret = m0chkpar (dervp, 2, parms, numparm) else iret = m0chkpar (dervp, 1, parms, numparm) endif endif C**** LEV(s) numlev=mcargnum(0,'LEV') if (numlev .gt. maxsort) then rc = -20 goto 2001 endif if (numlev .gt. 0) then C**** Pick up the parameters and put them into the levs array do 20 i=1,numlev iret=mcargstr(0,'LEV',i,' ',clev) call m0sxtrce('level is'//clev//cfr(iret)) if (iret .lt. 0) then rc = -7 goto 2001 endif C**** If the level is a character (there are a few), we C**** pass the lit of it, otherwise, we pass the numeric if (isdgch(clev).eq.-1.or.isdgch(clev).eq.0) then C***account for special cases! if (clev(1:4) .eq. 'SFC ') then lev(i) = 1001 elseif (clev(1:4) .eq. 'MSL ') then lev(i) = 1013 elseif (clev(1:4) .eq. 'TRO ') then lev(i) = 0 elseif (clev(1:4) .eq. ' ') then C**Not sure that this could even happen, but..... lev(i) = 999 else lev(i)=lit(clev) endif else C C clev *might* be a real number with a decimal point (in which C case isdgch will return -999) C if (mcstrtodbl(clev,dval) .eq. 200) then lev(i) = lit(clev) else lev(i)=iftok(clev) endif endif if (iret .eq. 0) then ! default returned lev(i) = lit('X') endif levorig(i) = lev(i) 20 continue call m0sortf(lev,numlev,-1) endif C**** LEVUNIT(s) numlevunit=mcargnum(0,'UNIT') if (numlevunit .gt. maxsort) then rc = -20 goto 2001 endif if (numlevunit .gt. 0) then C**** Pick up the parameters and put them into the levs array do 25 i=1,numlevunit iret=mcargstr(0,'UNIT',i,'X',clev) if (iret .lt. 0) then rc = -7 goto 2001 endif levunit(i) = lit(clev) 25 continue if (numlevunit .ne. numlev) then rc = -23 goto 2001 endif C**** LEV may not have the levels in the same order they were C entered....resort puts the leveunit array so that the C order in levunit matches the order in lev iret = m0resort(levunit,numlevunit,lev,levorig) if (iret .lt. 0) then rc = -24 goto 2001 endif endif C**** VT(s) numvt=mcargnum(0,'VT') if (numvt .gt. maxsort) then rc = -20 goto 2001 endif if (numvt .gt. 0) then C**** Pick up the parameters and put them into the vt array do 30 i=1, numvt iret=mcargint(0,'VT',i,0,1,0,thisvt,argdum) if (iret .lt. 0) then rc = -8 goto 2001 endif thisvt = thisvt/10000 vt(i)=thisvt 30 continue call m0sortf (vt, numvt,-1) endif C**** ENS(s) numens=mcargnum(0,'ENS') if (numens .gt. maxsort) then rc = -20 goto 2001 endif if (numens .gt. 0) then C**** Pick up the parameters and put them into the vt array do 3330 i=1, numens iret=mcargstr(0,'ENS',i,'X',thisens) if (iret .lt. 0) then rc = -25 goto 2001 endif ens(i)=thisens 3330 continue endif C**** FRANGE if (mcargnum(0, 'FRA.NGE') .gt. 0) then iret=mcargint(0,'FRA.NGE',1,0,1,0,bvt,argdum) if (iret .lt. 0) then rc = -9 goto 2001 endif iret=mcargint(0,'FRA.NGE',2,bvt,1,0,evt,argdum) if (iret .lt. 0) then rc = -9 goto 2001 endif iret=mcargint(0,'FRA.NGE',3,1,1,0,vtinc,argdum) if (iret .lt. 0) then rc = -9 goto 2001 endif bvt = bvt/10000 evt = evt/10000 vtinc = vtinc/10000 i=1 thisvt=bvt 40 continue vt(i)=thisvt thisvt=thisvt+vtinc i=i+1 if (i .gt. maxvt) then rc = -10 goto 2001 endif if (thisvt .le. evt)goto 40 numvt=i-1 call m0sortf(vt,numvt,-1) endif numdays=mcargnum(0,'DAY') if (numdays .gt. maxsort) then rc = -20 goto 2001 endif if (numdays .gt. 0) then C**** Pick up the parameters and put them into days array C**** Change the day being stored to iyd do 45 i=1, numdays iret=mcargint(0,'DAY',i,0,1,0,thisday,argdum) if (iret .lt. 0) then rc = -11 goto 2001 endif C iret=mccydtoiyd(thisday,temp_day) C thisday=temp_day C if this is uncommented, xcd will break days(i)=thisday 45 continue call m0sortf (days,numdays,-1) endif C**** DRANGE if (mcargnum(0,'DRA.NGE') .gt. 0) then iret=mcargint(0,'DRA.NGE',1,0,1,0,bday,argdum) if (iret .lt. 0) then rc = -12 goto 2001 endif iret=mcargint(0,'DRA.NGE',2,bday,1,0,eday,argdum) if (iret .lt. 0) then rc = -12 goto 2001 endif iret=mcargint(0,'DRA.NGE',3,1,1,0,dinc,argdum) if (iret .lt. 0) then rc = -12 goto 2001 endif i=1 thisday=bday 50 continue iret=mccydtoiyd(thisday,temp_day) days(i)=temp_day iret=mcincday(thisday,dinc,temp_day) thisday=temp_day i=i+1 if (i .gt. maxday) then rc = -13 goto 2001 endif if (thisday .le. eday)goto 50 numdays=i-1 call m0sortf(days,numdays,-1) endif numtime=mcargnum(0,'TIM.E') if (numtime .gt. maxsort) then rc = -20 goto 2001 endif if (numtime .gt. 0) then C**** Pick up the parameters and put them into time array do 55 i=1, numtime iret=mcargint(0,'TIM.E',i,0,1,0,thistime,argdum) if (iret .lt. 0) then rc = -14 goto 2001 endif times(i)=thistime 55 continue call m0sortf (times,numtime,-1) endif C**** TRANGE C****These are picked up using mcargint because they are picked up C using mccmdihr in the application and are passed down in hhmmss C format if (mcargnum(0,'TRA.NGE') .gt. 0) then iret=mcargint(0,'TRA.NGE',1,0,1,0,btime,argdum) if (iret .lt. 0) then rc = -15 goto 2001 endif iret=mcargint(0,'TRA.NGE',2,btime,1,0,etime,argdum) if (iret .lt. 0) then rc = -15 goto 2001 endif iret=mcargint(0,'TRA.NGE',3,1,1,0,tinc,argdum) if (iret .lt. 0) then rc = -15 goto 2001 endif i=1 ydum1 = 1996300 thistime=btime 58 continue times(i)=thistime iret = mcinctime(ydum1,thistime,tinc,ydum2,tdum) if (iret .lt. 0) then rc = -16 goto 2001 endif thistime = tdum i=i+1 if (i .gt. maxtime) then rc = -16 goto 2001 endif c---if ydum1/ydum2 are unequal, have wrapped to next day. if (thistime.le.etime .and. ydum1.eq.ydum2)goto 58 numtime=i-1 call m0sortf(times,numtime,-1) endif C**** Source (model) numsrc=mcargnum(0,'SRC') if (numsrc .gt. maxsort) then rc = -20 goto 2001 endif if (numsrc .gt. 0) then C**** Pick up the parameters and put them into the src array do 60 i=1, numsrc iret=mcargstr(0,'SRC',i,' ',thissrc) if (iret .lt. 0) then rc = -17 goto 2001 endif src(i)=thissrc 60 continue endif C**** Pick up the forecast hour and time, to validate the grid C**** directory for a match. The default will be a -1 to flag C**** that no keyword was specified, thus no matching needs to be C**** done. iret=mcargint(0,'FDAY',1,-1,1,0,fday,argdum) if (iret .lt. 0) then rc = -18 goto 2001 endif C**** Get fday in yyyddd C if(fday.ne.-1) then C iret=mccydtoiyd(fday,temp_fday) C fday=temp_fday C endif iret=mcargint(0,'FTI.ME',1,-1,1,0,ftime,argdum) if (iret .lt. 0) then rc = -19 goto 2001 endif C**** Pick up the grid projection...The default of -1 is used to C**** flag that no projection was specified, hence no checking of C**** the parameter needs to be done. numpro = mcargnum(0,'PRO') do 600 i = 1,numpro iret = mcargstr(0,'PRO',i,'-1',cpro(i)) if (iret .lt. 0) then rc = -21 goto 2001 endif 600 continue if (numpro .lt. maxsort) cpro(numpro+1) = '-1' C**** ALL keyword -YES send all matching grids, NO, send first one to match holdnum = 1 ngrids_toget = 1 allkey=mcargnum(0,'NUM') if (allkey .ne. 0) then iret=mcargstr(0,'NUM',1,'ALL',allval) if (iret .lt. 0) then rc = -22 goto 2001 endif if (isdgch(allval) .eq. -1) then if (allval .eq. 'ALL') then ngrids_toget =99999 holdnum = 99999 endif else iret=mcargint(0,'NUM',1,1,1,0,ngrids_toget,argdum) holdnum = ngrids_toget if (iret .lt. 0) then rc = -22 goto 2001 endif endif endif C**** change num_requested if DERIVE is specified... if (numderv .gt. 0) ngrids_toget = 99999 2001 continue m0readsort = rc return end *$ Name: *$ m0readsub - read in subsecting information for server *$ *$ Interface: *$ integer function *$ m0readssub(brow,bcol,erow,ecol,incrow,inccol,numsub) *$ *$ Input: *$ none *$ *$ Input and Output: *$ none *$ *$ Output: *$ brow | begin row for subsecting *$ bcol ! begin column for subsecting *$ erow | end row for subsecting *$ ecol ! end column for subsecting *$ incrow ! row increment for subsecting *$ inccol ! column increment for subsecting *$ llswitch ! lat/lon or row/col subsecting *$ numsub ! number of entries with SUBSECT keyword *$ *$ *$ Return values: *$ 0 - success *$ -1 - wrong number of keywords with SUBSECT *$ -2 - invalid keyword value *$ *$ Remarks: *$ Pick up the row/col information needed for subsecting *$ *$ Categories: *$ grid integer function m0readsub(brow,bcol,erow,ecol, & incrow,inccol,llswitch,numsub) implicit none double precision brow ! begin row double precision bcol ! begin column double precision erow ! end row double precision ecol ! end column integer incrow ! row increment integer inccol ! col increment integer llswitch ! lat/lon or row/col fetch? integer numsub ! number of subsect keyword entries integer mcargint ! get int via arg fetcher integer mcargnum ! get number of keywords integer mcargdbl ! get double precision via arg fetcher integer mcargstr ! get string via arg fetcher character*12 cfr ! convert integer to string character*256 argdum ! dummy arg for fetchers character*12 llchar ! lat/lon row/col flag integer iret ! function call return code integer rc ! return code rc = 0 C---set defaults for brow,erow,bcol,ecol and incrow/inccol in case C the client is old and is not sending a SUBSET keyword! brow = 1.D0 bcol = 1.D0 erow = 999999.D0 ecol = 999999.D0 incrow = 1 inccol = 1 llswitch = 1 numsub = mcargnum(0,'SUBSET') call m0sxtrce('XXXXnumsub is '//cfr(numsub)) if (numsub .eq. 7) then iret = mcargstr(0,'SUBSET',7,'LATLON',llchar) if (llchar(1:6) .eq. 'ROWCOL') llswitch = 1 if (llchar(1:6) .eq. 'LATLON') then brow = -90. erow = 90. bcol = -180. ecol = 180. llswitch = 0 endif if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargdbl(0,'SUBSET',1,brow,1.D0,0.D0,brow,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargdbl(0,'SUBSET',2,erow,1.D0,0.D0,erow,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargdbl(0,'SUBSET',3,bcol,1.D0,0.D0,bcol,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargdbl(0,'SUBSET',4,ecol,1.D0,0.D0,ecol,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargint(0,'SUBSET',5,1,1,0,incrow,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif iret = mcargint(0,'SUBSET',6,1,1,0,inccol,argdum) if (iret .lt. 0) then rc = -2 goto 2001 endif else if (numsub .ne. 0) then rc = -1 goto 2001 endif endif 2001 m0readsub = rc return end *$ Name: *$ m0readpars - modify the sort conditions based on the parsing *$ keyword *$ *$ Interface: *$ INTEGER FUNCTION m0readpars (parms,numparm,numderv,lev,numlev, *$ levunit,numlevunit,vt,numvt,numday,days,numtime,times, *$ numsrc,src,fday,ftime,numgproj,cpro,numgrib,gribgeo, *$ gribpar,gribmdl,griblvl,numens,ens,bgrid,egrid,uvflag,ngrids_to_get, *$ pnum,cparstr,getbygrid,startgrid,stopgrid) *$ *$ Input: *$ none *$ *$ Input and Output: *$ parms ! array of parameter to search for *$ numparm ! number of entries in parms array *$ numderv ! number of parameters to derive *$ lev ! array of level to search for *$ numlev ! number of entries in lev array *$ levunit ! array of level units to search for *$ numlevunit ! number of entries in levunit array *$ vt ! array of valid times (fhours) to search for *$ numvt ! number of entries in vt array *$ days ! array of days to search for *$ numday ! number of entries in days array *$ times ! array of times to search for *$ numtimes ! number of entries in times array *$ src ! array of grid source to search for *$ numsrc ! number of entries in src array *$ fday ! forecast day to search for, or -1 if none *$ ftime ! forecast time to search for, or -1 if none *$ cpro ! array of projections to search for *$ numgproj ! number of entries in proj array *$ numgrib ! number of entries in grib* arrays *$ gribgeo ! geographic GRIB values to search for *$ gribpar ! parameter GRIB values to search for *$ gribmdl ! model GRIB values to search for *$ griblvl ! level GRIB values to search for *$ numens ! number of entries in ens array *$ ens ! ensemble values to search for *$ bgrid ! begin gridfile *$ egrid ! end gridfile *$ uvflag ! set to 1 if (u,v) pair needed *$ ngrids_toget ! number of grids to get *$ pnum ! number of grids needed to parse *$ cparstr ! array of individual parse strings *$ startgrid ! start grid to get *$ stopgrid ! stop grid to get *$ *$ Output: *$ getbygrid ! 1 if GRID= is used in parsing clauses *$ *$ Return values: *$ 0 - success *$ -1 - error reading PNUM keyword *$ -2 - Too many arguments with PNUM *$ -3 - error reading PARSE keyword *$ -4 - failure in m0parstr: sort condition introduced *$ after first keyword *$ -5 - failure in m0parstr: could not parse string *$ -6 - specified GRID without explicit position number in *$ dataset *$ -10 - Too many levels specified in parse selects *$ -11 - Too many parameters specified in parse selects *$ -12 - Too many times specified in parse selects *$ -13 - Too many days specified in parse selects *$ -14 - Too many fhours specified in parse selects *$ -15 - Too many srcs specified in parse selects *$ -16 - Too many fdays specified in parse selects *$ -17 - Too many ftimes specified in parse selects *$ -18 - Too many grid projections specified in parse selects *$ -19 - Too many level units specified in parse selects *$ -20 - Too many grib values specified in parse selects *$ -21 - Too many ensemble values specified in parse selects *$ -40 - a parse string was empty *$ *$ Remarks: *$ This function processes the information in the parsing clause *$ *$ Categories: *$ grid INTEGER FUNCTION m0readpars (parms,numparm,lev,numlev, & levunit,numlevunit,vt,numvt,numdays,days,numtime,times, & numsrc,src,fday,ftime,numgproj,cpro,numgrib, & gribgeo,gribpar,gribmdl,griblvl,numens,ens,bgrid, & egrid,ngrids_toget,pnum,cparstr,getbygrid,startgrid, & stopgrid) implicit none include 'm0gadde.inc' include 'gridparm.inc' character*12 parms(maxsort) ! array of parms to search character*12 ens(maxsort) ! array of ensembles to search for character*12 src(maxsort) ! array of sources for search character*12 cpro(maxsort) ! projection(s) character*(*) cparstr(*) ! array of parse strings integer numgproj ! number of projections integer numdays ! number of elements in day array integer numens ! number of elements in ensemble array integer numgrib ! number of elements in grib arrays integer numlev ! number of elements in lev array integer numlevunit ! number of elements in levunit array integer numparm ! number of elements in parm array integer numsrc ! number of elements in source array integer numtime ! number of elements in time array integer numvt ! number of elements in vt array integer getbygrid ! 0 if GRID= not used integer gribgeo(maxsort) ! array of geo grib #s to search for integer gribpar(maxsort) ! array of par grib #s to search for integer gribmdl(maxsort) ! array of mdl grib #s to search for integer griblvl(maxsort) ! array of lvl grib #s to search for integer lev(maxsort) ! array of levels to search for integer levunit(maxsort) ! array of level units to search for integer days(maxday) ! array of days to search for integer times(maxtime) ! array to hold times for search integer vt(maxvt) ! array containing valid times integer pnum ! number of grids to be parsed integer bgrid ! begin gridfile integer egrid ! end gridfile integer ngrids_toget ! number of grids to get integer fday ! forecast day integer ftime ! forecast time integer startgrid ! startgrid to get integer stopgrid ! stopgrid to get integer m0parstrorder ! string for parsing integer mcargint ! read argument to integer integer mcargstr ! read argument to integer character*12 cfr character*80 errstring ! string to write to trace file character*256 argdum ! dummy argument for mcargstr integer grid ! grid number integer i ! loop bound integer iret ! return code from function call integer numftime ! number of FTIME entries integer numfday ! number of FDAY entries integer rc ! return code for this function call integer thislev ! this is the level in the parse string integer thislevu2 ! this is the level unit in the parse string integer thisparm ! this is the parameter integer thistime ! this is the time integer thisday ! this is the day integer thisens ! this is the ensemble integer thissrc ! this is the src integer thisvt ! this is the vt integer thisfday2 ! this is the fday integer thisftime2 ! this is the ftime integer thisgproj ! this is the ftime integer thisgrib ! this is the grib C**** Get PNUM to see if there are parse-able sort clauses to be C**** decoded... rc = 0 iret = mcargint(0,'PNU.M',1,0,1,0,pnum,argdum) if (iret .lt. 0) then rc = -1 goto 2001 endif if (pnum .gt. numpstr) then rc = -2 goto 2001 endif write(errstring,3111) numlev call m0sxtrce(errstring) if (pnum .gt. 0) then getbygrid = 0 C**** change num_requested to something BIG! ngrids_toget = 999999 C**** cycle through the PARSE keyword string, reading them in and C**** putting them through m0parstr to populate the sort strings. 3111 format('m0parstr returns ',i8) 3112 format(' numlev is ',i8) 3113 format(' numparm is ',i8) 3114 format(' numtime is ',i8) 3115 format(' numvt is ',i8) 3116 format(' numlevunit is ',i8) 3117 format(' numgrib is ',i8) 3118 format(' numens is ',i8) 3151 format(' a math select clause [G*] was empty') do 1120 i = 1,pnum iret = mcargstr(0,'PARSE',i,' ',cparstr(i)) if (iret .lt. 0) then rc = -3 goto 2001 endif call m0sxtrce('Parse the following') call m0sxtrce(cparstr(i)) C C trap for cases in which a user entered nothing in the C G* keyword, foolishly thinking that the defaults C would be enough C if (cparstr(i) .eq. '=') then write(errstring,3151) call m0sxtrce(errstring) rc = -40 goto 2001 endif iret = m0parstrorder(cparstr(i),numlev,lev,thislev, & numlevunit,levunit,thislevu2,numparm,parms,thisparm, & numtime,times,thistime,numdays,days,thisday,numvt, & vt,thisvt,numsrc,src,thissrc,numfday,fday,thisfday2, & numftime,ftime,thisftime2,numgproj,cpro(1),thisgproj, & numgrib,gribgeo,gribpar,gribmdl,griblvl,thisgrib, & numens,ens,thisens,grid,i) write(errstring,3111) iret call m0sxtrce(errstring) if (iret .lt. 0) then if (abs(mod(iret,100)) .eq. 6) then rc = -4 errstring = 'Sort conditions introduced after '// & 'first keyword ' else rc = -5 errstring = 'Bad format to string for parsing' endif goto 2001 endif if (numlev .gt. 0) then write(errstring,3112) numlev call m0sxtrce(errstring) endif if (numlevunit .gt. 0) then write(errstring,3116) numlevunit call m0sxtrce(errstring) endif if (numparm .gt. 0) then write(errstring,3113) numparm call m0sxtrce(errstring) endif if (numtime .gt. 0) then write(errstring,3114) numtime call m0sxtrce(errstring) endif if (numvt .gt. 0) then write(errstring,3115) numvt call m0sxtrce(errstring) endif if (numgrib .gt. 0) then write(errstring,3117) numgrib call m0sxtrce(errstring) endif if (numens .gt. 0) then write(errstring,3118) numens call m0sxtrce(errstring) endif C---If grid is returned from m0parstr as non-zero, the parsed string contained C a GRID= sort clause. Make sure that only one position has been C requested if so, and emit an error otherwise. if (grid .gt. -2 .and. bgrid .ne. egrid ) then rc = -6 goto 2001 endif C -- startgrids and stopgrid must contain the span of grids requested C by the parsing clauses; if GRID=LAST is used, then stopgrid C will be -1 call m0sxtrce('Grid found is '//cfr(grid)) if (grid .gt. -2) then getbygrid = 1 if (grid .ne. -1) then if (stopgrid .ne. -1) then if (grid .lt. startgrid) startgrid = grid if (grid .gt. stopgrid ) stopgrid = grid else if (grid .lt. startgrid) startgrid = grid endif else stopgrid = grid endif endif C---If PNUM > MAXSORT, then check the num* variables to make sure C they do not exceed MAXSORT. If pnum does not exceed maxsort, C then the num* variables cannot exceed maxsort since only C one entry per pnum is allowed if (pnum .gt. maxsort) then if (numlev .gt. maxsort) then rc = -10 goto 2001 endif if (numparm .gt. maxsort) then rc = -11 goto 2001 endif if (numtime .gt. maxsort) then rc = -12 goto 2001 endif if (numdays .gt. maxsort) then rc = -13 goto 2001 endif if (numvt .gt. maxsort) then rc = -14 goto 2001 endif if (numsrc .gt. maxsort) then rc = -15 goto 2001 endif if (numfday .gt. maxsort) then rc = -16 goto 2001 endif if (numftime .gt. maxsort) then rc = -17 goto 2001 endif if (numgproj .gt. maxsort) then rc = -18 goto 2001 endif if (numlevunit .gt. maxsort) then rc = -19 goto 2001 endif if (numgrib .gt. maxsort) then rc = -20 goto 2001 endif if (numens .gt. maxsort) then rc = -21 goto 2001 endif endif 1120 continue endif 2001 continue m0readpars = rc return end *$ Name: *$ m0errorout - fill the errstring/return code value based on the *$ program called and its return value *$ *$ Interface: *$ INTEGER FUNCTION m0readsub(character*(*) func, integer rc, *$ character*(*) errorstring) *$ *$ Input: *$ func ! function that created error *$ *$ Input and Output: *$ rc ! on input, error value from func; out output, *$ server error value *$ *$ Output: *$ errorstring ! error to be returned by server *$ *$ Return values: *$ 0 - success *$ *$ Remarks: *$ This function processes error return codes *$ *$ Categories: *$ grid integer function m0errorout(fname,rc,errstring) implicit none character*(*) fname ! function name that err'ed out integer rc ! value that function returned character*(*) errstring ! string for server to return m0errorout = 0 if (fname .eq. 'm0readsub') then if (rc .eq. -2) then errstring = 'Invalid keyword value in SUBSECT' elseif (rc .eq. -1) then errstring = 'Improper number of SUBSECT keywords' else errstring = 'Failure in reading SUBSECT keywords' endif rc = -21005 return elseif (fname .eq. 'm0readsort') then rc = -21002 if (rc .eq. -1) then errstring = 'Failed reading in GRID keywords' elseif (rc .eq. -2) then errstring = 'Failed reading PARAMETER keyword' elseif (rc .eq. -4) then errstring = 'Failed reading DERIVED keyword' elseif (rc .eq. -5) then errstring = 'Unknown DERIVABLE parameter' elseif (rc .eq. -6) then errstring = 'Mixed DERIVED and PARM requests' elseif (rc .eq. -7) then errstring = 'Failed reading LEV keyword' elseif (rc .eq. -8) then errstring = 'Failed reading VT keyword for FHOURS' elseif (rc .eq. -9) then errstring = 'Failed reading FRANGE keyword' elseif (rc .eq. -10) then errstring = 'FRANGE input results in too many FHOURS' elseif (rc .eq. -11) then errstring = 'Failed reading DAY keyword' elseif (rc .eq. -12) then errstring = 'Failed reading DRANGE keyword' elseif (rc .eq. -13) then errstring = 'DRANGE input results in too many DAYS' elseif (rc .eq. -14) then errstring = 'Failed reading TIME keyword' elseif (rc .eq. -15) then errstring = 'Failed reading TRANGE keyword' elseif (rc .eq. -16) then errstring = 'TRANGE input results in too many TIMES' elseif (rc .eq. -17) then errstring = 'Failed reading SRC keyword' elseif (rc .eq. -18) then errstring = 'Failed reading FDAY (forecast day) keyword' elseif (rc .eq. -19) then errstring = 'Failed reading FTIME (forecast time) keyword' elseif (rc .eq. -20) then errstring = 'Number of requested keywords exceeds maximum' elseif (rc .eq. -21) then errstring = 'Failed reading PRO keyword' elseif (rc .eq. -22) then errstring = 'Failed reading NUM keyword' elseif (rc .eq. -25) then errstring = 'Failed reading ENS keyword' else errstring = 'Failed to read in keywords in server string' endif rc = -21005 return elseif (fname .eq. 'm0readpars') then if (rc .eq. -1) then errstring = 'Failed reading PNUM keyword' elseif (rc .eq. -2) then errstring = 'Too many arguments with PNUM' elseif (rc .eq. -3) then errstring = 'Error reading PARSE keyword' elseif (rc .eq. -4) then errstring = 'New sort condition introduced after '// & 'first G* keyword' elseif (rc .eq. -5) then errstring = 'Bad format for string in G* keyword' elseif (rc .eq. -6) then errstring = 'GRID requested without explicit POSITION'// & ' number in dataset' elseif (rc .eq. -10) then errstring = 'Too many LEVELS specified in parse selects' elseif (rc .eq. -11) then errstring = 'Too many parameters specified in parse '// & 'selects' elseif (rc .eq. -12) then errstring = 'Too many TIMES specified in parse selects' elseif (rc .eq. -13) then errstring = 'Too many DAYS specified in parse selects' elseif (rc .eq. -14) then errstring = 'Too many FHOURS specified in parse selects' elseif (rc .eq. -15) then errstring = 'Too many SRCs specified in parse selects' elseif (rc .eq. -16) then errstring = 'Too many FDAYs specified in parse selects' elseif (rc .eq. -17) then errstring = 'Too many FTIMEs specified in parse selects' elseif (rc .eq. -18) then errstring = 'Too many grid PROjections in parse selects' elseif (rc .eq. -19) then errstring = 'Too many level units in parse selects' elseif (rc .eq. -20) then errstring = 'Too many GRIB values in parse selects' elseif (rc .eq. -21) then errstring = 'Too many ENSEMBLE values in parse selects' elseif (rc .eq. -40) then errstring = 'A math parsing string (G*) was empty' else errstring = 'Failed to read in PARSING information' endif rc = -21002 return else errstring = 'Failure' rc = -21009 return endif return end *$ Name: *$ m0resort - re-establish 1-1 order in levunit and lev *$ *$ Interface: *$ integer function *$ m0resort(integer levunit(*),integer numlevunit, integer lev(*) *$ integer levorig(*) ) *$ *$ Input: *$ levunit - target level unit *$ numlevunit - number of entries in levunit *$ lev - sorted levels *$ levorig - original levels, which have 1-1 match with lev *$ *$ Input and Output: *$ none *$ *$ Output: *$ none *$ *$ Return values: *$ 0 - successful completion *$ -1 - too many levels in lev, max is 20 *$ *$ Remarks: *$ This function relinks the levels and levelunits. When levels are *$ read in by the server, they are sorted from high to low to bypass *$ a feature in mcfndgrd that searches for ranges. This function *$ compares the original lev and the sorted lev and makes a levunit *$ that correctly matches the levunit. *$ integer FUNCTION m0resort(levunit,numlev,lev,levorig) implicit none integer NO parameter (NO=0) integer YES parameter (YES=1) integer levunit(*) ! array of level units integer numlev ! number of levels/level units integer lev(*) ! sorted levels integer levorig(*) ! original levels integer i,j ! loop bounds integer thislev ! this level integer tlevunit(20) ! temporary levunit holder integer used(20) data used/20*0/ m0resort = 0 if (numlev .gt. 20) then m0resort = -1 return endif do 10 i = 1,numlev ! make a temporary hold for levunit tlevunit(i) = levunit(i) 10 continue C -- go through the sorted levels....find the first un-used original C level and assign the lev unit to that slot do 100 i = 1,numlev thislev = lev(i) do 50 j = 1,numlev if (thislev .eq. levorig(j)) then if (used(j) .eq. NO) then used(j) = YES levunit(i) = tlevunit(j) endif endif 50 continue 100 continue return end