xan/awips2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
awips2/ncep/gov.noaa.nws.ncep.ui.nsharp/AwcNsharp/sncross.f
Steve Harris 8552902906 12.5.1-15 baseline 
Former-commit-id: 3904c4ccf5 [formerly 4909e0dd166e43c22a34d96aa744f51db8a7d6c0]
Former-commit-id: b13cbb7e00
2012-06-08 13:39:48 -05:00

531 lines
17 KiB
Fortran
Raw Blame History

SUBROUTINE SNCROSS (snfile, dattim, yaxis, cxstns )
C************************************************************************
C* PROGRAM SNCROSS *
C* *
C* This program draws cross sections using upper air data. *
C** *
C* Log: *
C* M. desJardins/GSFC 12/85 *
C* I. Graffman/RDS 5/86 Added observed wind drawing *
C* I. Graffman/RDS 5/88 GG call, DEVICE, GFLUSH to GEPLOT *
C* G. Huffman/GSC 11/88 GEMPAK4.1; modify parameter names *
C* M. desJardins/GSFC 8/89 Add IP_IDNT *
C* M. desJardins/GSFC 1/90 Change thtinc to thtint in SNSGTH *
C* S. Schotz/GSC 6/90 Updates and cleanup for GEMPAK5 *
C* S. Schotz/GSC 7/90 Added changes for IN_PTYP, IN_AXIS *
C* S. Schotz/GSC 8/90 Plot winds only at wind data levels *
C* M. desJardins/GSFC 8/90 Changed array size; plot any parameter *
C* J. Nielsen/SUNYA 2/91 Read data for new set of stations *
C* J. Whistler/SSAI 2/91 Added subroutine SNSWWE *
C* M. desJardins/GSFC 3/91 Reorganized x axis for time section *
C* M. desJardins/NMC 4/91 Change time section title *
C* J. Nielsen/TAMU 11/91 Added filter factor *
C* K. Brill/NMC 11/91 Changed PANEL*24 to *48 *
C* K. Brill/NMC 12/91 Call SNSWWE only if PROCES is true *
C* K. Brill/NMC 01/92 Changes for contour fill *
C* K. Brill/NMC 01/92 Replace GERROR with ER_WMSG *
C* K. Brill/NMC 02/92 Check for new vertical coord; add parm *
C* conditions *
C* S. Jacobs/EAI 11/92 Added call to GMESG and 'shrttl' *
C* S. Jacobs/EAI 9/93 Added CLRBAR, IN_CBAR and GG_CBAR *
C* S. Jacobs/EAI 9/93 Changed IN_CBAR and GG_CBAR to GG_CBAR *
C* S. Jacobs/NMC 4/94 Removed unused variables *
C* S. Jacobs/NMC 6/94 DEVICE*12 --> *72 *
C* L. Williams/EAI 7/94 Removed call to SNSUPD and added shrttl *
C* to the user input variables *
C* S. Jacobs/NMC 9/94 Moved the title plotting to the end *
C* D. Keiser/GSC 8/96 Added FL_MFIL to search for file type *
C* K. Tyle/GSC 8/96 Added ER_WMSG call after FL_MFIL call *
C* M. Linda/GSC 2/97 Removed GFLUSH *
C* S. Maxwell/GSC 7/97 Increased input character length *
C* K. Brill/EMC 4/99 Set MAXD grid dimension in PARAMETER *
C* M. Li/GSC 1/00 Added GCNTLN and nflag; removed GCSPLN *
C* T. Lee/GSC 7/00 Moved MAXD to GEMPRM.PRM & named LLMAXD *
C* T. Lee/GSC 8/00 Added calls to GSTANM and GENANM *
C* T. Lee/SAIC 10/01 Added contour fill types *
C* T. Piper/SAIC 4/02 Fixed UMR; initialized icvtyp & isnfln *
C* L. Hinson/AWC 3/03 Defined/init iend and ierr *
C* L. Hinson/AWC 4/03 Numerous Declarations/Initializations *
C* Added. Logic/Miscoding Fix in call to *
C* SNSWND, with undefined nlvl. Passed *
C* defined nvlvl set up by SNSVNT instead *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
C*
CHARACTER snfile*(*), dattim*(*), yaxis*(*), cxstns*(*)
CHARACTER device*(LLMXLN),
+ border*(LLMXLN), cint*(LLMXLN), line*(LLMXLN),
+ ptype*(LLMXLN), title*(LLMXLN), wind*(LLMXLN),
+ taxis*(LLMXLN), filter*(LLMXLN), shrttl*(LLMXLN),
+ panel*(LLMXLN), text*(LLMXLN), snparm*(LLMXLN),
+ vcoord*(LLMXLN),
+ curve*(LLMXLN), contur*(LLMXLN),
+ fint*(LLMXLN), fline*(LLMXLN), ctype*(LLMXLN),
+ clrbar*(LLMXLN), filnam*(LLMXLN),
+ vline*(LLMXLN), vint*(LLMXLN)
C*
LOGICAL clear
C
C* The "old" values keep track of the current values. NEWSTN
C* is set when station data must be read in. NEWPRM is set when
C* a new parameter is selected. NEWTHA is read when new theta
C* data for an isentropic display must be read.
C
CHARACTER cxsold*72, snfold*72, datold*48, prmold*4,
+ taxold*48, prmhld*16
LOGICAL newstn, newprm, newtha, newvco
C*
CHARACTER times (LLMXTM)*20, stns (LLTMCX)*20, parm*4
CHARACTER wintyp*1, winuni*1, vcord*4
CHARACTER ctlbl (LLMXTM)*12, ttlstr*72
PARAMETER ( MSDSIZ = 100000 )
REAL stndat ( MSDSIZ ), xtlbl (LLMXTM)
REAL sloc (LLTMCX), xx (LLMAXD), yy (LLMAXD),
+ pontha (LLMAXD,200), clvl (LLCLEV),
+ flvl (LLCLEV), pdat (LLTMCX,200),
+ rmargn (4), grid (LLMAXD,LLMAXD),
+ toptmp (LLTMCX), topwnd (LLTMCX),
+ yaxval (LLAXIS),vlvl(LLCLEV)
INTEGER iltype (LLCLEV), linwid (LLCLEV),
+ ilabel (LLCLEV), icolor (LLCLEV),
+ ifcolr (LLCLEV), iflabl (LLCLEV),
+ ifltyp (LLCLEV), ipsdat (LLTMCX),
+ nlvls (LLTMCX), idtype (LLMXLV,LLTMCX),
+ ivcolr(LLCLEV)
LOGICAL proces, respnd, done, isnflg, timflg,prmexs,
+ wndexs, cflag, lflag, sflag, bflag, fflag, nflag,
+ vflag
INTEGER iend, ier, iret, ivcord
INTEGER nstn, nyval, iylbfr, iyglfr, iytmfr, nxlbl,
+ ixlbfr, ixglfr, ixtmfr, nvlvl, iwnclr, kgxy,
+ iytype, nclvl,nflvl, ithinc, icttl, linttl
REAL ybot, ytop, xmin, xmax
C*
DATA snfold, cxsold, prmold, datold, taxold
+ / 5 * ' ' /
DATA newstn, newprm, newvco / 3 * .true. /
DATA icvtyp / 0 /, isnfln / 0 /, ivcold / -9999 /
C------------------------------------------------------------------------
C* Initialize TAE and GEMPLT
C
vflag=.false.
nflag=.false.
lflag=.false.
sflag=.false.
bflag=.false.
cflag=.false.
kgxy = 0
nvlvl = 0
nclvl = 0
nflvl = 0
nstn = 0
iend = 0
ier = 0
iret = 0
icttl = 0
linttl = 0
fflag = .false.
isnflg = .false.
newtha = .false.
timflg = .false.
ybot = 0.0
ytop = 0.0
xmin = 0.0
xmax = 0.0
nyval = 0
iylbfr = 0
iyglfr = 0
iytmfr = 0
nxlbl = 0
ixlbfr = 0
ixglfr = 0
ixtmfr = 0
iwnclr = 0
snfold = ' '
cxsold = ' '
prmold = ' '
datold = ' '
taxold = ' '
newstn = .true.
newprm = .true.
newvco = .true.
ivcold = -9999
CALL IN_BDTA ( ier )
CALL GSMODE ( 2, ier )
snparm = ' '
vcoord = 'hght'
ptype = 'lin//12;5;6;3'
taxis = 'r--1;2;1;1'
line = '0'
border = '1;1;8'
cint = '2'
wind = 'bk1/1/2/112'
title = '1/-3'
panel = '0'
clear = .true.
filter = 'yes'
text = '1/22//hw'
curve = '2'
clrbar = '0!1/v/lr/.99;.1//-1'
fint = '0;2;4;6;8;10'
contur = '0'
fline = '0'
vint = '20/0/180'
vline = '0;31;11;2;17;20;23;21;24;27;29'
ctype = 'l'
proces = .true.
prmexs = .true.
wndexs = .true.
C
C* Set up the graphics device.
C
C CALL GG_SDEV ( device, iret )
C IF ( iret .ne. 0 ) proces = .false.
C
C* Set text attributes
C
CALL IN_TEXT ( text, iret )
C
C* Open the sounding file.
C
CALL FL_MFIL ( snfile, ' ', filnam, ier )
IF ( iret .ne. 0 ) CALL ER_WMSG ( 'FL', iret, ' ', ier )
CALL SNSFIL ( filnam, snfold, isnfln, newstn, nparms,
+ iret )
IF ( iret .ne. 0 ) THEN
proces = .false.
ELSE
CALL SNSDAT ( isnfln, dattim, datold, newstn,
+ times, ntime, iret )
IF ( iret .ne. 0 ) THEN
proces = .false.
ELSE IF ( ntime .eq. 1 ) THEN
timflg = .false.
ELSE IF ( ntime .ge. 4 ) THEN
timflg = .true.
IF ( ntime .gt. LLTMCX ) THEN
ntime = LLTMCX
END IF
ELSE
iret = -6
CALL ER_WMSG ( 'SNCROSS', iret, dattim, ier )
proces = .false.
datold = ' '
END IF
END IF
C
C* Check to see if the station(s) have changed.
C
IF (proces) THEN
CALL ST_LCUC ( cxstns, cxstns, ier )
IF ( cxsold .ne. cxstns ) THEN
newstn = .true.
cxsold = ' '
END IF
C
C* Get wind information.
C
CALL IN_WIND ( wind, wintyp, winuni, iwnclr, ier )
C
C* Get the parameter to evaluate.
C
CALL ST_CLST ( snparm, ';', ' ', 1, prmhld, n, ier )
parm = prmhld (1:4)
isnflg=.false.
CALL ST_LCUC ( parm, parm, ier )
IF ( ( parm .eq. ' ' ) .and. ( iwnclr .eq. 0 ) ) THEN
iret = -13
CALL ER_WMSG ( 'SNCROSS', iret, snparm, ier )
proces = .false.
newprm = .true.
ELSE IF ( parm .ne. prmold ) THEN
newprm = .true.
IF ( parm .eq. 'ISEN' ) THEN
isnflg = .true.
ELSE
isnflg = .false.
END IF
END IF
C
C* Check to see if the time axis has changed for a time
C* series.
C
IF ( taxis .ne. taxold ) newstn = .true.
taxold = taxis
C
C* Get the data for the selected stations or times.
C
iret = 0
END IF
IF ( proces .and. ( .not. timflg ) .and. newstn )
+ THEN
CALL SNSSST ( cxstns, isnfln, nparms, MSDSIZ,
+ nstn, stns, ipsdat, nlvls, stndat,
+ idtype, sloc, xmin, xmax, iret )
IF ( iret .ne. 0 ) proces = .false.
ELSE IF ( proces .and. timflg .and. newstn ) THEN
CALL SNSSTM ( cxstns, isnfln, nparms, MSDSIZ, times,
+ ntime, taxis, nstn, ipsdat, nlvls,
+ stndat, idtype, sloc, xmin, xmax,
+ xtlbl, ctlbl, nxlbl, ixlbfr, ixglfr,
+ ixtmfr, iret )
IF ( iret .ne. 0 ) proces = .false.
END IF
CALL SN_CLOS( isnfln, ier)
C
C* Check for at least four stations.
C
IF ( proces .and. ( nstn .ge. 4 ) ) THEN
cxsold = cxstns
prmold = parm
ELSE
cxsold = ' '
prmold = ' '
proces = .false.
END IF
C
C* Get information about the y axes. Find the y points
C* on a LLMAXD by LLMAXD grid.
C
IF ( proces ) THEN
CALL SNSYAX ( ptype, vcoord, yaxis, iytype, ratio,
+ rmargn, ybot, ytop, ivcord, vcord,
+ yaxval, nyval, iylbfr, iyglfr,
+ iytmfr, iret )
IF ( iret .ne. 0 ) THEN
proces = .false.
ELSE IF ( isnflg .and. ( ivcord .ne. 1 ) ) THEN
iret = -4
CALL ER_WMSG ( 'SNCROSS', iret, ' ', ier )
proces = .false.
ELSE
IF ( ivcold .eq. ivcord ) newvco = .false.
ivcold = ivcord
CALL SNSGRD ( iytype, xmin, xmax, ybot, ytop,
+ ratio, rmargn, yy, xx, iret )
IF ( iret .ne. 0 ) proces = .false.
END IF
END IF
C
C* Get the minimum pressure for temperature and winds.
C
IF ( proces ) THEN
CALL SNSRGE ( vcord, nstn, stndat, nlvls, ipsdat,
+ toptmp, topwnd, iret )
C
C* Get interval and curve type.
C
CALL SNSGTH ( cint, curve, ithinc, icvtyp, newtha,
+ iret )
END IF
C
C* Get either grid or isentropic data.
C
IF ( proces ) THEN
IF ( isnflg .and.
+ ( newprm .or. newtha .or. newstn ) ) THEN
CALL SNSTHA ( ithinc, icvtyp, nstn, stns,
+ ipsdat, nlvls, stndat, sloc,
+ xx, thmin, thmax, pontha,
+ pdat, iret )
IF ( iret .eq. 0 ) THEN
newprm = .false.
ELSE
prmexs = .false.
END IF
ELSE IF ( ( .not. isnflg ) .and.
+ ( newprm .or. newstn .or. newvco ) ) THEN
CALL SNSPRM ( snparm, nstn, stns, ipsdat, nlvls,
+ stndat, sloc, xx, yy, vcord,
+ ivcord, icvtyp, grid, pontha,
+ iret )
IF ( iret .eq. 0 .and. parm .ne. ' ' ) THEN
CALL IN_CONT ( contur, ier )
CALL IN_CTYP ( ctype, nflag, lflag, sflag,
+ bflag, fflag, ier )
IF ( lflag .or. sflag .or.
+ bflag .or. nflag ) THEN
cflag = .true.
ELSE
cflag = .false.
END IF
kgxy = LLMAXD * LLMAXD
CALL SNSLEV ( cflag, line, cint, fflag,
+ fline, fint, kgxy, grid,
+ nclvl, clvl, icolor, iltype,
+ linwid, ilabel, nflvl, flvl,
+ ifcolr, iflabl, ifltyp, ier )
IF ( nclvl .eq. 0) cflag = .false.
IF ( nflvl .eq. 0) fflag = .false.
END IF
IF ( iret .ne. 0 ) THEN
prmexs = .false.
ELSE
CALL GSGGRF ( 1, iytype, LLMAXD, LLMAXD,
+ xmin, ybot, xmax, ytop, ier )
IF ( ier .ne. 0 ) THEN
iret = -15
CALL ER_WMSG ('SNCROSS', iret, ' ', ier)
proces = .false.
END IF
END IF
END IF
END IF
C
C* Check to see if wind data exist.
C
IF ( proces ) THEN
CALL SNSWWE ( winuni, vcord, ier )
IF ( ier .ne. 0 ) THEN
wndexs = .false.
END IF
END IF
C
C
C* Draw the cross section.
C
IF ( proces .and. ( prmexs .or. wndexs ) ) THEN
C
C* Clear the device if requested and set panel.
C
IF ( clear ) CALL GCLEAR ( iret )
CALL GG_PANL ( panel, iret )
C
C* Draw the isentropes or contours.
C
IF ( prmexs ) THEN
IF ( isnflg ) THEN
CALL SNSISN ( line, xx, pontha, ybot, ytop,
+ ithinc, thmin, thmax, nstn,
+ sloc, pdat, iret )
ELSE IF ( parm .ne. ' ' .and.
+ ( cflag .or. fflag ) ) THEN
IF ( fflag ) THEN
CALL GCFILL ( LLMAXD, LLMAXD, grid,
+ 0, 0, 0, nflvl, flvl,
+ ifcolr, iflabl, ifltyp,
+ iret )
IF ( iret .ne. 0 ) CALL ER_WMSG
+ ( 'GEMPLT', iret, ' ', ier )
END IF
IF ( cflag ) THEN
IF ( lflag ) THEN
CALL GCLGRN ( LLMAXD, LLMAXD, grid,
+ 0, 0, 0, nclvl, clvl,
+ icolor, iltype, linwid,
+ ilabel, iret )
IF ( iret .ne. 0 ) CALL ER_WMSG
+ ( 'GEMPLT', iret, ' ', ier )
END IF
IF ( nflag ) THEN
CALL GCNTLN ( LLMAXD, LLMAXD, grid,
+ 0, 0, 0, nclvl, clvl,
+ icolor, iltype, linwid,
+ ilabel, iret )
IF ( iret .ne. 0 ) CALL ER_WMSG
+ ( 'GEMPLT', iret, ' ', ier )
END IF
IF ( sflag ) THEN
CALL GCSPLN ( LLMAXD, LLMAXD, grid, 0, 0, 0,
+ nclvl, clvl, icolor,
+ iltype, linwid, ilabel,
+ iret )
IF ( iret .ne. 0 ) CALL ER_WMSG
+ ( 'GEMPLT', iret, ' ', ier )
END IF
IF ( bflag ) THEN
CALL GCBOXX ( LLMAXD, LLMAXD, grid,
+ 0, 0, 0, nclvl, clvl,
+ icolor, iltype, linwid,
+ ilabel, iret )
IF ( iret .ne. 0 ) CALL ER_WMSG
+ ( 'GEMPLT', iret, ' ', ier )
END IF
END IF
END IF
END IF
C
C* Plot the background and surface.
C
CALL SNSBOR ( border, ybot, ytop, yaxval, nyval,
+ iylbfr, iyglfr, iytmfr, xmin, xmax,
+ nstn, stns, sloc, xx, pontha,
+ toptmp, topwnd, xtlbl, ctlbl,
+ nxlbl, ixlbfr, ixglfr, ixtmfr,
+ timflg, iret )
C
C* Draw the winds.
C
IF ( wndexs ) THEN
IF ( vint .ne. ' ' ) THEN
CALL SNSVNT ( vint, vline, vflag, vlvl,
+ nvlvl, ivcolr, ier )
ELSE
vflag = .false.
END IF
C*
IF ( iwnclr .gt. 0 .or. vflag) THEN
CALL GSCOLR ( iwnclr, ier )
CALL IN_FILT ( filter, filtfc, ier )
CALL SNSWND ( wintyp, nstn, ipsdat,
+ nlvls, stndat, idtype, sloc,
+ ybot, ytop, filtfc, vcord,
+ nvlvl, vlvl, ivcolr, vflag,
+ iret )
END IF
END IF
C
C* Plot the color bar.
ipoint = INDEX ( clrbar, '!' )
IF ( fflag ) THEN
IF ( ipoint .gt. 0 ) THEN
iend = ipoint - 1
ELSE
CALL ST_LSTR ( clrbar, iend, ier )
END IF
CALL GG_CBAR ( clrbar(:iend), nflvl, flvl,
+ ifcolr, ier )
IF ( vflag .and. ipoint .gt. 0 ) THEN
CALL GG_CBAR ( clrbar(ipoint+1:), nvlvl,
+ vlvl, ivcolr, ier )
END IF
ELSE IF ( vflag ) THEN
CALL GG_CBAR ( clrbar, nvlvl, vlvl,
+ ivcolr, ier )
END IF
C
C
C* Write the title.
C
CALL SNSTTL (title, timflg, cxstns, times, ntime,
+ icttl, linttl, ttlstr, shrttl, iret)
IF ( clear ) CALL GMESG ( shrttl, ier )
IF ( icttl .gt. 0 ) THEN
CALL GSCOLR ( icttl, ier )
CALL GG_WSTR ( ttlstr, linttl, ier )
END IF
title = '1/-1/Height in Feet'
CALL SNSTTL (title, timflg, cxstns, times, ntime,
+ icttl, linttl, ttlstr, shrttl, iret)
IF ( icttl .gt. 0 ) THEN
CALL GSCOLR ( icttl, ier )
CALL GG_WSTR ( ttlstr, linttl, ier )
END IF
C
C
C* Flush the plotting buffers and update globals.
C
CALL GEPLOT ( iret )
END IF
C
C* Prompt for next cross section to be drawn.
C
C*
RETURN
END
Reference in a new issue View git blame Copy permalink