163 lines
5.2 KiB
Fortran
163 lines
5.2 KiB
Fortran
C$PRAGMA C (GET_APPS_DEFAULTS)
|
|
c =====================================================================
|
|
c pgm: subctr (iutw,iupr,iud,iupr,user,mwcol,icode,senof)
|
|
c
|
|
c in: iutw .... unit number for print output
|
|
c in: iupr .... unit number for log output
|
|
c in: iud .... unit number for debug output
|
|
c in: user .... sub-center identifier or sending office
|
|
c in: mwcol .... most west HRAP column
|
|
c out: icode .... sub-center code
|
|
c out: senof .... sending office
|
|
c =====================================================================
|
|
c
|
|
subroutine subctr (iutw,iupr,iud,user,mwcol,icode,senof)
|
|
c
|
|
c.......................................................................
|
|
c
|
|
c routine selects sub-center code for appropriate office according
|
|
c to GRIB Table C
|
|
c
|
|
c.......................................................................
|
|
c Initially written by
|
|
c Tim Sweeney, HRL July 26, 1996
|
|
c
|
|
c Updated sub-center codes. Added algorithm to handle SJU, Puerto
|
|
c Rico, OFS files used at SERFC.
|
|
c Tim Sweeney, HRL Aug 1998
|
|
c
|
|
c Added sub-center OFSTEST as code 163 (not used in GRIB).
|
|
c Tim Sweeney, HRL Nov 1998
|
|
c
|
|
c Changed logic to always search list of sub-centers.
|
|
c Tim Sweeney, HL Jan 2001
|
|
c
|
|
c For Puerto Rico message changed sub-center to KSJU
|
|
c and sending office to KALR (SERFC).
|
|
c Tim Sweeney, HL Mar 2001
|
|
c
|
|
c Changed sub-center OFSTEST to 200 (testing only).
|
|
c Tim Sweeney, HL Mar 2001
|
|
c
|
|
c Added check of grib_set_subcenter_0 token Jun 2006
|
|
c
|
|
c Removed first write statement to format 1 as this
|
|
c was constantly sending a email message to user
|
|
c oper, which is undesirable if called via cron. Sep 2007
|
|
c David T. Miller, RSIS, OHD/HSEB
|
|
c.......................................................................
|
|
c
|
|
character*2 subcenter0
|
|
character*4 suser,senof,subc
|
|
character*10 user
|
|
character*25 appsvar
|
|
c
|
|
include 'grib_tbl'
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob82/ohd/pproc/src/gribit/RCS/subctr.f,v $
|
|
. $', '
|
|
.$Id: subctr.f,v 1.1 2006/10/19 16:06:04 dsa Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
C
|
|
c
|
|
call prbug ('subctr',1,1,ibug)
|
|
ccc ibug = 1
|
|
c
|
|
c check value of grib_set_subcenter_0 token
|
|
c if set to ON, then set icode to 999
|
|
c
|
|
appsvar='grib_set_subcenter_0'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,subcenter0,lsub0)
|
|
if(subcenter0.eq.'ON'.or.subcenter0.eq.'on'
|
|
* .or.subcenter0.eq.'On') then
|
|
c write (iupr,1)
|
|
icode=999
|
|
return
|
|
end if
|
|
c
|
|
icode = -1
|
|
lsuser = 0
|
|
c
|
|
20 subc = senof
|
|
if (senof.eq.'KALR'.and.mwcol.gt.1121) subc = 'TSJU'
|
|
c
|
|
c get sub-center number from sub-center Table C
|
|
do 30 k=1,255
|
|
if (subc.eq.scid9c(k)) icode = k
|
|
30 continue
|
|
c
|
|
c sub-center not found
|
|
c
|
|
if (icode.lt.0) then
|
|
appsvar='awips_rfc_id'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,suser,lsuser)
|
|
c
|
|
if (lsuser.gt.0) then
|
|
write (iutw,37) suser(1:lsuser),
|
|
+ appsvar(1:lappsvar)
|
|
if (iupr.ne.iutw) write (iupr,37) suser(1:lsuser),
|
|
+ appsvar(1:lappsvar)
|
|
go to 39
|
|
endif
|
|
c
|
|
appsvar='awips_send_id'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,suser,lsuser)
|
|
c
|
|
if (lsuser.gt.0) then
|
|
write (iutw,37) suser(1:lsuser),
|
|
+ appsvar(1:lappsvar)
|
|
if (iupr.ne.iutw) write (iupr,37) suser(1:lsuser),
|
|
+ appsvar(1:lappsvar)
|
|
go to 39
|
|
endif
|
|
c
|
|
write (iutw,35)
|
|
if (iupr.ne.iutw) write (iupr,35)
|
|
suser='????'
|
|
lsuser=lenstr(suser)
|
|
go to 50
|
|
c
|
|
39 continue
|
|
if (lsuser.gt.0.and.lsuser.le.3) then
|
|
if (suser.ne.'ACR ') then
|
|
suser = 'K'//suser(1:lsuser)
|
|
else
|
|
suser = 'P'//suser(1:lsuser)
|
|
endif
|
|
c
|
|
lsuser = 4
|
|
endif
|
|
c
|
|
if (ibug.eq.1) write (iud,*) 'suser=',suser,' lsuser=',lsuser
|
|
senof = suser
|
|
icode = 0
|
|
go to 20
|
|
endif
|
|
c
|
|
if (icode.eq.0) then
|
|
if (lsuser.eq.0) then
|
|
write (iupr,40) user
|
|
if (iupr.ne.iutw) write (iupr,40) user
|
|
else
|
|
write (iupr,40) suser
|
|
if (iupr.ne.iutw) write (iupr,40) suser
|
|
endif
|
|
c
|
|
endif
|
|
c
|
|
50 return
|
|
c***************************************************************
|
|
1 format (' token set for setting subcenter to 0')
|
|
35 format (' ERROR in subctr: GRIB sub-center cannot be set ',
|
|
+ 'from apps_defaults.')
|
|
37 format (' NOTE in subctr: GRIB sub-center (',a,') set ',
|
|
+ 'from apps_default ',a,'.')
|
|
40 format ('ERROR: invalid sub-center : ',a)
|
|
end
|