diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /sys/gio/ncarutil | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'sys/gio/ncarutil')
182 files changed, 45818 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/README b/sys/gio/ncarutil/README new file mode 100644 index 00000000..6ae35023 --- /dev/null +++ b/sys/gio/ncarutil/README @@ -0,0 +1,219 @@ +Directory gio$ncarutil, with subdirectories conlib, autograph and sysint, +contains the source code for the GKS based NCAR plotting utilities library. +The first public release of this software was installed in IRAF 10SEP86. +(The 3 previous installations of the NCAR Utilities were the result of NOAO +serving as a Beta release test site.) What follows is the Notes files from +the installation : + +****************************************************************************** +Notes for installation of the NCAR GKS based plotting utilities. This +release marks the end of NCAR's beta testing and is the first public release +of the new software. The changes made at NOAO have been merged into the +new source code; these changes have are marked with "+/- NOAO." The IRAF +installed NCAR library differs from the version released on tape as documented +below. Installation was begun September 2, 1986. (S. Hammond) + +Subdirectory AUTOGRAPH -- + +autograph/agback.f: + Calls blockdata agdflt as run time subroutine. +autograph/agcurv.f: + Calls blockdata agdflt as run time subroutine. +autograph/agdflt.f: + This is the block data, which has been completely rewritten as + initialization statements instead of data statements. +autograph/agexax.f: + A ftn write statement has been commented out. +autograph/agppid.f: + A string is written with f77upk/pstr instead of a ftn write statement. +autograph/agrstr.f: + Binary read, completely commented out. +autograph/agsave.f: + Binary write (opposite of agrstr.f), completely commented out. +autograph/agscan.f: + Calls blockdata agdflt as run time subroutine. + A ftn write statement has been commented out. +autograph/agsetp.f: + Calls blockdata agdflt as run time subroutine. +autograph/agstup.f: + Calls blockdata agdflt as run time subroutine. +autograph/ezmxy.f, ezmy.f, ezxy.f, ezy.f: + These four subroutines require identical changes: + Call blockdata agdflt as run time subroutine upon entering; + Call subroutine initag before returning. +autograph/idiot.f: + Call blockdata adgflt as run time subroutine. + Call plotit and initut to reinitialize before returning. +autograph/pstr.x: + This file is not on the distribution tape, it was written to + output strings that have been unpacked by f77upk. + +Subdirectory CONLIB -- + +conlib/conecd.f: + Character variables IT and CHTMP are not used and so are commented out. + The FTN internal writes are rewritten as calls to encode. +conlib/congen.f: + FTN internal write replaced with call to encode. +conlib/conop1.f,conop2.f,conop3.f,conop4.f: + These four routines now call blockdata conbdn as run time initialization. +conlib/conout.f, conot2.f: + Both these routines are no-ops in IRAF. All statements have been commented + out. +conlib/conpdv.f: + FTN internal write replaced with a call to encode. +conlib/conssd.f: + FTN write and format statement commented out. +conlib/contng.f: + FTN internal writes rewritten as calls to encode. + + +Directory NCARUTIL -- + +conran.f: + Changed values of iabove, ibelow and ibel2 to improve label placement. + Blockdata condbn rewritten as run time initialization. (conbdn.f) + Internal writes rewritten as calls to encode. + +conrec.f: + Value of NCRT changed from 4 to 2. + The contour plot labelling has been improved, with the titles being + centered in the current viewport, and the large spaces between + fields eliminated. This change involves: + 1. common block noaolb added; also used in spp calling routine. + 2. Values of LNGTHS array modified. + 3. Character*25 variable string[5] added. + 4. Default plot position is centered on current viewport. + All internal writes have been replaced with calls to encode. + Error message concerning "overflow in STLINE" is now written only + to stderr, not to stdgraph as well. + EZCNTR no longer calls frame. + Block data CONBD deleted from conrec.f source, rewritten as conbd.f + +dashsmth.f: + In two places, the blockdata DASHBD is called as an initializing subroutine. + Subroutines kurv1s and kurv2s are used for both the dashsmth and + isosrf utilities. The code is duplicated in the two fortran files. I + have put it in a separate file (kurv.f) and deleted it from both original + locations. + +gridal.f: + In two places, blockdata GRIDT is called as an initializing subroutine. + All internal FTN writes changed to calls to encode. + FTN write and format statements for error reporting deleted - used seter. + Blockdata deleted from gridal.f; rewritten in gridt.f. + +hafton.f: + Blockdata hfinit rewritten and called as run time initializing subroutine. + One internal write rewritten as call to encode. + Call to FRAME removed from EZHFTN. + +isosrf.f: + Call to FRAME removed from EZISOS + Blockdata isosrb was rewritten as run time initialization isosrb.f + Source for subroutines kurv1s and kurv2s has been deleted from isosrf.f. + (It is shared with the dashsmth utility, and has been moved to kurv.f.) + +pwrity.f: + Blockdata PWRYBD rewritten as subroutine. + FTN writes and format statements commented out. + +pwrzs.f: + Common block noaovp added, so user can control viewport. Calls to + plotit and set had to be changed because they assumed the full + viewport [1-1024] was being used for srface plots. + +srface.f: + Because user changes viewport when labelling is selected, mods had + to be made. Common block noaovp has been added, and calls to set + and plotit no longer assume the full viewport [1-1024] is being used. + Blockdata SRFABD has been rewritten as a run time initialization. + +strmln.f: + The value of uvmsg changed from 1.0E+36 to 1.0E+16 in an attempt + to make this routine run on a VAX. + +threed.f: + Blockdata threbd rewritten as run time initialization. + Subroutine pwrz completely commented out. + +velvct.f: + Blockdata veldat rewritten as run time initialization. + FTN internal write rewritten as call to encode. + + +Subdirectory SYSINT (system interface) -- + +sysint/support.f: + 1. The character size calculated by WTSTR is doubled to be readable + with the IRAF font. + 2. Subroutines SETER and E9RIN both used FTN write statements to + output information. This is now handled by passing the error + message to ULIBER, where the string gets unpacked with f77upk + and written to stderr. + 3. Blockdata UERRBD was rewritten as a run time initialization. + 4. Block data UTILBD was rewritten as a run time initialization. + A logical flag (first) was added to insure that the internal + parameters were initialized only once per load; subroutine + utilbd can be called at several points. An entry point 'utinit' + was added to reset the 'first' flag to true. + 5. In an attempt to mimic the organization of the release tape, file + support.f contains the following fortran subroutines: + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + SUBROUTINE ENTSR(IROLD,IRNEW) + SUBROUTINE RETSR(IROLD) + SUBROUTINE ERROF + SUBROUTINE SETER(MESSG,NERR,IOPT) + SUBROUTINE EPRIN + SUBROUTINE E9RIN(MESSG,NERR,SAVE) + SUBROUTINE FDUM + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) + INTEGER FUNCTION NERRO(NERR) + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) + subroutine uerrbd + subroutine uliber (errcode, pkerrmsg, msglen) + +sysint/spps.f: + 1. Subroutine FLUSH has been renamed MCFLSH because of a name conflict. + 2. FRAME calls initut to initialize the 'first' flag in utilbd. + 3. Subroutines OPNGKS and CLSGKS have been commented out. + 4. In PLOTIT and PLOTIF the block data utilbd is called as a run time + initialization subroutine. + +**************************************************************************** + +gio$ncarutil/conrec.f Dec 23, 1986 S. Hammond + Moved the call to gsplci that set up major contours. This + statement was not being executed until after the first major line + had been drawn, resulting in the first major line not being bold. + + +*************************************************************************** +On June 1, 1987 the following copywright notice was inserted into all +FORTRAN files in the ncarutil directory tree. + +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +February 12, 1988. During Steve Rooke's port of IRAF to the HP RISC computer +several Fortran errors were caught by the HP compiler. These have been +fixed as shown: +sys/gio/ncarutil/conbdn.f + The data statement at line 244 had not been commented out. It is now. + +June 10, 1988. Made a mod to conbd.f (and in the comments to conrec.f) that +resets the point at which contour decides an image aspect ratio is "extreme". +Previously if the image axes ratio exceeded 1:4 the contour plot was square. +This limit was too restrictive and has been changed to 1:16. See related +change in pkg$plot.vport.x. diff --git a/sys/gio/ncarutil/autograph/README b/sys/gio/ncarutil/autograph/README new file mode 100644 index 00000000..befb5e42 --- /dev/null +++ b/sys/gio/ncarutil/autograph/README @@ -0,0 +1,46 @@ +AUTOGRAPH -- This directory contains the contents of the NCAR file +autograph.f, unpacked one subroutine per file. Here is the revision file +supplied by NCAR for the autograph package. For NOAO specific enhancements, +see gio$ncarutil/README. + + Revision history: + + February, 1979 Added a revision history and enhanced machine + independency. + + September, 1979 Fixed a couple of problems which caused the code to + bomb when core was pre-set to indefinites and the + 1st graph drawn was peculiar in some way and another + which caused it to set the default dashed-line-speci- + fier length wrong. Added new documentation. + + October, 1979 Changed the way IDIOT behaves when NPTS is negative. + + March, 1980 Fixed a couple of small errors, one which prevented + an error exit in AGSETP from ever being reached and + another which caused AUTOGRAPH to blow up when given + a zero or negative on a logarithmic axis. Changed + the way in which NBPF is computed by AGSTR1. + + August, 1981 Removed all calls setting the plotter intensity and + made the computation of the variable SMRL portable. + + April, 1984 Made the code strictly FORTRAN-77 compatible, taking + out all dependency on support routines (such as LOC). + This required some changes in the user interface. + + February, 1985 Put code in AGSETP to reclaim character-store space + used by character-string dash patterns when they are + redefined using binary patterns. Also changed AGGTCH + to return a single blank for a non-existent string. + + August, 1985 Put code in AGGETP so that the label-name identifier + is now returned properly. Among other things, this + cures a problem which caused the character-storage + space to be eaten up. + + December, 1985 Fixed AGSETP to zero the current-line pointer when + the current-label pointer is changed. + + January, 1986 Fixed AGAXIS to respond properly to the zeroing of + NCIM by AGCHNL. diff --git a/sys/gio/ncarutil/autograph/agaxis.f b/sys/gio/ncarutil/autograph/agaxis.f new file mode 100644 index 00000000..4c3bec73 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agaxis.f @@ -0,0 +1,1851 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C A B R I E F D E S C R I P T I O N O F A U T O G R A P H +C --------------------------------------------------------------------- +C +C Following is a brief description of the AUTOGRAPH package. For a +C complete write-up, see the document "AUTOGRAPH - THE UNABRIDGED +C WRITE-UP". +C +C +C PACKAGE AUTOGRAPH +C +C LATEST REVISION January, 1986 +C +C PURPOSE To draw graphs, each with a labelled background +C and each displaying one or more curves. +C +C ACCESS (ON THE CRAY) To use AUTOGRAPH routines on the Cray, simply +C call them; they are in the binary library +C $NCARLB, which is automatically searched. +C +C To get smoother curves, drawn using spline +C interpolation, compile DASHSMTH, from ULIB, +C to replace DASHCHAR, from $NCARLB: +C +C GETSRC,LIB=ULIB,FILE=DASHSMTH,L=DSMTH. +C CFT,I=DSMTH,L=0. +C +C AUTOGRAPH contains a routine AGPWRT, which it +C calls to draw labels. This routine just passes +C its arguments on to the system-plot-package +C routine PWRIT. To use one of the fancier +C character-drawers, like PWRITX or PWRITY, +C just compile a routine AGPWRT to replace the +C default version; it has the same arguments as +C PWRIT and may either draw the character string +C itself, or just pass the arguments on to a +C desired character-drawer. The AUTOGRAPH +C specialist has some "standard" versions of +C AGPWRT and should be consulted for help in +C avoiding pitfalls. One standard version, +C which calls PWRITX, may be obtained using the +C following JCL: +C +C GETSRC,LIB=XLIB,FILE=AGUPWRITX,L=UPWRTX. +C CFT,I=UPWRTX,L=0. +C +C USAGE Following this indented preamble are given two +C lists: one describing the AUTOGRAPH routines +C and another describing the arguments of those +C routines. +C +C "AUTOGRAPH - THE UNABRIDGED WRITE-UP" gives +C a complete write-up of AUTOGRAPH, in great +C detail and with a set of helpful examples. +C +C ENTRY POINTS Except for seven routines which are included +C in the package for historical reasons (EZY, +C EZXY, EZMY, EZMXY, IDIOT, ANOTAT, and DISPLA), +C the AUTOGRAPH routines have six-character names +C beginning with the characters 'AG'. An alpha- +C betized list follows: +C +C AGAXIS AGBACK AGBNCH AGCHAX AGCHCU AGCHIL +C AGCHNL AGCTCS AGCTKO AGCURV AGDASH AGDFLT +C AGDLCH AGDSHN AGEXAX AGEXUS AGEZSU AGFPBN +C AGFTOL AGGETC AGGETF AGGETI AGGETP AGGTCH +C AGINIT AGKURV AGLBLS AGMAXI AGMINI AGNUMB +C AGPPID AGPWRT AGQURV AGRPCH AGRSTR AGSAVE +C AGSCAN AGSETC AGSETF AGSETI AGSETP AGSRCH +C AGSTCH AGSTUP AGUTOL +C +C NOTE: The "routine" AGDFLT is a block-data +C routine specifying the default values of +C AUTOGRAPH control parameters. +C +C SPECIAL CONDITIONS Under certain conditions, AUTOGRAPH may print +C an error message (via the routine SETER) and +C stop. Each error message includes the name of +C the routine which issued it. A description of +C the condition which caused the error may be +C found in the AUTOGRAPH write-up in the NCAR +C graphics manual; look in the write-up of the +C routine which issued the error message, under +C the heading 'SPECIAL CONDITIONS'. +C +C For error messages issued by the routine +C AGNUMB, see the write-up of the routine AGSTUP. +C +C If you get an error in the routine ALOG10, it +C probably means that you are using a logarithmic +C axis and some of the coordinate data along that +C axis are zero or negative. +C +C COMMON BLOCKS The AUTOGRAPH common blocks are AGCONP, AGORIP, +C AGOCHP, AGCHR1, and AGCHR2. AGCONP contains +C the AUTOGRAPH "control parameters", primary and +C secondary, all of which are real, AGORIP other +C real and/or integer parameters, AGOCHP other +C character parameters, AGCHR1 and AGCHR2 the +C variables implementing the character-storage- +C and-retrieval scheme of AUTOGRAPH. +C +C I/O Lower-level plotting routines are called to +C produce graphical output and, when errors +C occur, error messages may be written to the +C system error file, as defined by I1MACH(4), +C either directly or by way of a call to SETER. +C +C REQUIRED ULIB AUTOGRAPH uses the software dashed-line package +C ROUTINES DASHCHAR. Of course, either of the packages +C DASHSMTH or DASHSUPR may be used instead, to +C get smoother curves. +C +C SPECIALIST Dave Kennison, Scientific Computing Division, +C National Center for Atmospheric Research +C +C LANGUAGE FORTRAN +C +C HISTORY Dave Robertson wrote the original routine +C IDIOT, which was intended to provide a simple, +C quick-and-dirty, x-y graph-drawing capability. +C In time, as it became obvious that many users +C were adapting IDIOT to more sophisticated +C tasks, Dan Anderson wrote the first AUTOGRAPH +C package, based on IDIOT. It allowed the user +C to put more than one curve on a graph, to use +C more sophisticated backgrounds, to specify +C coordinate data in a variety of ways, and to +C more easily control the scaling and positioning +C of graphs. Eventually, this package, too, was +C found wanting. In 1977, Dave Kennison entirely +C re-wrote AUTOGRAPH, with the following goals: +C to maintain the ease of use for simple graphs +C which had been the principal virtue of the +C package, to provide the user with as much +C control as possible, to incorporate desirable +C new features, and to make the package as +C portable as possible. In 1984, the package +C was again worked over by Dave Kennison, to +C make it compatible with FORTRAN-77 and +C to remove any dependency on the LOC function, +C which had proved to cause difficulties on +C certain machines. The user interface was +C changed somewhat and some new features were +C added. A GKS-compatible version was written. +C +C SPACE REQUIRED AUTOGRAPH is big; one pays a price for its +C capabilities. On the Cray, it occupies a +C little under 30000 (octal) locations. The +C required plot package routines take about +C another 7000 (octal), the (modified) PORT +C support routines about another 1000 (octal), +C and system routines (math, I/O, miscellany) +C another 30000 (octal). +C +C PORTABILITY AUTOGRAPH may be ported with few modifications +C to most systems having a FORTRAN-77 compiler. +C +C The labelled common blocks may have to be +C declared in a part of the user program which +C is always core-resident so that variables +C in them will maintain their values from one +C AUTOGRAPH-routine call to the next. Such a +C problem may arise when AUTOGRAPH is placed in +C an overlay or when some sort of memory-paging +C scheme is used. +C +C REQUIRED RESIDENT AUTOGRAPH uses the DASHCHAR routines DASHDB, +C ROUTINES DASHDC, FRSTD, LASTD, LINED, AND VECTD, the +C system-plot-package routines FRAME, GETSET, +C GETSI, LINE, PWRIT, and SET, the support +C routines ISHIFT and IOR, the (modified) +C PORT utilities SETER and I1MACH, and the +C FORTRAN-library routines ALOG10, ATAN2, COS, +C SIN, AND SQRT. +C +C --------------------------------------------------------------------- +C U S E R - C A L L A B L E A U T O G R A P H R O U T I N E S +C --------------------------------------------------------------------- +C +C Following is a list of AUTOGRAPH routines to be called by the user +C (organized by function). Each routine is described briefly. The +C arguments of the routines are described in the next section. +C +C Each of the following routines draws a complete graph with one call. +C Each is implemented by a set of calls to the lower-level AUTOGRAPH +C routines AGSTUP, AGCURV, and AGBACK (which see, below). +C +C -- EZY (YDRA,NPTS,GLAB) - draws a graph of the curve defined by the +C data points ((I,YDRA(I)),I=1,NPTS), with a graph label specified +C by GLAB. +C +C -- EZXY (XDRA,YDRA,NPTS,GLAB) - draws a graph of the curve defined by +C the data points ((XDRA(I),YDRA(I)),I=1,NPTS), with a graph label +C specified by GLAB. +C +C -- EZMY (YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the family of +C curves defined by data points (((I,YDRA(I,J)),I=1,NPTS),J=1,MANY), +C with a graph label specified by GLAB. The order of the subscripts +C of YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the +C family of curves defined by the data points (((XDRA(I),YDRA(I,J)), +C I=1,NPTS),J=1,MANY), with a graph label specified by GLAB. XDRA +C may be doubly-subscripted and the order of the subscripts of XDRA +C and YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) - implements +C the routine from which AUTOGRAPH grew - not recommended - provided +C for antique lovers. +C +C The following routines provide user access to the AUTOGRAPH control +C parameters (in the labelled common block AGCONP). +C +C -- ANOTAT (XLAB,YLAB,LBAC,LSET,NDSH,DSHL) - may be used to change the +C x- and y-axis (non-numeric) labels, the background type, the way +C in which graphs are positioned and scaled, and the type of dash +C patterns to be used in drawing curves. +C +C -- DISPLA (LFRA,LROW,LTYP) - may be used to specify when, if ever, +C the EZ... routines do a frame advance, how input arrays for EZMY +C and EZMXY are dimensioned, and the linear/log nature of graphs. +C +C -- AGSETP (TPGN,FURA,LURA) - a general-purpose parameter-setting +C routine, used to set the group of parameters specified by TPGN, +C using values obtained from the array (FURA(I),I=1,LURA). +C +C -- AGSETF (TPGN,FUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FUSR. +C +C -- AGSETI (TPGN,IUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FLOAT(IUSR). +C +C -- AGSETC (TPGN,CUSR) - the character string CUSR is stashed in an +C array inside AUTOGRAPH and the floating-point equivalent of an +C identifier which may be used for later retrieval of the string is +C stored as the value of the single parameter specified by TPGN. The +C single parameter must be a label name, a dash pattern, the text of +C a label line, or the line-terminator character. +C +C -- AGGETP (TPGN,FURA,LURA) - a general-purpose parameter-getting +C routine, used to get the group of parameters specified by TPGN, +C putting the result in the array (FURA(I),I=1,LURA). +C +C -- AGGETF (TPGN,FUSR) - used to get, in FUSR, the floating-point +C value of the single parameter specified by TPGN. +C +C -- AGGETI (TPGN,IUSR) - used to get, in IUSR, the integer equivalent +C of the value of the single parameter specified by TPGN. +C +C -- AGGETC (TPGN,CUSR) - used to get, in CUSR, the character string +C whose identifier is specified by the integer equivalent of the +C single parameter specified by TPGN. The single parameter must +C be a label name, a dash pattern, the text of a label line, or the +C line-terminator character. +C +C The following are lower-level routines, which may be used to draw +C graphs of many different kinds. The EZ... routines call these. They +C are intended to be called by user programs, as well. +C +C -- AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) - this +C routine must be called prior to the first call to either of the +C two routines AGBACK and AGCURV, to force the set-up of secondary +C parameters controlling the behavior of those routines. After any +C parameter-setting call, AGSTUP must be called again before calling +C either AGBACK or AGCURV again. AGSTUP calls the routine "SET", in +C the plot package, so that user x/y coordinates in subsequent calls +C will map properly into the plotter space. +C +C -- AGBACK - draws the background defined by the current state of the +C AUTOGRAPH control parameters. +C +C -- AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) - draws the curve defined +C by the arguments, positioning it as specified by the current state +C of the AUTOGRAPH control parameters. +C +C The following utility routines are called by the user. +C +C -- AGSAVE (IFNO) - used to save the current state of AUTOGRAPH by +C writing the appropriate information to a specified file. Most +C commonly used to save the default state for later restoration. +C This routine should be used instead of AGGETP when the object +C is to save the whole state of AUTOGRAPH, since it saves not only +C the primary control parameters, but all of the character strings +C pointed to by the primary control parameters. It is the user's +C responsibility to position the file before calling AGSAVE. +C +C -- AGRSTR (IFNO) - used to restore a saved state of AUTOGRAPH by +C reading the appropriate information from a specified file. Most +C commonly used to restore AUTOGRAPH to its default state. It is +C the user's responsibility to position the file before calling +C AGRSTR. +C +C -- AGBNCH (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given a 16-bit binary dash pattern, is the equivalent character +C dash pattern. +C +C -- AGDSHN (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given an integer "n" (typically between 1 and 26) is the character +C string 'DASH/ARRAY/nnnn.', which is the name of the nth dash +C pattern parameter. To set the 13th dash pattern, for example, +C one might use "CALL AGSETC (AGDSHN(13),'$$$$$$CURVE 13$$$$$$')". +C +C The following utility routines are called by AUTOGRAPH. The versions +C included in AUTOGRAPH itself are dummies; they do nothing but RETURN. +C The user may replace one or more of these routines with versions to +C accomplish specific purposes. +C +C -- AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) - called by AUTOGRAPH to perform +C the mapping from user-system values along an axis to label-system +C values along the axis and vice-versa. This routine may be replaced +C by the user to create a desired graph. +C +C -- AGCHAX (IFLG,IAXS,IPRT,VILS) - called by AUTOGRAPH just before and +C just after the various parts of the axes are drawn. +C +C -- AGCHCU (IFLG,KDSH) - called by AUTOGRAPH just before and just after +C each curve is drawn. +C +C -- AGCHIL (IFLG,LBNM,LNNO) - called by AUTOGRAPH just before and just +C after each line of an informational label is drawn. +C +C -- AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) - called by +C AUTOGRAPH just after the character strings defining a numeric label +C have been generated. +C +C --------------------------------------------------------------------- +C D E S C R I P T I O N S O F A R G U M E N T S +C --------------------------------------------------------------------- +C +C In calls to the routines EZY, EZXY, EZMY, and EZMXY: +C +C -- XDRA is an array of x coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as an +C x coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- YDRA is an array of y coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as a +C y coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- IDXY is the first dimension of the arrays XDRA (if it has two +C dimensions) and YDRA. +C +C -- MANY is the number of curves to be drawn by the call to EZ... - +C normally, the second dimension of XDRA (if it has two dimensions) +C and YDRA. +C +C -- NPTS is the number of points defining each curve to be drawn by +C the routine EZ... - normally, the first (or only) dimension of +C XDRA and YDRA. +C +C -- GLAB is a character constant or a character variable, defining a +C label to be placed at the top of the graph. The string may not be +C more than 40 characters long - if it is fewer than 40 characters +C long, its last character must be a dollar sign. (The dollar sign +C is not a part of the label - it is stripped off.) The character +C string "CHAR(0)" may be used to indicate that the previous label, +C whatever it was, should continue to be used. The initial graph +C label consists of blanks. +C +C In calls to the routine ANOTAT: +C +C -- XLAB and YLAB resemble GLAB (see above) and define labels for the +C x and y axes. The default x-axis label is the single character +C X, the default y-axis label the single character Y. Note that one +C may use the string "CHAR(0)" to indicate that the x-axis (y-axis) +C label is not to be changed from what it was previously. +C +C -- LBAC, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'BACKGROUND.', as follows: +C +C 1 - a perimeter background +C +C 2 - a grid background +C +C 3 - an axis background +C +C 4 - no background +C +C The default value of 'BACKGROUND.' is 1. +C +C -- LSET, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'SET.'. This parameter may be negated to suspend the +C drawing of curves by the EZ... routines, so that a call to one of +C them will produce only a background. The absolute value of 'SET.' +C affects the way in which AUTOGRAPH determines the position and +C shape of the graph and the scaling of the axes, as follows: +C +C 1 - Restores the default values of the AUTOGRAPH parameters +C in question. AUTOGRAPH will set up an appropriate call +C to the plot-package routine "SET", over-riding any prior +C call to that routine. +C +C 2 - Tells AUTOGRAPH to use arguments 1-4 and 9 of the last +C "SET" call. Arguments 1-4 specify where the graph should +C fall on the plotter frame, argument 9 whether the graph +C is linear/linear, linear/log, etc. +C +C 3 - Tells AUTOGRAPH to use arguments 5-8 and 9 of the last +C "SET" call. Arguments 5-8 specify the scaling of the +C axes, argument 9 whether the graph is linear/linear, +C linear/log, etc. +C +C 4 - A combination of 2 and 3. Arguments 1-4 of the last "SET" +C call specify the position, arguments 5-8 the scaling, and +C argument 9 the linear/log nature, of the graph. +C +C (The plot-package routine "SET" is described in the NCAR Graphics +C Manual; it is not a part of AUTOGRAPH.) +C +C If the routine DISPLA is called with its argument LTYP non-zero, +C the linear/log nature of the graph will be that specified by LTYP, +C not that specified by the last "SET" call, no matter what the value +C of the control parameter 'SET.'. +C +C The default value of 'SET.' is 1. +C +C -- NDSH, if non-zero, specifies a new value of the AUTOGRAPH control +C parameter 'DASH/SELECTOR.' (and therefore a new set of dashed-line +C patterns), as described below. Note: The default value of the +C dashed-line parameters is such that all curves will be drawn using +C solid lines; if that is what you want, use a zero for NDSH. +C +C If the value of 'DASH/SELECTOR.' is negative, curves produced +C by subsequent calls to EZMY or EZMXY will be drawn using a +C set of alphabetic dashed-line patterns. The first curve drawn +C by a given call will be labelled 'A', the second 'B', ..., the +C twenty-sixth 'Z', the twenty-seventh 'A' again, and so on. +C Curves drawn by calls to EZY and EZXY will be unaffected. +C +C If the value of 'DASH/SELECTOR.' is positive, it must be less +C than or equal to 26. The next argument, DSHL, is an array +C containing NDSH dashed-line patterns. All curves produced by +C subsequent calls to EZY, EZXY, EZMY, and EZMXY will be drawn +C using the dashed-line patterns in (DSHL(I),I=1,NDSH) - the +C first curve produced by a given call will have the pattern +C specified by DSHL(1), the second that specified by DSHL(2), +C the third that specified by DSHL(3), . . . the NDSH+1st that +C specified by DSHL(1), . . . etc. Each element of DSHL must +C be a character string, in which a dollar sign stands for a +C solid-line segment, a quote stands for a gap, and other +C characters stand for themselves. See the write-up of the +C package "DASHCHAR". Binary dashed-line patterns may not be +C defined by means of a call to ANOTAT, only by means of calls +C to lower-level routines. +C +C -- DSHL (if NDSH is greater than zero) is an array of dashed-line +C patterns, as described above. +C +C In calls to the routine DISPLA: +C +C -- LFRA, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'FRAME.'. Possible values are as follows: +C +C 1 - The EZ... routines do a frame advance after drawing. +C +C 2 - No frame advance is done by the EZ... routines. +C +C 3 - The EZ... routines do a frame advance before drawing. +C +C The default value of 'FRAME.' is 1. +C +C -- LROW, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'ROW.'. This parameter tells AUTOGRAPH how the argument +C arrays XDRA and YDRA, in calls to the routines EZMY and EZMXY, are +C subscripted, as follows: +C +C If 'ROW.' is positive, this implies that the first subscript +C of YDRA is a point number and the second subscript is a curve +C number. If 'ROW.' is negative, the order is reversed. +C +C If the absolute value of 'ROW.' is 1, this implies that XDRA +C is singly-subscripted, by point number only. If the absolute +C value of 'ROW.' is 2 or greater, this implies that XDRA is +C doubly-subscripted, just like YDRA. +C +C The default value of 'ROW.' is 1, spicifying that XDRA is singly- +C subscripted and that YDRA is doubly-subscripted by point number +C and curve number, in that order. +C +C -- LTYP, if non-zero, specifies new values for the AUTOGRAPH control +C parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.', which determine +C whether the X and Y axes are linear or logarithmic. Possible +C values are as follows: +C +C 1 - x axis linear, y axis linear +C +C 2 - x axis linear, y axis logarithmic +C +C 3 - x axis logarithmic, y axis linear +C +C 4 - x axis logarithmic, y axis logarithmic +C +C The default values of these parameters make both axes linear. +C +C If the parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.' are reset +C by the routine DISPLA, they are given values which make them +C immune to being reset when 'SET.' = 2, 3, or 4 (see the discussion +C of the argument LSET, above). +C +C In calls to the routines AGSETP, AGSETF, AGSETI AGSETC, AGGETP, +C AGGETF, AGGETI, and AGGETC: +C +C -- TPGN is a character string identifying a group of AUTOGRAPH +C control parameters. It is of the form 'K1/K2/K3/ . . . /Kn.'. +C Each Ki is a keyword. The keyword K1 specifies a group of control +C parameters, K2 a subgroup of that group, K3 a subgroup of that +C subgroup, etc. See the AUTOGRAPH write-up in the graphics manual +C for a more complete description of these parameter-group names and +C the ways in which they may be abbreviated. +C +C -- FURA is an array, from which control-parameter values are to be +C taken (the routine AGSETP) or into which they are to be stored +C (the routine AGGETP). Note that the array is real; all of the +C AUTOGRAPH parameters are stored internally as reals. +C +C -- LURA is the length of the user array FURA. +C +C -- FUSR is a variable, from which a single control parameter value is +C to be taken (the routine AGSETF) or in which it is to be returned +C (the routine AGGETF). Note that the variable is real. +C +C -- IUSR is a variable, from which a single-control parameter value is +C to be taken (the routine AGSETI) or in which it is to be returned +C (the routine AGGETI). Note that, since the control parameters are +C stored internally as reals, each of the routines AGSETI and AGGETI +C does a conversion - from integer to real or vice-versa. Note also +C that AGSETI and AGGETI should only be used for parameters which +C have intrinsically integral values. +C +C -- CUSR is a character variable from which a character string is to +C be taken (the routine AGSETC) or into which it is to be retrieved +C (the routine AGGETC). The control parameter affected by the call +C contains the floating-point equivalent of an integer identifier +C returned by the routine which stashes the character string and +C tendered to the routine which retrieves it (sort of the automated +C equivalent of a hat check). Note that AGSETC and AGGETC should +C only be used for parameters which intrinsically represent character +C strings. +C +C In calls to the routine AGSTUP: +C +C -- XDRA is an array of x coordinates of user data - usually, but not +C necessarily, the same data which will later be used in calls to +C the routine AGCURV. +C +C -- NVIX is the number of vectors of data in XDRA - if XDRA is doubly- +C dimensioned, NVIX would normally have the value of its second +C dimension, if XDRA is singly-dimensioned, a 1. +C +C -- IIVX is the index increment between vectors in XDRA - if XDRA is +C doubly-dimensioned, IIVX would normally have the value of its +C first dimension, if XDRA is singly-dimensioned, a dummy value. +C +C -- NEVX is the number of elements in each data vector in XDRA - if +C XDRA is doubly-dimensioned, NEVX would normally have the value of +C its first dimension, if XDRA is singly-dimensioned, the value of +C that single dimension. +C +C -- IIEX is the index increment between elements of a data vector in +C XDRA - normally a 1. +C +C -- YDRA, NVIY, IIVY, NEVY, and IIEY are analogous to XDRA, NVIX, +C IIVX, NEVX, and IIEX, but define y-coordinate data. +C +C In calls to the routine AGCURV: +C +C -- XVEC is a vector of x coordinate data. +C +C -- IIEX is the index increment between elements in XVEC. AGCURV will +C use XVEC(1), XVEC(1+IIEX), XVEC(1+2*IIEX), etc. +C +C -- YVEC is a vector of y coordinate data. +C +C -- IIEY is the index increment between elements in YVEC. AGCURV will +C use YVEC(1), YVEC(1+IIEY), YVEC(1+2*IIEY), etc. +C +C -- NEXY is the number of points defining the curve to be drawn. +C +C -- KDSH is a dashed-line selector. Possible values are as follows: +C +C If KDSH is zero, AUTOGRAPH will assume that the user has +C called the routine DASHD (in the DASHCHAR package, which see) +C to define the dashed-line pattern to be used. +C +C If KDSH is less than zero and has absolute value M, AUTOGRAPH +C will use the Mth (modulo 26) alphabetic dashed-line pattern. +C Each of these patterns defines a solid line interrupted every +C so often by a letter of the alphabet. +C +C If KDSH is greater than zero and has the value M, AUTOGRAPH +C will use the Mth (modulo N) dashed-line pattern in the group +C of N dashed-line patterns defined by the AUTOGRAPH control +C parameters in the group named 'DASH/PATTERNS.'. The default +C values of these parameters specify solid lines. +C +C In calls to the routines AGSAVE and AGRSTR: +C +C -- IFNO is the unit number associated with a file to which a single +C unformatted logical record of data is to be written, or from which +C such a record is to be read, by AUTOGRAPH. The file is not rewound +C before being written or read; positioning it properly is the user's +C responsibility. +C +C In calls to the function AGBNCH: +C +C -- IDSH is a 16-bit binary dash pattern, the character equivalent of +C which is to be returned as the value of AGBNCH. +C +C In calls to the function AGDSHN: +C +C -- IDSH is the number of the dash pattern parameter whose name is to +C be returned as the value of the function AGDSHN. +C +C In calls to the routine AGUTOL: +C +C -- IAXS is the number of the axis. The values 1, 2, 3, and 4 imply +C the left, right, bottom, and top axes, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.' which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C In calls to the routine AGCHAX: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 indicate the left, right, bottom, and top axes, respectively. +C +C -- IPRT indicates the part of the axis being drawn. Possible values +C are as follows: +C +C -- 1 implies the line of the axis. +C +C -- 2 implies a major tick. +C +C -- 3 implies a minor tick. +C +C -- 4 implies the mantissa of a numeric label. +C +C -- 5 implies the exponent of a numeric label. +C +C -- VILS is the value in the label system at the point where the part +C is being drawn. For IPRT = 1, VILS is zero. +C +C In calls to the routine AGCHCU: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- KDSH is the value with which AGCURV was called, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C In calls to the routine AGCHIL: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- LBNM is a character variable containing the name of the label being +C drawn. +C +C -- LNNO is the number of the line being drawn. +C +C In calls to the routine AGCHNL: +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 imply the left, right, bottom, and top axes, respectively. +C +C -- VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C -- CHRM, on entry, is a character string containing the mantissa of +C the numeric label, as it will appear if AGCHNL makes no changes. +C If the numeric label includes a "times" symbol, it is represented +C by a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C -- MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C -- NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C -- IPXM, on entry, is zero if there is no "times" symbol in CHRM; if +C it is non-zero, it is the index of a character position in CHRM. +C If AGCHNL changes the position of the "times" symbol in CHRM, +C removes it, or adds it, the value of IPXM must be changed. +C +C -- CHRE, on entry, is a character string containing the exponent of +C the numeric label, as it will appear if AGCHNL makes no changes. +C CHRE may be modified. +C +C -- MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C -- NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C --------------------------------------------------------------------- +C T H E A U T O G R A P H C O D E +C --------------------------------------------------------------------- +C +C Following is the AUTOGRAPH code. Routines appear in alphabetic order. +C + SUBROUTINE AGAXIS (IAXS,QTST,QSPA,WCWP,HCWP,XBGA,YBGA,XNDA,YNDA, + + QLUA,UBGA,UNDA,FUNS,QBTP,BASE,QJDP,WMJL,WMJR, + + QMNT,QNDP,WMNL,WMNR,QLTP,QLEX,QLFL,QLOF,QLOS, + + DNLA,WCLM,WCLE,RFNL,QCIM,QCIE,WNLL,WNLR,WNLB, + + WNLE) +C +C The routine AGAXIS is used to draw, tick-mark, and label an axis or, +C if ITST is non-zero, to pre-compute the amount of space which will be +C required for numeric labels when the axis is actually drawn. AGAXIS +C assumes that the last call to the plot-package routine SET was as +C follows (or the equivalent thereof): +C +C CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1) +C +C where XLCW, XRCW, YBCW, and YTCW are the coordinates of the left, +C right, bottom, and top edges of the curve window, stated as fractions +C of the appropriate edge of the plotter frame. +C +C The arguments of AGAXIS are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4, meaning +C the left, right, bottom, and top axes, respectively. +C +C -- ITST is an integer specifying what the caller wishes AGAXIS to do, +C as follows: +C +C -- If ITST .LT. 0, AGAXIS is to draw only the axis, nothing else. +C +C -- If ITST .EQ. 0, AGAXIS is to draw, tick, and label the axis. +C +C -- If ITST .GT. 0, AGAXIS is to pre-compute the amount of space +C which will be required for numeric labels. If the labels will +C not fit in the space provided, AGAXIS is instructed to take +C action as follows: +C +C -- ITST .EQ. 1 - no action. +C +C -- ITST .EQ. 2 - shrink the labels. +C +C -- ITST .EQ. 3 - re-orient the labels. +C +C -- ITST .EQ. 4 - shrink and/or re-orient the labels. +C +C -- ISPA is a 0 or a 1, specifying whether or not the axis itself is +C to be drawn. If ISPA .NE. 0, the axis is suppressed. Tick marks +C and/or labels may still be drawn. +C +C -- WCWP is the width of the curve window, in plotter units. +C +C -- HCWP is the height of the curve window, in plotter units. +C +C -- XBGA, YBGA, XNDA, and YNDA are the x and y coordinates of the ends +C of the axis. X coordinates are stated as fractions of the width, +C y coordinates as fractions of the height, of the curve window. The +C axis to be drawn must be either horizontal or vertical (at an angle +C of 0, 90, 180, or 270 degrees). The left side, right side, begin- +C ning, and end of the axis are defined from the viewpoint of a demon +C standing at (XBGA,YBGA) and staring balefully toward (XNDA,YNDA). +C +C -- LLUA, UBGA, and UNDA define the mapping of the "user" coordinate +C system (used for data-point coordinates) onto the axis. If LLUA +C is zero, the mapping is linear; if LLUA is non-zero, the mapping +C is logarithmic. UBGA is the user-system value at the beginning of +C the axis, UNDA the value at the end of the axis. The subroutine +C AGFTOL, which needs these parameters, is actually passed LLUA, +C UBEG=F(UBGA), and UDIF=F(UNDA)-F(UBGA), where F is the function +C F(X)=X or the function F(X)=ALOG10(X), depending on LLUA. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL, which +C defines the mappings from the user system to the label system and +C vice-versa for each of the four axes. The functions defined must +C be continuous, monotonic, and bounded within the user-system range +C (UBGA,UNDA) and a little bit outside that range. The positions +C of numeric labels and tick marks are chosen in the label system, +C mapped to the user system, and then onto the axis. +C +C -- NBTP and BASE specify how major ticks are to be positioned in the +C label coordinate system. See the routine AGNUMB (arguments NBTP, +C SBSE, and EXMU) for a description of these arguments. Note that +C NBTP .EQ. 0 or BASE .EQ. 0. suppresses both major tick marks and +C their labels. Note: SBSE .EQ. +BASE or -BASE, as needed. +C +C -- QJDP is the major-tick-mark dash pattern (0. .LE. QJDP .LE. 65535.) +C QJDP .LE. 0 suppresses major ticks. +C +C -- WMJL and WMJR are the distances to the left and right ends of the +C major tick marks, stated as fractions of the shortest side of the +C curve window. Values .EQ. 0 may be used to suppress one or both +C portions. Values .GE. 1 may be used to extend a given portion all +C the way to the edge of the curve window. (See routine AGCTKO.) +C +C -- NMNT is the number of minor tick marks to be placed between each +C pair of consecutive major tick marks. NMNT .EQ. 0 suppresses them. +C +C -- QNDP, WMNL, and WMNR are analogous to QJDP, WMJL, and WMJR, but +C specify minor-tick-mark characteristics. +C +C -- NLTP, NLEX, and NLFL specify the graphic form of numeric labels, as +C described in the routine AGNUMB (which see). Note that NLTP .LE. 0 +C suppresses numeric labels. +C +C -- NLOF and NLOS are first and second choices for the numeric label +C orientation. Both must be multiples of 90, specifying an angle +C measured in degrees counter-clockwise from a vector running from +C left to right in the curve window. If ITST .EQ. 0, AGAXIS uses +C NLOF if it is .GE. 0, NLOS otherwise, for the label orientation. +C If ITST .NE. 0, AGAXIS initially makes both NLOF and NLOS positive. +C Then, if ITST .GE. 3, NLOF may or may not be made negative. (To +C set the sign of NLOF or NLOS, AGAXIS adds or subtracts 360*K.) +C +C -- DNLA is the desired distance of numeric labels from the axis, +C positive to the left, negative to the right, of the axis. The +C magnitude of DNLA is the size of the gap between the axis and the +C nearest edge of a label, expressed as a fraction of the smaller +C dimension of the curve window. See also RFNL, below. +C +C -- WCLM and WCLE are the desired widths of characters in the mantissa +C or the exponent, respectively, of numeric labels, expressed as a +C fraction of the smaller dimension of the curve window. See also +C RFNL, below. +C +C -- RFNL is a reduction factor, used as a multiplier for DNLA, WCLM, +C and WCLE. If ITST .NE. 0, RFNL is initially set to 1. - then, if +C ITST .EQ. 2 or 4, it is reset as necessary to shrink the labels. +C +C -- MCIM and MCIE specify the maximum number of characters in the +C mantissa and exponent, respectively, of a numeric label. These +C are input parameters if ITST .EQ. 0, output parameters otherwise. +C +C -- WNLL, WNLR, WNLB, and WNLE are the widths of numeric-label strips +C on the left side, on the right side, at the beginning, and at the +C end, of the axis. These are both input and output parameters of +C AGAXIS. On input, they specify the amount of space available for +C numeric labels - on output, they specify the amount of space used +C (if ITST .EQ. 0) or required (if ITST .NE. 0). Each is stated as +C a fraction of either the width or the height of the curve window, +C depending on the orientation of the axis in the curve window. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C actually used here are ISLD, MWCM, MWCE, and MDLA. ISLD is a solid- +C line dash pattern (sixteen one bits). MWCM, MWCE, and MDLA specify +C the minimum allowed values of the width of a character in a label +C mantissa, the width of a character in a label exponent, and the +C distance of a label from the axis. All are in plotter coordinate +C units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C +C Local data required are as follows: +C +C BFRM is a buffer in which the routine AGNUMB returns the characters of +C a label mantissa. CTMP holds a sub-string from an AGPWRT call. +C + CHARACTER*40 BFRM + CHARACTER*40 CTMP +C +C BFRE is a buffer in which the routine AGNUMB returns the characters of +C a label exponent. +C + CHARACTER*5 BFRE +C +C XMJT, YMJT, XMNT, and YMNT are used to hold x and y offsets to the +C endpoints of left-of-label and right-of-label portions of major and +C minor tick marks. +C + DIMENSION XMJT(4),YMJT(4),XMNT(4),YMNT(4) +C +C SMJP is the minimum distance allowed between major tick marks, in +C plotter coordinate units. +C + DATA SMJP / 4. / +C +C FBGM, FBGP, FNDM, and FNDP are the coordinates of points a little on +C either side of the beginning and end of the axis, as fractions of the +C distance along the axis. +C + DATA FBGM / -0.000001 / + DATA FBGP / +0.000001 / + DATA FNDM / +0.999999 / + DATA FNDP / +1.000001 / +C +C HCFW is an arithmetic statement function specifying the height of a +C character as a function of its width (not counting "white space"). +C The value of the multiplier was determined heuristically, by trying +C various values and seeing which gave the best results. +C + HCFW(WDTH)=1.25*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the initialization section of AGAXIS. +C +C Unpack integer values from floating-point arguments. +C + ITST=IFIX(QTST) + ISPA=IFIX(QSPA) + LLUA=IFIX(QLUA) + NBTP=IFIX(QBTP) + NMNT=IFIX(QMNT) + NLTP=IFIX(QLTP) + NLEX=IFIX(QLEX) + NLFL=IFIX(QLFL) + NLOF=IFIX(QLOF) + NLOS=IFIX(QLOS) + MCIM=IFIX(QCIM) + MCIE=IFIX(QCIE) +C +C Initialize the local flags which specify what entities to draw, using +C values appropriate for the following quick exit. +C + LDAX=1-ISPA + LDNL=0 + LDMN=0 +C +C If AGAXIS is to draw only the axis, exit immediately. +C + IF (ITST.LT.0) GO TO 800 +C +C If either NBTP or BASE is zeroed, exit immediately. +C + IF (NBTP.EQ.0.OR.BASE.EQ.0.) GO TO 800 +C +C Re-initialize the flag controlling the drawing of numeric labels. +C + IF (NLTP.NE.0) LDNL=1 +C +C If this is not a test run, skip. +C + IF (ITST.EQ.0) GO TO 101 +C +C This is a test run - exit if there are no numeric labels. +C + IF (LDNL.EQ.0) GO TO 800 +C +C This is a test run and the axis is to have numeric labels - initialize +C the numeric-label orientation and sizing parameters. Clobber drawing. +C + NLOF=MOD(NLOF+3600,360) + NLOS=MOD(NLOS+3600,360) + RFNL=1. + MCIM=0 + MCIE=0 + LDMJ=0 + LDMN=0 +C +C The main body of the initialization follows. +C +C Compute the length of the smaller side of the curve window, in the +C plotter coordinate system. +C + 101 SCWP=AMIN1(WCWP,HCWP) +C +C Compute a set of direction numbers for the axis, in the curve-window +C coordinate system (the change in x and y from the beginning to the +C end of the axis). +C + XDNA=XNDA-XBGA + YDNA=YNDA-YBGA +C +C Compute the length of the axis in the plotter coordinate system and +C its direction cosines. +C + XDNP=XDNA*WCWP + YDNP=YDNA*HCWP + AXLP=SQRT(XDNP*XDNP+YDNP*YDNP) + XDCA=XDNP/AXLP + YDCA=YDNP/AXLP +C +C Compute the axis orientation angle, in degrees counter-clockwise. +C + IAOR=MOD(IFIX(57.2957795130823*ATAN2(YDCA,XDCA)+3600.5),360) +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the width or height of the curve +C window (a distance in x or y). +C + CFAX=AXLP/WCWP + CFAY=AXLP/HCWP +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the along-axis and perpendicular-to- +C axis sides of the curve window. +C + CFAA=ABS(XDCA*CFAX+YDCA*CFAY) + CFAP=ABS(XDCA*CFAY+YDCA*CFAX) +C +C Compute the quantities (UBEG) and (UDIF) for AGFTOL. +C + IF (LLUA.NE.0) GO TO 102 +C + UBEG=UBGA + UDIF=UNDA-UBGA + GO TO 103 +C + 102 UBEG=ALOG10(UBGA) + UDIF=ALOG10(UNDA)-UBEG +C +C SMJT and SMNT are fractions of the axis length and specify the minimum +C space which must be available between two major ticks before the major +C ticks themselves or the minor ticks between them, respectively, may be +C drawn. +C + 103 SMJT=SMJP/AXLP + SMNT=SMJT*FLOAT(NMNT+1) +C +C Initialize the fractional numeric-label character heights. +C + FHCM=0. + FHCE=0. +C +C If the axis has no numeric labels, skip the following code. +C + IF (LDNL.EQ.0) GO TO 104 +C +C Zero the numeric-label offset. +C + FNLO=0. +C +C The numeric-label parameters are computed by an internal procedure +C (which see, below). +C + ASSIGN 104 TO JMP3 + GO TO 500 +C +C If this is a test run, skip the following code. +C + 104 IF (ITST.NE.0) GO TO 200 +C +C This is not a test run. First, set up the tick-mark parameters. +C +C Compute the multiplicative constant required to convert a fraction of +C the smaller dimension of the grid to a fraction of the axis length. +C + CSFA=SCWP/AXLP +C +C Compute the widths of the left and right portions of the numeric-label +C space as fractions of the axis length, affixing an appropriate sign. +C + FNLL=-WNLL/CFAP + FNLR=+WNLR/CFAP +C +C Compute a jump parameter to sort out the axis orientations. +C + JAOR=1+IAOR/90 +C +C The routine AGCTKO is used to compute the rest of the tick parameters. +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR, 1,QJDP, + + WMJL,WMJR,FNLL,FNLR,MJ12,MJ34,XMJT,YMJT) +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMNT,QNDP, + + WMNL,WMNR,FNLL,FNLR,MN12,MN34,XMNT,YMNT) +C +C Set the flags controlling the drawing of tick marks. +C + LDMJ=MJ12+MJ34 + LDMN=MN12+MN34 + LDLR=-(LDMJ+LDMN) +C +C If no numeric labels are to be drawn, skip the following code. +C + IF (LDNL.EQ.0) GO TO 117 +C +C Numeric labels are to be drawn. Precompute parameters which will be +C used to position labels relative to the axis. +C +C Compute the widths and heights of the longest possible label mantissa +C and exponent, as fractions of the length of the axis. +C + FWLM=FLOAT(MCIM)*FWCM + FWLE=FLOAT(MCIE)*FWCE + FHLM=FHCM + FHLE=FHCE + IF (MCIE.EQ.0) FHLE=0. +C +C Jump on the label-to-axis orientation. +C + GO TO (105,106,107,108) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 105 FBLP=-FHLM + GO TO 109 +C +C Label is at a 90-degree angle to the axis. +C + 106 FBLA=0. + FBLQ=-FWLM-FWLE + GO TO 110 +C +C Label is at a 180-degree angle to the axis. +C + 107 FBLP=FHLM+FHLE + GO TO 109 +C +C Label is at a 270-degree angle to the axis. +C + 108 FBLA=0. + FBLQ=FWLM+FWLE + GO TO 110 +C +C Label is parallel to the axis. +C + 109 FNLW=FHLM+.5*FHLE + FBLQ=0. + GO TO 111 +C +C Label is perpendicular to the axis. +C + 110 FNLW=FWLM+FWLE + FBLP=0. +C +C If the labels will not fit in the space provided, clobber them. +C + 111 IF (.999999*FNLW.LT.FNLR-FNLL) GO TO 112 +C + LDNL=0 + GO TO 117 +C +C Jump on the signed value of the numeric-label distance from the axis. +C + 112 IF (DNLA) 113,114,115 +C +C Labels are to the right of the axis. +C + 113 FNLC=FDLA+.5*FNLW + FBLP=FDLA+.5*ABS(FBLP-FHLE) + FBLQ=FDLA+.5*ABS(FBLQ+FWLM-FWLE) + GO TO 116 +C +C Labels are centered on the axis. +C + 114 FNLC=0. + FBLP=0. + FBLQ=0. + GO TO 116 +C +C Labels are to the left of the axis. +C + 115 FNLC=-(FDLA+.5*FNLW) + FBLP=-(FDLA+.5*ABS(FBLP)) + FBLQ=-(FDLA+.5*ABS(FBLQ-FWLM+FWLE)) +C + 116 FNLO=.5*(FNLL+FNLR)-FNLC +C +C If the axis would pass through the offset labels, clobber it. +C + IF (FNLL*FNLR.LT.0.) LDAX=0 +C +C Jump to draw numeric labels and/or tick marks. +C + GO TO 200 +C +C No numeric labels are to be drawn. If no tick marks are to be drawn +C either, exit. +C + 117 IF (LDLR.EQ.0) GO TO 800 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following code directs the process of tick-marking and labelling +C the axis, using the internal procedures which follow it. If the +C label-coordinate-system value 0 maps onto the axis, tick-marking and +C labelling are done in two passes, one starting at 0 and proceeding +C in a positive direction and the other starting at 0 and proceeding +C in a negative direction. If the label-coordinate-system value 0 does +C not map onto the axis, only one pass is required. +C +C First, determine the label-coordinate-system values VBGM and VNDP at +C the points FBGM and FNDP, a little beyond the ends of the axis. +C + 200 CALL AGFTOL (IAXS,1,FBGM,VBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + CALL AGFTOL (IAXS,1,FNDP,VNDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C If zero falls on the axis, jump to the two-pass section of the code. +C + IF (VBGM*VNDP.LE.0.) GO TO 201 +C +C We may tick-mark and label the axis in a single pass. Compute an +C appropriate starting value for the exponent/multiplier EXMU. +C + SBSE=SIGN(BASE,VBGM) + CALL AGFTOL (IAXS,2,FBGM,EBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + CALL AGFTOL (IAXS,2,FNDP,ENDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=AMIN1(EBGM,ENDP) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Set the numeric-label-space limits for the beginning and end of the +C axis. +C + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Jump to an internal procedure to tick-mark and label the axis. Return +C from there to the termination section of AGAXIS. +C + ASSIGN 800 TO JMP1 + GO TO 300 +C +C Tick marks and labels must be done in two passes. First, draw the +C tick mark and/or label at the zero position in the label system, using +C an internal procedure below. A number of parameters must be preset. +C + 201 CALL AGFTOL (IAXS,-1,0.,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C Determine whether label is to be drawn or not. +C + LDLB=0 + IF (LDNL.EQ.0) GO TO 202 + LDLB=1 +C +C The mantissa portion of the label consists of the single character 0. +C + BFRM(1:1)='0' + NCIM=1 + IPXM=0 +C +C The label has no exponent portion. +C + NCIE=0 +C +C Allow the user to change the numeric label. +C + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C Compute the length of the mantissa, the exponent, and the whole label. +C + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C The numeric-label space begins and ends at impossible values. +C + FNLB=-10. + FNLE=+10. +C +C Force the labeler to update FNLB, rather than FNLE. +C + FDIR=1. +C +C Jump to an internal procedure to draw the label and/or the tick mark. +C + 202 ASSIGN 203 TO JMP2 + GO TO 400 +C +C Save the position of the zero-point (FRAX, expressed as a fraction of +C the axis length) and preset the parameter DZRT, which is the minimum +C distance from the zero-point at which a major tick mark could occur, +C and the parameter DZRL, which is the minimum distance from the zero- +C point at which a label could occur. Set the label-space limit FNLE. +C Preset the internal-procedure exit parameter JMP1. +C + 203 ASSIGN 205 TO JMP1 + FZRO=FRAX + DZRT=AMAX1(SMJT,1.6*FLOAT(LDNL)*FHCM) + IF (LDNL.EQ.0) GO TO 204 + DZRL=FNLB-FZRO + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Do the portion of the axis lying in the direction specified by DZRT. +C If it is too short, skip it entirely. +C + 204 FRAX=FZRO+DZRT + IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Find out whether BASE must be negated for this portion. +C + CALL AGFTOL (IAXS,1,FRAX,VLCS,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + SBSE=SIGN(BASE,VLCS) +C +C Compute a starting value of the exponent/multiplier EXMU. +C + CALL AGFTOL (IAXS,2,FRAX,EXMU,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Jump to an internal procedure to draw the tick marks and/or labels. +C + GO TO 300 +C +C Set up to do the second portion of the axis, then go do it. +C + 205 ASSIGN 800 TO JMP1 + DZRT=-DZRT + IF (LDNL.EQ.0) GO TO 204 + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FZRO-DZRL + GO TO 204 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP1. Its purpose is to tick-mark and label a portion of the +C axis (perhaps the entire axis) at positions determined by consecutive +C values of the parameter EXMU. It prevents tick marks from piling up +C or passing through the label space and prevents overlapping of labels. +C Tick marks are drawn alternately from left to right or vice-versa. +C +C The caller has provided an initial value of EXMU, but we must consider +C possible minor tick marks in the interval (EXMU-1.,EXMU). +C + 300 EXMU=EXMU-1. +C +C Compute FRAX, which is the fractional distance along the axis, and +C VLCS, which is the value in the label coordinate system corresponding +C to the current value of EXMU. +C + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C Move the current values of EXMU, FRAX, and VLCS to ELST, FLST, and +C VLST, specifying the last values of these parameters. Then increment +C EXMU by 1. and recompute FRAX and VLCS. (The loop through consecutive +C values of EXMU begins here.) +C + 301 ELST=EXMU + FLST=FRAX + VLST=VLCS +C + EXMU=EXMU+1. + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C FDIR indicates the direction, FDST the magnitude, of step along axis. +C + FDIR=FRAX-FLST + FDST=ABS(FDIR) +C +C Draw minor tick marks, if any, in the interval (FLST,FRAX). +C + IF (LDMN.EQ.0.OR.FDST.LT.SMNT) GO TO 304 +C +C Use the dashed-line pattern for minor tick marks. +C + CALL DASHDB (AGFPBN(QNDP)) +C +C Minor tick marks are equally spaced in the label-coordinate system. +C + VINC=(VLCS-VLST)/FLOAT(NMNT+1) +C + DO 303 I=1,NMNT + VMNT=VLST+VINC*FLOAT(I) + CALL AGFTOL (IAXS,-1,VMNT,FMNT,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP, + + SBSE) + IF (FMNT.LT.FBGP.OR.FMNT.GT.FNDM) GO TO 303 + XPAX=XBGA+FMNT*XDNA + YPAX=YBGA+FMNT*YDNA + LDLR=-LDLR + IF (LDLR.LT.0) GO TO 302 + CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(1),YPAX+YMNT(1), + + XPAX+XMNT(2),YPAX+YMNT(2)) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(3),YPAX+YMNT(3), + + XPAX+XMNT(4),YPAX+YMNT(4)) + CALL AGCHAX (1,IAXS,3,VMNT) + GO TO 303 + 302 CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(4),YPAX+YMNT(4), + + XPAX+XMNT(3),YPAX+YMNT(3)) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(2),YPAX+YMNT(2), + + XPAX+XMNT(1),YPAX+YMNT(1)) + CALL AGCHAX (1,IAXS,3,VMNT) + 303 CONTINUE +C +C If the end of the axis has been reached, return to caller. +C + 304 IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Draw the major tick mark and/or the numeric label at FRAX. +C + IF (FDST.LT.SMJT) GO TO 301 + LDLB=0 + IF (LDNL.EQ.0) GO TO 305 + CALL AGNUMB (NBTP,SBSE,EXMU,NLTP,NLEX,NLFL,BFRM,40,NCIM,IPXM,BFRE, + + 5,NCIE) + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C If this is not a test run, mantissa and exponent length are checked. +C + IF (ITST.EQ.0.AND.(NCIM.GT.MCIM.OR.NCIE.GT.MCIE)) GO TO 305 + LDLB=1 + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C Use the next internal procedure to draw the major tick and/or label. +C + 305 ASSIGN 301 TO JMP2 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP2. Its purpose is to draw the major tick mark and/or the +C numeric label at a specified point on the axis or, if ITST is .NE. 0, +C to predict the amount of space which will be required for such items. +C +C Jump if no label is to be drawn. +C + 400 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 410 +C +C See if the label will fit without overlapping another label. To do +C this, first compute its fractional length along the axis (FLAA). +C + GO TO (401,402,401,402) , JLAO +C +C Label is parallel to the axis. Allow for inter-label spacing. +C + 401 FLAA=FLLB+FWCM + GO TO 403 +C +C Label is perpendicular to the axis. Ignore exponent portion. +C + 402 FLAA=1.6*FHCM +C +C Compute the fractional coordinates of the endpoints of the label +C (along the axis) and see if it will fit in the available label space. +C + 403 FLBB=FRAX-.5*FLAA + FLBE=FRAX+.5*FLAA +C + IF (FLBB.GE.FNLB.AND.FLBE.LE.FNLE) GO TO 407 +C +C Label will not fit. Omit it or, if this is a test run, see if any +C remedial action is to be taken. +C + LDLB=0 + IF (ITST.EQ.0) GO TO 411 +C +C This is a test run and we have two consecutive labels which overlap. +C See what can be done about it. +C + GO TO (424,404,406,404) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 404 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 405 +C +C If not, shrink them by an amount based on the extent of the overlap, +C reset the parameters affected, and start from square one. +C + RFNL=AMIN1(.9,FDST/(FDST+AMAX1(FNLB-FLBB,FLBE-FNLE)))*RFNL + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, at least continue with finding the maximum +C mantissa and exponent lengths. +C + 405 IF (ITST.NE.4) GO TO 424 +C +C Try re-orienting the labels. If this has already been tried, or it it +C would be pointless, skip it, but continue with finding the maximum +C mantissa and exponent lengths. +C + 406 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.2.OR.JLAO.EQ.4) GO TO 424 +C +C If re-orienting makes sense, reset the appropriate parameters and +C start from square one. +C + NLOF=NLOF-360 + RFNL=1. + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C Label will fit. Update the label space limits for next time. +C + 407 IF (FDIR.GE.0.) GO TO 408 + FNLE=FLBB + GO TO 409 + 408 FNLB=FLBE +C +C If this is not just a test shot, go off and draw the tick mark/label. +C + 409 IF (ITST.EQ.0) GO TO 411 +C +C If this is a test shot, update the maximum mantissa and exponent +C lengths being generated and exit from this internal procedure. +C + MCIM=MAX0(MCIM,NCIM) + MCIE=MAX0(MCIE,NCIE) + GO TO 424 +C +C No label is to be drawn. If this is a test shot, exit from this +C internal procedure without drawing the tick mark. +C + 410 IF (ITST.NE.0) GO TO 424 +C +C Compute x and y coordinates of current axis point. +C + 411 XPAX=XBGA+FRAX*XDNA + YPAX=YBGA+FRAX*YDNA +C +C Jump if no major tick-mark is to be drawn. Otherwise, set up the +C dash pattern for major tick-marks. +C + IF (LDMJ.EQ.0) GO TO 414 + CALL DASHDB (AGFPBN(QJDP)) +C +C Flip the left-to-right/right-to-left direction flag. +C + LDLR=-LDLR +C +C Draw the first portion of the tick mark. +C + IF (LDLR) 413,414,412 +C + 412 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(1),YPAX+YMJT(1),XPAX+XMJT(2),YPAX+YMJT(2)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 414 +C + 413 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(4),YPAX+YMJT(4),XPAX+XMJT(3),YPAX+YMJT(3)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Draw the label, if any. +C + 414 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 421 +C +C Compute the distances from (XPAX,YPAX) to the beginning of the label - +C along the axis (FBLA) and perpendicular to the axis (FBLP). Each is a +C directed distance whose magnitude represents a fraction of the length +C of the axis. The values depend on the label/axis orientation and the +C distance of the label from the axis. In some cases, these quantities, +C or portions of them, have already been computed. +C + GO TO (415,416,417,418) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 415 FBLA=-.5*FLLB + GO TO 419 +C +C Label is at a 90-degree angle to the axis. +C + 416 FBLP=FBLQ+FLLM + IF (DNLA.EQ.0.) FBLP=.5*FLLB + GO TO 419 +C +C Label is at a 180-degree angle to the axis. +C + 417 FBLA=.5*FLLB + GO TO 419 +C +C Label is at a 270-degree angle to the axis. +C + 418 FBLP=FBLQ-FLLM + IF (DNLA.EQ.0.) FBLP=-.5*FLLB +C +C Draw the mantissa portion of the label (excluding the "X", if any). +C + 419 DEEX=FBLA*XDCA+(FBLP+FNLO)*YDCA + DEEY=FBLA*YDCA-(FBLP+FNLO)*XDCA + CALL AGCHAX (0,IAXS,4,VLCS) + IF (IPXM.EQ.0) THEN + CALL AGPWRT (XPAX+CFAX*DEEX, + + YPAX+CFAY*DEEY,BFRM,NCIM,IWCM,NLOR,-1) + ELSE + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-3.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-3.*FWCM)*YDCL), + + BFRM,IPXM-1,IWCM,NLOR,+1) + CTMP=BFRM(IPXM+1:NCIM) + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-2.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-2.*FWCM)*YDCL), + + CTMP,NCIM-IPXM,IWCM,NLOR,-1) + END IF + DEEX=DEEX+FLLM*XDCL + DEEY=DEEY+FLLM*YDCL +C +C Draw the "X" portion of the mantissa, if it was left out above. +C + IF (IPXM.EQ.0) GO TO 420 + DEEX=DEEX-2.5*FWCM*XDCL + DEEY=DEEY-2.5*FWCM*YDCL + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL+XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL+XDCL))) + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL-XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL-XDCL))) + DEEX=DEEX+2.5*FWCM*XDCL + DEEY=DEEY+2.5*FWCM*YDCL + 420 CALL AGCHAX (1,IAXS,4,VLCS) +C +C Draw the exponent portion of the label (if it has one). +C + IF (NCIE.EQ.0) GO TO 421 + DEEX=DEEX-.5*FHCM*YDCL + DEEY=DEEY+.5*FHCM*XDCL + CALL AGCHAX (0,IAXS,5,VLCS) + CALL AGPWRT (XPAX+CFAX*DEEX,YPAX+CFAY*DEEY,BFRE,NCIE,IWCE,NLOR,-1) + CALL AGCHAX (1,IAXS,5,VLCS) +C +C Draw the second portion of the tick mark, if any. +C + 421 IF (LDLR) 423,424,422 +C + 422 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(3),YPAX+YMJT(3),XPAX+XMJT(4),YPAX+YMJT(4)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 424 +C + 423 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(2),YPAX+YMJT(2),XPAX+XMJT(1),YPAX+YMJT(1)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Exit from internal procedure. +C + 424 GO TO JMP2 , (203,301) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP3. Its purpose is to compute all numeric-label parameters +C required by AGAXIS. +C +C Compute the desired label orientation and its direction cosines. +C + 500 NLOR=NLOF + IF (NLOR.LT.0) NLOR=NLOS +C + XDCL=COS(.017453292519943*FLOAT(NLOR)) + YDCL=SIN(.017453292519943*FLOAT(NLOR)) +C +C Compute JLAO, which is a computed-go-to jump parameter specifying the +C label-to-axis orientation. +C + JLAO=1+MOD(NLOR-IAOR+3600,360)/90 +C +C Compute the width of a character in the label mantissa, the width of a +C character in the label exponent, and the distance of a label from the +C axis, in the plotter coordinate system. +C + IWCM=MAX0(MWCM,IFIX(RFNL*ABS(WCLM)*SCWP+.5)) + IWCE=MAX0(MWCE,IFIX(RFNL*ABS(WCLE)*SCWP+.5)) + IDLA=MAX0(MDLA,IFIX(RFNL*ABS(DNLA)*SCWP+.5)) +C +C Compute the same quantities as fractions of the axis length. +C + FWCM=FLOAT(IWCM)/AXLP + FWCE=FLOAT(IWCE)/AXLP + FDLA=FLOAT(IDLA)/AXLP +C +C Compute character heights as fractions of the axis length. +C + FHCM=HCFW(FWCM) + FHCE=HCFW(FWCE) +C +C Return to internal-procedure caller. +C + GO TO JMP3 , (104,200,801) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the termination section of AGAXIS. +C +C Update the parameters WNLL and WNLR to reflect the amount of space +C used/needed for numeric labels to the left and right of the axis. +C + 800 IF (LDNL.NE.0) GO TO 801 +C +C No numeric labels occur on the axis. Zero WNLL and WNLR and jump. +C + WNLL=0. + WNLR=0. + GO TO 815 +C +C Numeric labels do occur on the axis. Compute the space required. +C + 801 GO TO (802,803,802,803) , JLAO +C +C Labels are parallel to the axis. +C + 802 FNLW=FHCM + IF (MCIE.NE.0) FNLW=FNLW+.5*FHCE + GO TO 804 +C +C Labels are perpendicular to the axis. +C + 803 FNLW=FLOAT(MCIM)*FWCM+FLOAT(MCIE)*FWCE +C +C Jump on the numeric-label-distance-from-axis parameter DNLA. +C + 804 IF (DNLA) 805,806,807 +C +C Labels are to the right of the axis. +C + 805 FNLL=-FDLA + FNLR=+FDLA+FNLW + GO TO 808 +C +C Labels are centered on the axis. +C + 806 FNLL=+.5*FNLW + FNLR=+.5*FNLW + GO TO 808 +C +C Labels are to the left of the axis. +C + 807 FNLL=+FDLA+FNLW + FNLR=-FDLA +C +C Adjust FNLL and FNLR as implied by the numeric-label offset. +C + 808 FNLL=FNLL-FNLO + FNLR=FNLR+FNLO +C +C If this is not a test run, jump to reset WNLL and WNLR. +C + IF (ITST.EQ.0) GO TO 814 +C +C If this is a test run, see if the labels will fit. Jump if so. +C + IF (CFAP*FNLL.LE.WNLL.AND.CFAP*FNLR.LE.WNLR) GO TO 814 +C +C If the labels will not fit, we have a problem. We may or may not be +C able to do anything about it, depending on ITST. +C + GO TO (814,809,813,809) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 809 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 812 +C +C If not, shrink them by an amount based on the extent of the problem, +C reset the parameters affected and see if the problem is solved. +C + IF (WNLR+WNLL.GT.0.) GO TO 810 +C + RFNL=.000001*RFNL + GO TO 811 +C + 810 RFNL=AMIN1(.9,(WNLL+WNLR)/(CFAP*(FNLL+FNLR)))*RFNL +C + 811 ASSIGN 801 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, give up. +C + 812 IF (ITST.NE.3) GO TO 814 +C +C Try re-orienting the labels. If this has already been tried, or if it +C would be pointless, give up. +C + 813 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.1.OR.JLAO.EQ.3) GO TO 814 +C +C If re-orienting makes sense, reset the parameters affected and see if +C the problem is solved. +C + NLOF=NLOF-360 + RFNL=1. + ASSIGN 801 TO JMP3 + GO TO 500 +C +C Reset WNLL and WNLR for caller. +C + 814 WNLL=FNLL*CFAP + WNLR=FNLR*CFAP +C +C If this is a test run, we are now done. +C + 815 IF (ITST.GT.0) GO TO 816 +C +C Draw the axis, if it is to be drawn. +C + IF (LDAX.EQ.0) GO TO 816 +C + CALL DASHDB (ISLD) + CALL AGCHAX (0,IAXS,1,0.) + CALL LINED (XBGA,YBGA,XNDA,YNDA) + CALL AGCHAX (1,IAXS,1,0.) +C +C Pack up integer values which might have been changed into the +C corresponding floating-point arguments. +C + 816 QLOF=FLOAT(NLOF) + QLOS=FLOAT(NLOS) + QCIM=FLOAT(MCIM) + QCIE=FLOAT(MCIE) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agback.f b/sys/gio/ncarutil/autograph/agback.f new file mode 100644 index 00000000..108d2b66 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agback.f @@ -0,0 +1,152 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGBACK +C +C The subroutine AGBACK is used to draw a graph background, as directed +C by the current contents of the parameter list. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C +NOAO - Block data replaced with run time initialization subroutine. +C +C EXTERNAL AGDFLT + call agdflt +C +C -NOAO +C +C Do an appropriate SET call for the following routines. The call is +C equivalent to "CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1)", but +C makes the viewport cover the whole plotter frame, which avoids the +C problems resulting from clipping by GKS. +C + CALL SET (0.,1.,0.,1.,-XLCW/(XRCW-XLCW),(1.-XLCW)/(XRCW-XLCW), + + -YBCW/(YTCW-YBCW),(1.-YBCW)/(YTCW-YBCW),1) +C +C Draw the labels, if any, first. +C + IDLB=IFIX(QDLB) + IF (IDLB.EQ.0) GO TO 101 +C + LBIM=IFIX(QBIM) + CALL AGLBLS (IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Now draw each of the four axes. +C + 101 I=0 +C + 102 I=I+1 +C + IF (I.EQ.5) GO TO 108 +C + IF (QDAX(I).EQ.0.) GO TO 102 +C + GO TO (103,104,105,106) , I +C +C Y axis - left. +C + 103 WNLB(1)=0.-YBGW + IF (XBGA(1)-WNLL(1).LT.DBOX(3,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(3,1)) WNLB(1)=0.-DBOX(3,4) +C + WNLE(1)=YTGW-1. + IF (XBGA(1)-WNLL(1).LT.DBOX(4,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(4,1)) WNLE(1)=DBOX(4,3)-1. +C + GO TO 107 +C +C Y axis - right. +C + 104 WNLB(2)=YTGW-1. + IF (XBGA(2)-WNLR(2).LT.DBOX(4,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(4,1)) WNLB(2)=DBOX(4,3)-1. +C + WNLE(2)=0.-YBGW + IF (XBGA(2)-WNLR(2).LT.DBOX(3,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(3,1)) WNLE(2)=0.-DBOX(3,4) +C + GO TO 107 +C +C X axis - bottom. +C + 105 WNLB(3)=XRGW-1. + IF (YBGA(3)-WNLL(3).LT.DBOX(2,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(2,3)) WNLB(3)=DBOX(2,1)-1. +C + WNLE(3)=0.-XLGW + IF (YBGA(3)-WNLL(3).LT.DBOX(1,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(1,3)) WNLE(3)=0.-DBOX(1,2) +C + GO TO 107 +C +C X axis - top. +C + 106 WNLB(4)=0.-XLGW + IF (YBGA(4)-WNLR(4).LT.DBOX(1,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(1,3)) WNLB(4)=0.-DBOX(1,2) +C + WNLE(4)=XRGW-1. + IF (YBGA(4)-WNLR(4).LT.DBOX(2,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(2,3)) WNLE(4)=DBOX(2,1)-1. +C + 107 Q=AMIN1(0.,QDAX(I)) +C + CALL AGAXIS (I,Q, + + QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I),XNDA(I),YNDA(I), + + QLUA(I),UBGA(I),UNDA(I),FUNS(I),QBTP(I),BASE(I), + + QJDP(I),WMJL(I),WMJR(I),QMNT(I),QNDP(I),WMNL(I), + + WMNR(I),QLTP(I),QLEX(I),QLFL(I),QLOF(I),QLOS(I), + + DNLA(I),WCLM(I),WCLE(I),RFNL(I),QCIM(I),QCIE(I), + + WNLL(I),WNLR(I),WNLB(I),WNLE(I)) +C + GO TO 102 +C +C Do set call for user and return. +C + 108 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agbnch.f b/sys/gio/ncarutil/autograph/agbnch.f new file mode 100644 index 00000000..4aee636a --- /dev/null +++ b/sys/gio/ncarutil/autograph/agbnch.f @@ -0,0 +1,35 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGBNCH (IDSH) +C +C The value of this function is the character-dash-pattern equivalent of +C the integer dash pattern IDSH, a string of quotes and/or dollar signs. +C Note that the support routines IAND and ISHIFT are used. +C + KDSH=IDSH +C + DO 101 I=16,1,-1 + IF (IAND(KDSH,1).EQ.0) THEN + AGBNCH(I:I)='''' + ELSE + AGBNCH(I:I)='$' + END IF + KDSH=ISHIFT(KDSH,-1) + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchax.f b/sys/gio/ncarutil/autograph/agchax.f new file mode 100644 index 00000000..451bce5c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchax.f @@ -0,0 +1,41 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHAX (IFLG,IAXS,IPRT,VILS) +C +C The routine AGCHAX is called by AGAXIS just before and just after each +C of a selected set of objects on the axes are drawn. A user may supply +C a version to change the appearance of these objects. The arguments +C are as follows: +C +C - IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C - IAXS is the number of the axis in question. The values 1, 2, 3, and +C 4 imply the right, left, bottom, and top axes, respectively. +C +C - IPRT is an integer implying which part of the axis is being drawn. +C The value 1 implies the line itself, 2 a major tick, 3 a minor tick, +C 4 the mantissa of a label, and 5 the exponent of a label. +C +C - VILS is the value, in the label coordinate system along the axis, +C associated with the position of the object being drawn. IPRT=1 +C implies VILS=0. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchcu.f b/sys/gio/ncarutil/autograph/agchcu.f new file mode 100644 index 00000000..1364ad28 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchcu.f @@ -0,0 +1,44 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHCU (IFLG,KDSH) +C +C The routine AGCHCU is called by AGCURV just before and just after each +C curve is drawn. The default version does nothing. A user may supply +C a version to change the appearance of the curves. The arguments are +C as follows: +C +C - IFLG is zero if a curve is about to be drawn, non-zero if a curve +C has just been drawn. +C +C - KDSH is the last argument of AGCURV, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C The sign of KDSH, when AGCURV is called by EZMY or EZMXY, indicates +C whether the "user" dash patterns or the "alphabetic" dash patterns +C were selected for use. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchil.f b/sys/gio/ncarutil/autograph/agchil.f new file mode 100644 index 00000000..1952cf68 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchil.f @@ -0,0 +1,36 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHIL (IFLG,LBNM,LNNO) +C + CHARACTER*(*) LBNM +C +C The routine AGCHIL is called by AGLBLS just before and just after each +C informational-label line of text is drawn. The default version does +C nothing. A user may supply a version to change the appearance of the +C text lines. The arguments are as follows: +C +C - IFLG is zero if a text line is about to be drawn, non-zero if one +C has just been drawn. +C +C - LBNM is the name of the label containing the line in question. +C +C - LNNO is the number of the line. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchnl.f b/sys/gio/ncarutil/autograph/agchnl.f new file mode 100644 index 00000000..3b42a5f6 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchnl.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctcs.f b/sys/gio/ncarutil/autograph/agctcs.f new file mode 100644 index 00000000..d9f67d5f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctcs.f @@ -0,0 +1,79 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTCS (TPID,ITCS) +C + CHARACTER*(*) TPID +C +C The routine AGCTCS is called by the routines AGGETC and AGSETC to +C check what type of character-string parameter is implied by the +C parameter identifier TPID and return an appropriate value of ITCS, as +C follows: +C +C -- ITCS = 0 implies that the parameter is not intrinsically of type +C character and that AGGETC/AGSETC should not have been called in +C the way that it was. +C +C -- ITCS = 1 implies a dash-pattern parameter. +C +C -- ITCS = 2 implies a label name. +C +C -- ITCS = 3 implies the line-end character. +C +C -- ITCS = 4 implies the text of some line of some label. +C +C Find out where in the parameter list the requested parameter lies. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C See if it's a dash pattern. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.GE.LODP.AND.LOPA.LE.LODP+NIDP-1) THEN + ITCS=1 + RETURN + END IF +C +C See if it's a label name. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) THEN + ITCS=2 + RETURN + END IF +C +C See if it's the line-end character. +C + CALL AGSCAN ('LINE/END .',LOLE,NILE,IILE) + IF (LOPA.EQ.LOLE) THEN + ITCS=3 + RETURN + END IF +C +C See if it's the text of some label line. +C + CALL AGSCAN ('LINE/BUFF/CONT.',LOLB,NILB,IILB) + IF (LOPA.GE.LOLB.AND.LOPA.LE.LOLB+NILB-1.AND. + + MOD(LOPA-LOLB,6).EQ.3) THEN + ITCS=4 + RETURN + END IF +C +C Error - type not recognizable. +C + ITCS=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctko.f b/sys/gio/ncarutil/autograph/agctko.f new file mode 100644 index 00000000..105438cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctko.f @@ -0,0 +1,150 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMMT, + + QMDP,WMML,WMMR,FNLL,FNLR,MM12,MM34,XMMT,YMMT) +C + DIMENSION XMMT(4),YMMT(4) +C +C The routine AGCTKO is used to compute the x and y offsets to the end- +C points of the left-of-label and right-of-label portions of the major +C and minor tick marks. See AGAXIS for definitions of the arguments. +C +C A note about WMML and WMMR: Each is a positive number, of the form +C (E) or (1+E), where E (=EPSILON) is .LT. 1. and is expressed as a +C fraction of the smaller side of the curve window. If the form (E) is +C used, it implies just a tick of length E; if the form (1+E) is used, +C it implies a tick long enough to reach the edge of the curve window, +C plus the length E. +C +C If the tick-mark count NMMT .EQ. 0 or the tick-mark dash pattern QMDP +C .EQ. 0 or both the left-of-axis and right-of-axis tick-mark lengths +C WMML and WMMR .EQ. 0, then no tick marks are to be drawn. +C + IF (NMMT.EQ.0.OR.QMDP.EQ.0..OR.(WMML.EQ.0..AND.WMMR.EQ.0.)) + * GO TO 115 +C +C Compute the distances of the tick mark ends from the axis as fractions +C of the axis length, using only the (EPSILON) portion of WMML and WMMR. +C + FMML=-CSFA*AMOD(WMML,1.) + FMMR=+CSFA*AMOD(WMMR,1.) +C +C If the labels overlap the axis and the (EPSILON) form was used for +C WMML or WMMR, move the tick mark to the end of the label. +C + IF (FNLL*FNLR.GE.0.) GO TO 101 +C + IF (WMML.LT.1.) FMML=FMML+FNLL +C + IF (WMMR.LT.1.) FMMR=FMMR+FNLR +C +C Compute the x and y offsets to the ends of the tick mark. +C + 101 XMML=+CFAX*FMML*YDCA + YMML=-CFAY*FMML*XDCA + XMMR=+CFAX*FMMR*YDCA + YMMR=-CFAY*FMMR*XDCA +C +C If the (1+EPSILON) form was used for WMML or WMMR, adjust XMML, YMML, +C XMMR, and YMMR as implied by the current axis orientation. +C + IF (WMML.LT.1.) GO TO 107 +C + GO TO (102,103,104,105) , JAOR +C +C Axis at 0 degrees (left to right). +C + 102 YMML=YMML+1.-YBGA + GO TO 106 +C +C Axis at 90 degrees (bottom to top). +C + 103 XMML=XMML-XBGA + GO TO 106 +C +C Axis at 180 degrees (right to left). +C + 104 YMML=YMML-YBGA + GO TO 106 +C +C Axis at 270 degrees (top to bottom). +C + 105 XMML=XMML+1.-XBGA +C + 106 FMML=(XMML+YMML)/(CFAX*YDCA-CFAY*XDCA) +C + 107 IF (WMMR.LT.1.) GO TO 113 +C + GO TO (108,109,110,111) , JAOR +C +C Axis at 0 degrees (left to right). +C + 108 YMMR=YMMR-YBGA + GO TO 112 +C +C Axis at 90 degrees (bottom to top). +C + 109 XMMR=XMMR+1.-XBGA + GO TO 112 +C +C Axis at 180 degrees (right to left). +C + 110 YMMR=YMMR+1.-YBGA + GO TO 112 +C +C Axis at 270 degrees (top to bottom). +C + 111 XMMR=XMMR-XBGA +C + 112 FMMR=(XMMR+YMMR)/(CFAX*YDCA-CFAY*XDCA) +C +C Now split the tick mark into two portions - one to the left, and one +C to the right, of the numeric label space. +C + 113 XMMT(1)=XMML + YMMT(1)=YMML + XMMT(2)=XMMR + YMMT(2)=YMMR + MM12=1 + MM34=0 + IF (FMMR.LE.FNLL.OR.FNLL.GE.FNLR) RETURN +C + MM12=0 + IF (FMML.GE.FNLL) GO TO 114 + MM12=1 + XMMT(2)=+CFAX*(FNLL-.005*CSFA)*YDCA + YMMT(2)=-CFAY*(FNLL-.005*CSFA)*XDCA +C + 114 IF (FMMR.LE.FNLR) RETURN +C + MM34=1 + XMMT(4)=XMMR + YMMT(4)=YMMR + XMMT(3)=XMML + YMMT(3)=YMML +C + IF (FMML.GE.FNLR) RETURN + XMMT(3)=+CFAX*(FNLR+.005*CSFA)*YDCA + YMMT(3)=-CFAY*(FNLR+.005*CSFA)*XDCA + RETURN +C +C No ticks to be drawn - zero the flags MM12 and MM34 to indicate this. +C + 115 MM12=0 + MM34=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agcurv.f b/sys/gio/ncarutil/autograph/agcurv.f new file mode 100644 index 00000000..47624321 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agcurv.f @@ -0,0 +1,149 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGCURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where, if the primary parameter 'INVERT.' is zero, +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If 'INVERT.' is non-zero, the definitions are interchanged, so that +C +C X(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case X(I)=I), and +C Y(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C If the primary parameter 'WINDOW.' is zero, AGKURV is called; it does +C no windowing. If 'WINDOW.' is non-zero, AGQURV is called; it omits +C portions of the curve which fall outside the current curve window. +C +C The argument KDSH specifies the dash pattern to be used. If KDSH is +C negative, the function MOD(IABS(KDSH),26) is used to select a solid +C line interrupted by one of the alphabetic characters. If KDSH is +C zero, the user is assumed to have done his own DASHD call. If KDSH +C is positive, the function MOD(KDSH,NODP) is used to select one of the +C dash patterns in the parameter group 'DASH/PATTERNS.'. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine external to force it to load. +C +C +NOAO +C EXTERNAL AGDFLT +C -NOAO +C +C DASH receives alphabetic dash patterns. +C + CHARACTER*10 DASH +C +C ALPH contains an alphabet. +C + CHARACTER*26 ALPH +C + DATA ALPH / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / +C +C +NOAO - replace blockdata with run time initialization. + call agdflt +C -NOAO +C +C Check for an alphabetic dash pattern. +C + IF (KDSH.LT.0) THEN + IDSH=MOD(-KDSH-1,26)+1 + IPSN=MOD(3*IDSH-1,10)+1 + DASH='$$$$$$$$$$' + DASH(IPSN:IPSN)=ALPH(IDSH:IDSH) + CALL AGSTCH (DASH,10,IDCS) + CALL AGDASH (FLOAT(IDCS),WODQ,WOCD,SCWP) + CALL AGDLCH (IDCS) +C +C Check for a dash pattern from the group "DASH/PATTERNS." +C + ELSE IF (KDSH.GT.0) THEN + IDSH=MOD(KDSH-1,IFIX(QODP))+1 + CALL AGDASH (QDSH(IDSH),WODQ,WOCD,SCWP) +C + END IF +C +C Now that the dash pattern is determined, do the SET call. +C + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C +C Give the user a chance to modify the curve (by changing line style, +C color, etc.). +C + CALL AGCHCU (0,KDSH) +C +C Decide whether AGKURV or AGQURV is to draw the curve. +C + IF (QWND.EQ.0.) THEN +C +C No windowing requested - AGKURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGKURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + ELSE +C +C Windowing requested - AGQURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGQURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + END IF +C +C Give the user a chance to change back what he changed above. +C + CALL AGCHCU (1,KDSH) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdash.f b/sys/gio/ncarutil/autograph/agdash.f new file mode 100644 index 00000000..243eb808 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdash.f @@ -0,0 +1,69 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDASH (DASH,WODQ,WOCD,SCWP) +C +C AGDASH sets up the DASHD call required to establish the dash pattern +C desired for the next curve. The arguments are as follows: +C +C -- DASH specifies the desired dash pattern. A positive value implies +C that a binary dash pattern is to be used, a negative value that a +C character-string dash pattern is to be used. +C +C -- WODQ is the width of the solid-line segment specified by a dollar +C sign and the gap specified by a quote, expressed as a fraction of +C the smaller side of the curve window. +C +C -- WOCD is the width of a character which is to be a part of the dash +C pattern, expressed in the same units as WODQ. +C +C -- SCWP is the length of the smaller side of the curve window, in +C plotter coordinate units. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C used here are MWCD and MWDQ - the minimum widths of characters and +C spaces, respectively, in the dash pattern. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C + IWCD=MAX0(MWCD,IFIX(WOCD*SCWP)) + IWDQ=MAX0(MWDQ,IFIX(WODQ*SCWP)) +C + IF (DASH.GE.0.) THEN + CALL DASHDB (AGFPBN(DASH)) + ELSE + CALL AGGTCH (IFIX(DASH),CHS1,LNC1) + CALL DASHDC (CHS1(1:LNC1),IWDQ,IWCD) + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.bd b/sys/gio/ncarutil/autograph/agdflt.bd new file mode 100644 index 00000000..ddbde9a1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.bd @@ -0,0 +1,414 @@ +C +NOAO +C This block data has been rewritten as a run time initialization +C subroutine (see file agdflt.f). This original block data file +C is retained for reference only. +C -NOAO +C +C --------------------------------------------------------------------- +C + BLOCK DATA AGDFLT +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C + CHARACTER*504 CHS1,CHS2 +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C + DATA QFRA / 1. / +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C + DATA QSET / 1. / +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C + DATA QROW / 1. / +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C + DATA QIXY / 0. / +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C + DATA QWND / 0. / +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C + DATA QBAC / 1. / +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C + DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C + DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C + DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C + DATA SOGD / 0. / +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA XMIN / 1E36 / , XMAX / 1E36 / +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUX / 0. / +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVX / 0. / +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEX / -1. / +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C + DATA XLOW / 1E36 / , XHGH / 1E36 / +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA YMIN / 1E36 / , YMAX / 1E36 / +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUY / 0. / +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVY / 0. / +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEY / -1. / +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C + DATA YLOW / 1E36 / , YHGH / 1E36 / +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C + DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C + DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C + DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C + DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C + DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C + DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ + DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ + DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / + DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ + DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / + DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C + DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ + DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ + DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / + DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C + DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ + DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ + DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ + DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / + DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ + DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ + DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ + DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C + DATA QODP / 1. / +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C + DATA QCDP / 8. / +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C + DATA WOCD / .010 / , WODQ / .010 / +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C + DATA QDSH / 26*65535. / +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C + DATA QDLB /2./ +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C + DATA QBIM / 8. / +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C + DATA QBAN / 0. / +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C + DATA QLLN /40./ +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C + DATA QNIM / 16. / +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C + DATA QNAN / 0. / +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C + DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , + + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , + + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , + + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , + + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , + + FLLN( 6,1)/ 0./ +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C + DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , + + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , + + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , + + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , + + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , + + FLLN( 6,2)/ 0./ +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C + DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , + + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , + + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , + + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , + + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , + + FLLN( 6,3)/ 0./ +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C + DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , + + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , + + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , + + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , + + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , + + FLLN( 6,4)/ 0./ +C +C Certain secondary parameters must be initialized to prevent bombing. +C + DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ + DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ + DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ + DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ + DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ + DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ + DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ + DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ + DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ + DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C + DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C + DATA INIF / 0 / +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C + DATA LNIC / 50 / +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C + DATA (INCH(1,I),I=1,50) / 50*0 / + DATA (INCH(2,I),I=1,50) / 50*0 / +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C + DATA LNCA / 2000 / +C +C INCA is the index of the last character used in CHRA. +C + DATA INCA / 0 / +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.f b/sys/gio/ncarutil/autograph/agdflt.f new file mode 100644 index 00000000..87b0ca45 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.f @@ -0,0 +1,690 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C +c +noao: blockdata rewritten to be run time initialization +c BLOCK DATA AGDFLT + subroutine agdflt +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +c +noao: logical flag added to prevent "over-initialization" + logical first + data first /.true./ + call utilbd + if (.not. first) return + first = .false. +c -noao +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C +c DATA QFRA / 1. / + QFRA = 1. +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C +c DATA QSET / 1. / + QSET = 1. +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C +c DATA QROW / 1. / + QROW = 1. +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C +c DATA QIXY / 0. / + QIXY = 0. +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C +c DATA QWND / 0. / + QWND = 0. +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C +c DATA QBAC / 1. / + QBAC = 1. +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C +c DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / + SVAL(1) = 1E36 + SVAL(2) = 2E36 +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C +c DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / + XLGF = 0. + XRGF = 1. + YBGF = 0. + YTGF = 1. +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C +c DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / + XLGD = .15 + XRGD = .95 + YBGD = .15 + YTGD = .95 +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C +c DATA SOGD / 0. / + SOGD = 0. +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA XMIN / 1E36 / , XMAX / 1E36 / + XMIN = 1E36 + XMAX = 1E36 +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUX / 0. / + QLUX = 0. +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVX / 0. / + QOVX = 0. +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEX / -1. / + QCEX = -1. +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C +c DATA XLOW / 1E36 / , XHGH / 1E36 / + XLOW = 1E36 + XHGH = 1E36 +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA YMIN / 1E36 / , YMAX / 1E36 / + YMIN = 1E36 + YMAX = 1E36 +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUY / 0. / + QLUY = 0. +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVY / 0. / + QOVY = 0. +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEY / -1. / + QCEY = -1. +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C +c DATA YLOW / 1E36 / , YHGH / 1E36 / + YLOW = 1E36 + YHGH = 1E36 +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C +c DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / + QDAX(1) = 4. + QDAX(2) = 4. + QDAX(3) = 4. + QDAX(4) = 4. +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C +c DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / + QSPA(1) = 0. + QSPA(2) = 0. + QSPA(3) = 0. + QSPA(4) = 0. +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C +c DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ + PING(1) = 1E36 + PING(2) = 1E36 + PING(3) = 1E36 + PING(4) = 1E36 +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C +c DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ + PINU(1) = 1E36 + PINU(2) = 1E36 + PINU(3) = 1E36 + PINU(4) = 1E36 +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C +c DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / + FUNS(1) = 0. + FUNS(2) = 0. + FUNS(3) = 0. + FUNS(4) = 0. +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C +c DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ +c DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ +c DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / +c DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ +c DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / +c DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ + QBTD(1) = 1E36 + QBTD(2) = 1E36 + QBTD(3) = 1E36 + QBTD(4) = 1E36 + BASD(1) = 1E36 + BASD(2) = 1E36 + BASD(3) = 1E36 + BASD(4) = 1E36 + QMJD(1) = 6. + QMJD(2) = 6. + QMJD(3) = 6. + QMJD(4) = 6. + QJDP(1) = 1E36 + QJDP(2) = 1E36 + QJDP(3) = 1E36 + QJDP(4) = 1E36 + WMJL(1) = 0. + WMJL(2) = 0. + WMJL(3) = 0. + WMJL(4) = 0. + WMJR(1) = .015 + WMJR(2) = .015 + WMJR(3) = .015 + WMJR(4) = .015 +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C +c DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ +c DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ +c DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / +c DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ + QMND(1) = 1E36 + QMND(2) = 1E36 + QMND(3) = 1E36 + QMND(4) = 1E36 + QNDP(1) = 1E36 + QNDP(2) = 1E36 + QNDP(3) = 1E36 + QNDP(4) = 1E36 + WMNL(1) = 0. + WMNL(2) = 0. + WMNL(3) = 0. + WMNL(4) = 0. + WMNR(1) = .010 + WMNR(2) = .010 + WMNR(3) = .010 + WMNR(4) = .010 +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C +c DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ +c DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ +c DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ +c DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / +c DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ +c DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ +c DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ +c DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ + QLTD(1) = 1E36 + QLTD(2) = 0. + QLTD(3) = 1E36 + QLTD(4) = 0. + QLED(1) = 1E36 + QLED(2) = 1E36 + QLED(3) = 1E36 + QLED(4) = 1E36 + QLFD(1) = 1E36 + QLFD(2) = 1E36 + QLFD(3) = 1E36 + QLFD(4) = 1E36 + QLOF(1) = 0. + QLOF(2) = 0. + QLOF(3) = 0. + QLOF(4) = 0. + QLOS(1) = 90. + QLOS(2) = 90. + QLOS(3) = 90. + QLOS(4) = 90. + DNLA(1) = .015 + DNLA(2) = .015 + DNLA(3) = .015 + DNLA(4) = .015 + WCLM(1) = .015 + WCLM(2) = .015 + WCLM(3) = .015 + WCLM(4) = .015 + WCLE(1) = .010 + WCLE(2) = .010 + WCLE(3) = .010 + WCLE(4) = .010 +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C +c DATA QODP / 1. / + QODP = 1. +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C +c DATA QCDP / 8. / + QCDP = 8. +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C +c DATA WOCD / .010 / , WODQ / .010 / + WOCD = .010 + WODQ = .010 +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C +c DATA QDSH / 26*65535. / + do 20, ijk = 1, 26 + 20 QDSH(ijk) = 65535. +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C +c DATA QDLB /2./ + QDLB = 2. +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C +c DATA QBIM / 8. / + QBIM = 8. +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C +c DATA QBAN / 0. / + QBAN = 0. +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C +c DATA QLLN /40./ + QLLN = 40. +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C +c DATA QNIM / 16. / + QNIM = 16. +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C +c DATA QNAN / 0. / + QNAN = 0. +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , +c + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , +c + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , +c + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , +c + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , +c + FLLN( 6,1)/ 0./ + FLLB( 1,1) = 0. + FLLB( 2,1) = 0. + FLLB( 3,1) = 0. + FLLB( 4,1) = .5 + FLLB( 5,1) = -.015 + FLLB( 6,1) = 0. + FLLB( 7,1) = 90. + FLLB( 8,1) = 0. + FLLB( 9,1) = 1. + FLLB(10,1) = 1. + FLLN( 1,1) = +100. + FLLN( 2,1) = 0. + FLLN( 3,1) = .015 + FLLN( 4,1) = -2. + FLLN( 5,1) = 1. + FLLN( 6,1) = 0. +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , +c + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , +c + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , +c + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , +c + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , +c + FLLN( 6,2)/ 0./ + FLLB( 1,2) = 0. + FLLB( 2,2) = 0. + FLLB( 3,2) = 1. + FLLB( 4,2) = .5 + FLLB( 5,2) = +.015 + FLLB( 6,2) = 0. + FLLB( 7,2) = 90. + FLLB( 8,2) = 0. + FLLB( 9,2) = 1. + FLLB(10,2) = 2. + FLLN( 1,2) = -100. + FLLN( 2,2) = 0. + FLLN( 3,2) = .015 + FLLN( 4,2) = -3. + FLLN( 5,2) = 0. + FLLN( 6,2) = 0. +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , +c + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , +c + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , +c + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , +c + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , +c + FLLN( 6,3)/ 0./ + FLLB( 1,3) = 0. + FLLB( 2,3) = 0. + FLLB( 3,3) = .5 + FLLB( 4,3) = 0. + FLLB( 5,3) = 0. + FLLB( 6,3) = -.015 + FLLB( 7,3) = 0. + FLLB( 8,3) = 0. + FLLB( 9,3) = 1. + FLLB(10,3) = 3. + FLLN( 1,3) = -100. + FLLN( 2,3) = 0. + FLLN( 3,3) = .015 + FLLN( 4,3) = -1. + FLLN( 5,3) = 1. + FLLN( 6,3) = 0. +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , +c + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , +c + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , +c + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , +c + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , +c + FLLN( 6,4)/ 0./ + FLLB( 1,4) = 0. + FLLB( 2,4) = 0. + FLLB( 3,4) = .5 + FLLB( 4,4) = 1. + FLLB( 5,4) = 0. + FLLB( 6,4) = +.020 + FLLB( 7,4) = 0. + FLLB( 8,4) = 0. + FLLB( 9,4) = 1. + FLLB(10,4) = 4. + FLLN( 1,4) = +100. + FLLN( 2,4) = 0. + FLLN( 3,4) = .020 + FLLN( 4,4) = -3. + FLLN( 5,4) = 0. + FLLN( 6,4) = 0. +C +C Certain secondary parameters must be initialized to prevent bombing. +C +c DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ +c DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ +c DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ +c DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ +c DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ +c DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ +c DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ +c DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ +c DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ +c DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ + QBTP(1) = 0. + QBTP(2) = 0. + QBTP(3) = 0. + QBTP(4) = 0. + BASE(1) = 0. + BASE(2) = 0. + BASE(3) = 0. + BASE(4) = 0. + QMNT(1) = 0. + QMNT(2) = 0. + QMNT(3) = 0. + QMNT(4) = 0. + QLTP(1) = 0. + QLTP(2) = 0. + QLTP(3) = 0. + QLTP(4) = 0. + QLEX(1) = 0. + QLEX(2) = 0. + QLEX(3) = 0. + QLEX(4) = 0. + QLFL(1) = 0. + QLFL(2) = 0. + QLFL(3) = 0. + QLFL(4) = 0. + QCIM(1) = 0. + QCIM(2) = 0. + QCIM(3) = 0. + QCIM(4) = 0. + QCIE(1) = 0. + QCIE(2) = 0. + QCIE(3) = 0. + QCIE(4) = 0. + RFNL(1) = 0. + RFNL(2) = 0. + RFNL(3) = 0. + RFNL(4) = 0. + QLUA(1) = 0. + QLUA(2) = 0. + QLUA(3) = 0. + QLUA(4) = 0. +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C +c DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ + MWCL = 8 + MWCM = 8 + MWCE = 8 + MDLA = 8 + MWCD = 8 + MWDQ = 8 +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C +c DATA INIF / 0 / + INIF = 0 +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C +c DATA LNIC / 50 / + LNIC = 50 +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C +c DATA (INCH(1,I),I=1,50) / 50*0 / +c DATA (INCH(2,I),I=1,50) / 50*0 / + do 10, ijk = 1, 50 + inch (1, ijk) = 0 + inch (2, ijk) = 0 + 10 continue +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C +c DATA LNCA / 2000 / + LNCA = 2000 +C +C INCA is the index of the last character used in CHRA. +C +c DATA INCA / 0 / + INCA = 0 +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + return +c + entry initag + first = .true. + END diff --git a/sys/gio/ncarutil/autograph/agdlch.f b/sys/gio/ncarutil/autograph/agdlch.f new file mode 100644 index 00000000..78a96c8f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdlch.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDLCH (IDCS) +C +C This routine deletes character strings previously stored by the +C routine AGSTCH (which see). It has the following argument: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Only if the identifier is between -LNIC and -1, inclusive, was the +C string ever stored, so that it needs to be deleted. If the string is +C the last one in CHRA, we can just set INCA to point to the position +C preceding it; otherwise, we zero out the string but don't bother to +C collapse CHRA, which will happen in AGSTCH when the space is needed +C again. In either case, the index entry in INCH is zeroed. +C + IF (IDCS.GE.(-LNIC).AND.IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I) + IF (J.GT.0) THEN + K=J+INCH(2,I)-1 + IF (K.EQ.INCA) THEN + INCA=J-1 + ELSE + DO 101 L=J,K + CHRA(L)=CHAR(0) + 101 CONTINUE + END IF + INCH(1,I)=0 + END IF + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdshn.f b/sys/gio/ncarutil/autograph/agdshn.f new file mode 100644 index 00000000..a20a5dfd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdshn.f @@ -0,0 +1,34 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGDSHN (IDSH) +C +C The value of this function is the name of the dash pattern numbered +C IDSH - that is to say, the character string 'DASH/PATTERN/n.', where +C n is an integer between 1 and 99, equal to MAX0(1,MIN0(99,IDSH)). +C + AGDSHN='DASH/PATTERN/ .' +C + KDSH=MAX0(1,MIN0(99,IDSH)) +C + DO 101 I=15,14,-1 + AGDSHN(I:I)=CHAR(ICHAR('0')+MOD(KDSH,10)) + IF (KDSH.LE.9) GO TO 102 + KDSH=KDSH/10 + 101 CONTINUE +C + 102 RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agexax.f b/sys/gio/ncarutil/autograph/agexax.f new file mode 100644 index 00000000..b16e2319 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexax.f @@ -0,0 +1,415 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXAX (IAXS,SVAL,UMIN,UMAX,NICE,QLUA,FUNS,QBTP,BASD, + + BASE,QMJD,QMND,QMNT,QLTD,QLTP,QLED,QLEX,QLFD, + + QLFL,QMIN,QMAX) +C + DIMENSION SVAL(2) +C +C The routine AGEXAX is used by AGSTUP to examine the parameters which +C determine how a given axis is tick-marked and labelled and to provide +C default values for missing ones. Its arguments are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4. +C +C -- SVAL is the array of special values. +C +C -- UMIN and UMAX are the minimum and maximum values along the axis, in +C the user coordinate system. Rounded values of UMIN and UMAX are +C returned in QMIN and QMAX if the following argument (NICE) is zero. +C +C -- NICE is a flag indicating whether rounded values of UMIN and UMAX +C are to be returned (NICE.EQ.0) or not (NICE.NE.0). +C +C -- LLUA and FUNS specify the user-system-to-label-system mapping along +C the axis. See the routine AGAXIS for a discussion of them. +C +C -- NBTP, BASD, BASE, and NMJD are used to determine the positioning of +C major tick marks in the label coordinate system. NBTP and BASE are +C described in the routine AGNUMB. BASD is the desired value of BASE +C supplied by the user. If BASD has a null value, BASE is computed +C by AGEXAX. NMJD is a user-supplied-or-defaulted parameter giving +C the approximate number of major ticks (and therefore the number of +C numeric labels) to be placed on the axis. +C +C -- NMND and NMNT are the desired and actual (to be determined) number +C of minor ticks per major division. See discussion in AGAXIS. +C +C -- NLTD, NLTP, NLED, NLEX, NLFD, and NLFL are desired and actual (to +C be determined) values of the parameters describing the form to be +C used for numeric labels. See discussion in AGNUMB. +C +C -- QMIN and QMAX are rounded values of UMIN and UMAX, returned only if +C NICE.EQ.0. +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The arrays BASP and NMNP specify possible default values for BASE and +C NMNT when NBTP.EQ.1. +C + DIMENSION BASP(5),NMNP(5) +C + DATA BASP(1) / 10. / , NMNP(1) / 1 / , + * BASP(2) / 5. / , NMNP(2) / 4 / , + * BASP(3) / 2. / , NMNP(3) / 1 / , + * BASP(4) / 1. / , NMNP(4) / 1 / , + * BASP(5) / .5 / , NMNP(5) / 4 / +C +C If the parameter NBTP is zero, tick marks and labels are suppressed. +C + NBTP=IFIX(QBTP) + IF (NBTP.EQ.0) RETURN +C +C Unpack integer values from floating-point arguments. +C + LLUA=IFIX(QLUA) + NMJD=IFIX(QMJD) + IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMND=IFIX(QMND) + NMNT=0 + IF (QLTD.NE.SVAL(1).AND.QLTD.NE.SVAL(2)) NLTD=IFIX(QLTD) + NLTP=0 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) NLED=IFIX(QLED) + NLEX=0 + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) NLFD=IFIX(QLFD) + NLFL=0 +C +C Compute label-coordinate-system values at the ends of the axis. +C + CALL AGUTOL (IAXS,FUNS,1,UMIN,VMIN) + CALL AGUTOL (IAXS,FUNS,1,UMAX,VMAX) +C +C Error if the label-coordinate-system values are equal. +C + IF (VMIN.EQ.VMAX) GO TO 901 +C +C If a special value is specified for the parameter BASD, AGEXAX must +C pick a value for the parameter BASE. +C + IF (BASD.EQ.SVAL(1).OR.BASD.EQ.SVAL(2)) GO TO 101 +C +C The user has specified a value for the parameter BASE. If that value +C is less than or equal to zero, tick marks and labels are suppressed. +C + BASE=AMAX1(0.,BASD) + IF (BASE.EQ.0.) RETURN + NMNT=0 + GO TO 108 +C +C Pick a value for the parameter BASE, depending on the number type. +C + 101 GO TO (102,105,106) , NBTP +C +C Major ticks and labels are at numbers of the form (-) BASE * EXMU. +C + 102 NMJD=MAX0(0,NMJD) +C +C Compute an approximate value for BASE. +C + FTMP=ABS(VMAX-VMIN)/FLOAT(NMJD+1) +C +C Reduce the approximate value to the form FTMP * 10 ** ITMP. +C + ASSIGN 103 TO JMP1 + GO TO 200 +C +C Pick a reasonable value for BASE (1., 2., OR 5. * 10**ITMP). +C + 103 DO 104 I=1,5 + IF (FTMP.LT.BASP(I)) GO TO 104 + BASE=BASP(I)*SNGL(10.D0**ITMP) + NMNT=NMNP(I) + GO TO 107 + 104 CONTINUE +C +C Major ticks and labels are at numbers of the form (-) BASE * 10**EXMU. +C + 105 BASE=1. + NMNT=8 + GO TO 107 +C +C Major ticks and labels are at numbers of the form (-) BASE**EXMU. +C + 106 BASE=10. + NMNT=8 +C + 107 IF (BASD.EQ.SVAL(2)) BASD=BASE +C + 108 IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMNT=MAX0(0,NMND) + IF (QMND.EQ.SVAL(2)) QMND=FLOAT(NMNT) +C +C If the user wants nice values at the axis ends, reset UMIN and UMAX. +C + IF (NICE.NE.0) GO TO 115 +C + LOOP=0 +C + WMIN=VMIN + WMAX=VMAX +C + GO TO (109,110,112) , NBTP +C + 109 EMIN=VMIN/BASE+.5+SIGN(.5,VMIN-VMAX) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN-VMAX) + WMIN=BASE*(EMIN-AMOD(EMIN,1.)) + EMAX=VMAX/BASE+.5+SIGN(.5,VMAX-VMIN) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX-VMIN) + WMAX=BASE*(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 110 IF (VMIN.EQ.0.) GO TO 111 + EMIN=ALOG10(ABS(VMIN)/BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(BASE,VMIN)*10.**(EMIN-AMOD(EMIN,1.)) + 111 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX)/BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(BASE,VMAX)*10.**(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 112 IF (BASE.EQ.1.) GO TO 115 + IF (VMIN.EQ.0.) GO TO 113 + EMIN=ALOG10(ABS(VMIN))/ALOG10(BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(1.,VMIN)*BASE**(EMIN-AMOD(EMIN,1.)) + 113 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX))/ALOG10(BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(1.,VMAX)*BASE**(EMAX-AMOD(EMAX,1.)) +C +C Re-compute the user-coordinate-system minimum and maximum values. +C + 114 CALL AGUTOL (IAXS,FUNS,-1,WMIN,QMIN) + CALL AGUTOL (IAXS,FUNS,-1,WMAX,QMAX) +C +C Test for problems with nice values chosen. +C + IF (QMIN.LT.QMAX) GO TO 140 + IF (QMIN.GT.QMAX) GO TO 901 +C +C We have a pathological case - user values are clustered very close to +C a label position. See what can be done about it. +C + LOOP=LOOP+1 + IF (LOOP.GT.1) GO TO 901 +C + GO TO (137,138,139) , NBTP +C + 137 VMIN=VMIN+SIGN(BASE,VMIN-VMAX) + VMAX=VMAX+SIGN(BASE,VMAX-VMIN) + GO TO 109 +C + 138 VMIN=VMIN*10.**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*10.**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 110 +C + 139 VMIN=VMIN*BASE**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*BASE**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 112 +C + 140 VMIN=WMIN + VMAX=WMAX +C +C Now we examine the parameters defining the appearance of the numeric +C labels. If the numeric-label type is zero, there is no more to do. +C + 115 IF (QLTD.EQ.SVAL(1).OR.QLTD.EQ.SVAL(2)) GO TO 116 + NLTP=MAX0(0,MIN0(3,NLTD)) + IF (NLTP.EQ.0) GO TO 136 +C +C The numeric-label type (NLTP) is specified. If both the numeric-label +C exponent and numeric-label fraction-length are also specified, quit. +C + NLEX=NLED + NLFL=NLFD + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2).AND. + + QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2) ) GO TO 136 + GO TO 117 +C +C We must pick a value for the numeric-label type. Start with the dummy +C value 4 so as to jump to the proper piece of code. +C + 116 NLTP=4 +C +C Reduce the value of BASE to the form RBSE * 10**KBSE, where RBSE is +C in the range (1,10) and KBSE is an integer. +C + 117 FTMP=BASE + ASSIGN 118 TO JMP1 + GO TO 200 +C + 118 RBSE=FTMP + KBSE=ITMP +C +C Compute LBSE = the number of significant digits in RBSE. +C + ASSIGN 119 TO JMP2 + GO TO 300 +C + 119 LBSE=1+ITMP +C +C Jump depending on the value of the numeric-label type. +C + GO TO (120,128,131,132) , NLTP +C +C Scientific notation is to be used. Estimate the number of significant +C digits that are likely to be required, depending on the number type. +C + 120 GO TO (121,123,124) , NBTP +C + 121 FTMP=AMAX1(ABS(VMIN),ABS(VMAX))/BASE + ASSIGN 122 TO JMP1 + GO TO 200 +C + 122 NSIG=MAX0(1,ITMP+1+LBSE) + GO TO 125 +C + 123 NSIG=LBSE + GO TO 125 +C + 124 NSIG=10 +C +C NLEX + NLFL should be equal to NSIG. Make that the case. +C + 125 IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 127 + IF (QLFD.EQ.SVAL(1).OR. QLFD.EQ.SVAL(2)) GO TO 126 + NLEX=NSIG-MAX0(0,NLFL) + GO TO 135 + 126 NLEX=1 + 127 NLFL=NSIG-NLEX + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is to be used. Compute the exponent NEXP such +C that BASE / 10**NEXP is an integer. +C + 128 NEXP=KBSE-LBSE+1 +C +C NLEX - NLFL should be equal to NEXP. Make that the case. (Note that, +C if NBTP is 3, NLEX is forced to zero.) +C + IF (NBTP.EQ.3) NLEX=0 +C + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 129 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 130 + NLFL=-1 + 129 NLEX=MAX0(0,NLFL)+NEXP + GO TO 135 + 130 NLFL=NLEX-NEXP + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C No-exponent notation is to be used. NLFL is the only parameter we +C need to worry about. If it is already set, quit. +C + 131 IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 136 +C +C Set NLFL to the actual number of digits in the fractional portion of +C BASE. +C + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C We must pick a value for the numeric-label type, depending on the +C number type. +C + 132 GO TO (133,134,134) , NBTP +C +C Nunbers are of the form (-) BASE * EXMU. Use labels with no exponent +C unless the use of an exponent would result in shorter labels. +C + 133 IF (MAX0(KBSE+1-LBSE,-KBSE-1).GT.4) GO TO 134 + NLTP=3 + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is used. +C + 134 NLTP=2 + NLEX=KBSE-LBSE+1 + NLFL=-1 +C +C Back-store the computed parameters, if requested, and return. +C + 135 IF (QLTD.EQ.SVAL(2)) QLTD=FLOAT(NLTP) + IF (QLED.EQ.SVAL(2)) QLED=FLOAT(NLEX) + IF (QLFD.EQ.SVAL(2)) QLFD=FLOAT(NLFL) +C +C Pack up integer values to floating-point arguments and return. +C + 136 QMNT=FLOAT(NMNT) + QLTP=FLOAT(NLTP) + QLEX=FLOAT(NLEX) + QLFL=FLOAT(NLFL) + RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure reduces the number (FTMP) to the range (1,10), +C returning (FTMP) and (ITMP) such that (FTMP) * 10**(ITMP) is equal to +C the original value of (FTMP). (FTMP) must be positive. +C + 200 FTM1=ALOG10(FTMP+SMRL*FTMP) + IF (FTM1.LT.0.) FTM1=FTM1-1. + ITMP=IFIX(FTM1) + FTMP=AMAX1(1.,FTMP*SNGL(10.D0**(-ITMP))) + GO TO JMP1 , (103,118,122) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure counts the number of digits in the fractional +C portion of (FTMP), returning the count as the value of (ITMP). +C + 300 FTM1=AMOD(FTMP+SMRL*FTMP,1.) + FTM2=10.*SMRL*FTMP + ITMP=0 +C + 301 IF (FTM1.LT.FTM2) GO TO 302 + ITMP=ITMP+1 + IF (ITMP.GE.10) GO TO 302 + FTM1=AMOD(10.*FTM1,1.) + FTM2=10.*FTM2 + GO TO 301 +C + 302 GO TO JMP2 , (119) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C Error exit. +C +C +NOAO - Comment out FTN write and format statement, SETER is okay. +C + 901 CONTINUE +C 901 WRITE (I1MACH(4),9001) IAXS + CALL SETER ('AGEXAX (CALLED BY AGSTUP) - USER-SYSTEM-TO-LABEL-SYST + +EM MAPPING IS NOT MONOTONIC',1,2) +C +C Formats. +C +C9001 FORMAT ('0PROBLEM WITH AXIS NUMBER',I2, +C + ' (1, 2, 3, AND 4 IMPLY LEFT, RIGHT, BOTTOM, AND TOP)') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agexus.f b/sys/gio/ncarutil/autograph/agexus.f new file mode 100644 index 00000000..7d4a274e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexus.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXUS (SVAL,ZMIN,ZMAX,ZLOW,ZHGH, + + ZDRA,NVIZ,IIVZ,NEVZ,IIEZ,UMIN,UMAX) +C + DIMENSION SVAL(2),ZDRA(1) +C +C The routine AGEXUS is used by AGSTUP to determine tentative values of +C the user-window edge coordinates. Its arguments are as follows: +C +C -- SVAL is the array of special values. +C +C -- ZMIN and ZMAX are user-supplied minimum and maximum values of the +C data x (or y) coordinates. +C +C -- ZLOW and ZHGH are, respectively, the smallest and largest data +C values to be considered in choosing the minimum and maximum, if +C those values, as given by the user, are null. +C +C -- ZDRA, NVIZ, IIVZ, NEVZ, and IIEZ specify the array of x (or y) +C data coordinates (see AGMAXI or AGMINI for complete description). +C +C -- UMIN and UMAX are returned with tentative minimum and maximum +C values for use at the appropriate user-window edges (left/right +C or bottom/top). +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Assume initially that the user has provided actual values to be used. +C + UMIN=ZMIN + UMAX=ZMAX +C +C If either of the values is null, replace it by a data-based value. +C + IF (UMIN.EQ.SVAL(1).OR.UMIN.EQ.SVAL(2)) + + UMIN=AGMINI(SVAL(1),ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) + IF (UMAX.EQ.SVAL(1).OR.UMAX.EQ.SVAL(2)) + + UMAX=AGMAXI(SVAL(1),ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C +C Either or both values might still be null (if the user data was null). +C + IF (UMIN.EQ.SVAL(1)) UMIN=UMAX + IF (UMAX.EQ.SVAL(1)) UMAX=UMIN +C +C Check the relative values of UMIN and UMAX for problems. +C + IF (ABS(UMIN-UMAX).LT.50.*SMRL*(ABS(UMIN)+ABS(UMAX))) GO TO 102 + IF (UMAX-UMIN) 101,102,103 + 101 IF (ZMIN.NE.SVAL(1).AND.ZMIN.NE.SVAL(2)) UMAX=UMIN + IF (ZMAX.NE.SVAL(1).AND.ZMAX.NE.SVAL(2)) UMIN=UMAX +C + 102 UMIN=UMIN-.5*ABS(UMIN) + UMAX=UMAX+.5*ABS(UMAX) + IF (UMIN.NE.UMAX) GO TO 103 + UMIN=-1. + UMAX=+1. +C +C If the user wanted these values back-stored, do it. +C + 103 IF (ZMIN.EQ.SVAL(2)) ZMIN=UMIN + IF (ZMAX.EQ.SVAL(2)) ZMAX=UMAX +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agezsu.f b/sys/gio/ncarutil/autograph/agezsu.f new file mode 100644 index 00000000..535e1811 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agezsu.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEZSU (ITOC,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX, + + IIVY,IIEY) +C + REAL XDRA(1),YDRA(1) + CHARACTER*(*) LABG +C +C The routine AGEZSU is used by the AUTOGRAPH routines EZY, EZXY, EZMY, +C EZMXY, and IDIOT to examine those parameters which are peculiar to the +C old version of AUTOGRAPH and to do the appropriate call to AGSTUP. +C The arguments are as follows: +C +C -- ITOC indicates which routine is calling AGEZSU, as follows: +C +C -- ITOC .EQ. 1 - call by EZY +C -- ITOC .EQ. 2 - call by EZXY +C -- ITOC .EQ. 3 - call by EZMY +C -- ITOC .EQ. 4 - call by EZMXY +C -- ITOC .EQ. 5 - call by IDIOT +C +C -- XDRA is an array of x-coordinate data. +C +C -- YDRA is an array of y-coordinate data. +C +C -- IDXY is the first dimension of YDRA. +C +C -- MANY is the number of curves defined by XDRA and YDRA. +C +C -- NPTS is the number of points per curve. +C +C -- LABG is a new header label (or the single character CHAR(0), if the +C header label is to be unchanged). +C +C -- IIVX, IIEX, IIVY, and IIEY are indexing controls for the x and y +C data arrays, computed and returned by AGEZSU for use in setting up +C calls to the routine AGCURV. +C +C Examine the frame-advance parameter. Do frame advance as appropriate. +C + CALL AGGETI ('FRAM.',IFRA) + IFRA=MAX0(1,MIN0(3,IFRA)) +C + IF (IFRA.EQ.3) CALL FRAME +C +C Set up the header label. +C + IF (ICHAR(LABG(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'T') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABG) + END IF +C +C Set up the AGSTUP arguments defining the coordinate-data arrays. +C + CALL AGGETI ('ROW .',IROW) + IROW=MAX0(-2,MIN0(+2,IROW)) +C + NVIY=MANY + IIVY=IDXY + NEVY=NPTS + IIEY=1 +C + IF (IROW.LE.0.AND.ITOC.GE.3.AND.ITOC.LE.4) THEN + IIVY=1 + IIEY=IDXY + END IF +C + NVIX=NVIY + IIVX=IIVY + NEVX=NEVY + IIEX=IIEY +C + IF (IABS(IROW).LE.1) THEN + NVIX=1 + IIVX=0 + NEVX=NPTS + IIEX=1 + END IF +C + IF (ITOC.EQ.1.OR.ITOC.EQ.3) IIEX=0 +C +C Do the AGSTUP call. +C + CALL AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agfpbn.f b/sys/gio/ncarutil/autograph/agfpbn.f new file mode 100644 index 00000000..f4900b60 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agfpbn.f @@ -0,0 +1,37 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + INTEGER FUNCTION AGFPBN (FPDP) +C +C The value of AGFPBN(FPDP) is a binary dash pattern, obtained from the +C floating-point dash pattern FPDP. On machines having a word length +C greater than 16 bits, AGFPBN(FPDP) = IFIX(FPDP). On machines having +C a word length of 16 bits, this is not true. For example, when FPDP = +C 65535. (2 to the 16th minus 1), the equivalent binary dash pattern +C does not have the value 65535, but the value -1 (assuming integers +C are represented in a ones' complement format). So, the functions +C ISHIFT and IOR must be used to generate the dash pattern. +C + TEMP=FPDP + AGFPBN=0 +C + DO 101 I=1,16 + IF (AMOD(TEMP,2.).GE.1.) AGFPBN=IOR(AGFPBN,ISHIFT(1,I-1)) + TEMP=TEMP/2. + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agftol.f b/sys/gio/ncarutil/autograph/agftol.f new file mode 100644 index 00000000..b685f913 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agftol.f @@ -0,0 +1,119 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGFTOL (IAXS,IDMA,VINP,VOTP,VLCS,LLUA,UBEG,UDIF,FUNS, + + NBTP,SBSE) +C +C The routine AGFTOL is used by AGAXIS to map a fractional distance +C along the axis to a value in the label coordinate system or vice- +C versa. Its arguments are as follows: +C +C -- IAXS specifies which axis is being drawn. It is passed to the +C routine AGUTOL. See AGAXIS for a complete description of IAXS. +C +C -- IDMA specifies the direction of the mapping - from the fractional +C system to the label system if IDMA .GT. 0 or from the label system +C to the fractional system if IDMA .LT. 0. IDMA also specifies how +C the label-system value is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .EQ. 1, an actual value in the label coordinate +C system (VLCS) is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .NE. 1, a value of the exponent/multiplier EXMU +C corresponding to VLCS is given to or returned by AGFTOL. +C +C -- VINP is an input value in one coordinate system. +C +C -- VOTP is an output value in the other coordinate system. +C +C -- VLCS is an output value in the label coordinate system, returned +C no matter what the value of IDMA. +C +C -- LLUA, UBGA, and UDFA specify the mapping from the user coordinate +C system to the fractional system and vice-versa. See the routine +C AGAXIS for a complete description of these parameters. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL. It +C selects the mapping from the user coordinate system to the label +C coordinate system and vice-versa. See the routine AGAXIS for a +C complete description of this parameter. +C +C -- NBTP and SBSE specify the mapping of label-coordinate-system values +C to exponent/multiplier values and vice-versa. See the routine +C AGNUMB for a complete dexcription of these parameters. +C +C Determine desired direction of mapping. +C + IF (IDMA.GT.0) THEN +C +C Map axis fraction VINP to a label-coordinate-system value VLCS. +C + VUCS=UBEG+VINP*UDIF + IF (LLUA.NE.0) VUCS=10.**VUCS + CALL AGUTOL (IAXS,FUNS,1,VUCS,VLCS) +C +C If IDMA .EQ. 1, caller wants VLCS - otherwise, map VLCS to the +C appropriate exponent/multiplier value EXMU - return value in VOTP. +C + IF (IDMA.EQ.1) THEN + VOTP=VLCS + RETURN + END IF +C + GO TO (101,102,103) , NBTP +C + 101 VOTP=VLCS/SBSE + RETURN +C + 102 VOTP=ALOG10(VLCS/SBSE) + RETURN +C + 103 VOTP=ALOG10(ABS(VLCS))/ALOG10(ABS(SBSE)) + RETURN +C + ELSE +C +C If IDMA .EQ. -1, caller has provided VINP .EQ. VLCS, a value in the +C label coordinate system - otherwise, VINP .EQ. EXMU, the exponent/ +C multiplier needed to generate VLCS. +C + IF (IDMA.EQ.(-1)) THEN + VLCS=VINP + GO TO 107 + END IF +C + GO TO (104,105,106) , NBTP +C + 104 VLCS=SBSE*VINP + GO TO 107 +C + 105 VLCS=SBSE*10.**VINP + GO TO 107 +C + 106 VLCS=SIGN(1.,SBSE)*ABS(SBSE)**VINP +C +C Map label-system value VLCS to a user-system value VUCS. +C + 107 CALL AGUTOL (IAXS,FUNS,-1,VLCS,VUCS) +C +C Map user-system value VUCS to an axis fraction VOTP and return. +C + IF (LLUA.NE.0) VUCS=ALOG10(VUCS) + VOTP=(VUCS-UBEG)/UDIF + RETURN +C + END IF +C + END diff --git a/sys/gio/ncarutil/autograph/aggetc.f b/sys/gio/ncarutil/autograph/aggetc.f new file mode 100644 index 00000000..caf9f357 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetc.f @@ -0,0 +1,51 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGGETC is used to get the character strings represented +C by the values of certain individual AUTOGRAPH parameters. TPID is a +C parameter identifier (from the caller). CUSR is a character string +C (returned to the caller). +C +C See what kind of parameter is being gotten. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Otherwise, get the integer value of the parameter and use that to get +C the desired character string. +C + CALL AGGETP (TPID,FURA,1) + CALL AGGTCH (IFIX(FURA(1)),CUSR,LNCS) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETC - PARAMETER TO GET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',2,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aggetf.f b/sys/gio/ncarutil/autograph/aggetf.f new file mode 100644 index 00000000..6391222b --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETF may be used to get the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + FUSR=FURA(1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggeti.f b/sys/gio/ncarutil/autograph/aggeti.f new file mode 100644 index 00000000..31841826 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggeti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETI may be used to get the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + IUSR=IFIX(FURA(1)) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggetp.f b/sys/gio/ncarutil/autograph/aggetp.f new file mode 100644 index 00000000..ac44085e --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetp.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETP returns to the user the AUTOGRAPH parameter(s) +C specified by the parameter identifier TPID. The arguments are as +C follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array which is to receive the desired parameter(s) +C specified by TPID. +C +C -- LURA is the length of the user array FURA. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Define the array DUMI, which allows access to the parameter list as +C an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters desired. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of elements to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C Transfer the desired parameters to the user array. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + FURA(IURA)=DUMI(IDMI) + 101 CONTINUE +C +C If the current label name is being gotten, return its identifier. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN.AND.NIPA.EQ.NILN.AND.QBAN.NE.0.) THEN + LBAN=IFIX(QBAN) + FURA(1)=FLLB(1,LBAN) + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggtch.f b/sys/gio/ncarutil/autograph/aggtch.f new file mode 100644 index 00000000..7591c670 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggtch.f @@ -0,0 +1,78 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGTCH (IDCS,CHST,LNCS) +C + CHARACTER*(*) CHST +C +C This routine gets character strings previously stored by the routine +C AGSTCH (which see). It has the following arguments: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C -- CHST is the character string returned. +C +C -- LNCS is the length of the character string returned in CHST. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C First, blank-fill the character variable to be returned. +C + CHST=' ' +C +C If the identifier is less than -LNIC, the (one-character) string is +C retrieved from it. +C + IF (IDCS.LT.(-LNIC)) THEN + CHST=CHAR(-IDCS-LNIC-1) + LNCS=1 +C +C If the identifier is between -LNIC and -1, its absolute value is the +C index, in INCH, of the descriptor of the character string stored in +C CHRA. +C + ELSE IF (IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I)-1 + IF (J.GE.0) THEN + LNCS=MIN0(LEN(CHST),INCH(2,I)) + DO 101 K=1,LNCS + J=J+1 + CHST(K:K)=CHRA(J) + 101 CONTINUE + ELSE + LNCS=0 + END IF +C +C In all other cases, return a single blank. +C + ELSE + LNCS=1 +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aginit.f b/sys/gio/ncarutil/autograph/aginit.f new file mode 100644 index 00000000..e863e01f --- /dev/null +++ b/sys/gio/ncarutil/autograph/aginit.f @@ -0,0 +1,113 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGINIT +C +C This routine is called to initialize some machine-dependent constants. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Fill in the names of the four pre-defined labels. +C + CALL AGSTCH ('L',1,IDCS) + FLLB(1,1)=FLOAT(IDCS) + CALL AGSTCH ('R',1,IDCS) + FLLB(1,2)=FLOAT(IDCS) + CALL AGSTCH ('B',1,IDCS) + FLLB(1,3)=FLOAT(IDCS) + CALL AGSTCH ('T',1,IDCS) + FLLB(1,4)=FLOAT(IDCS) +C +C Declare the rest of the label-definition slots to be available. +C + LBIM=IFIX(QBIM) +C + DO 101 J=5,LBIM + FLLB(1,J)=0. + 101 CONTINUE +C +C Fill in the text of the four pre-defined lines. +C + CALL AGSTCH ('Y',1,IDCS) + FLLN(4,1)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,2)=FLOAT(IDCS) + CALL AGSTCH ('X',1,IDCS) + FLLN(4,3)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,4)=FLOAT(IDCS) +C +C Declare the rest of the line-definition slots to be available. +C + LNIM=IFIX(QNIM) +C + DO 102 J=5,LNIM + FLLN(1,J)=SVAL(1) + 102 CONTINUE +C +C Set the value of 'LINE/TERMINATOR.' +C + CALL AGSTCH ('$',1,IDCS) + TCLN=FLOAT(IDCS) +C +C SMRL is used by AUTOGRAPH for rounding operations. +C + SMRL=10.**(3-IFIX(ALOG10(FLOAT(I1MACH(10)))*FLOAT(I1MACH(11)))) +C +C ISLD is an integer containing 16 one bits (right-justified with zero +C fill to the left). It is used to direct the DASHCHAR package to draw +C solid lines. To generate it, we start with a 15-bit mask and then +C add another bit. +C + ISLD = 32767 + ISLD = ISHIFT(ISLD,1) + ISLD = IOR(ISLD,1) +C +C Set the initialization flag to indicate initialization has been done. +C + INIF=1 +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agkurv.f b/sys/gio/ncarutil/autograph/agkurv.f new file mode 100644 index 00000000..d93f0659 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agkurv.f @@ -0,0 +1,145 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGKURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C No windowing is performed. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point flag. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 102 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Start or continue line. +C + IF (LDLP.EQ.0) THEN + CALL FRSTD (XNXT,YNXT) + XLST=XNXT + YLST=YNXT + ELSE + CALL VECTD (XNXT,YNXT) + END IF +C + LDLP=LDLP+1 + GO TO 101 +C +C Last point was final point. Finish up. +C + 102 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGKURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',3,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aglbls.f b/sys/gio/ncarutil/autograph/aglbls.f new file mode 100644 index 00000000..d99b038d --- /dev/null +++ b/sys/gio/ncarutil/autograph/aglbls.f @@ -0,0 +1,616 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGLBLS (ITST,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C + DIMENSION FLLB(10,8),FLLN(6,16),DBOX(6,4),SBOX(6,4),RBOX(6) +C +C The routine AGLBLS is used (if ITST .LE. 0) to predict the amount of +C space which will be required for graph labels (excluding the numeric +C labels on the axes, which are handled by AGAXIS) or (if ITST .GT. 0) +C to actually draw the graph labels. +C +C The labels in question are defined by the label list (FLLB array) and +C the line list (FLLN array). Each label is assumed to lie in one of +C five boxes, as follows: +C +C Box 1 is to the left of the curve window. +C Box 2 is to the right of the curve window. +C Box 3 is below the curve window. +C Box 4 is above the curve window. +C Box 5 is the curve window itself. +C Box 6 is the entire plot (graph) window. +C +C A test run of AGLBLS returns two sets of box dimensions to the caller. +C DBOX contains the dimensions required if all labels are to have their +C desired sizes, SBOX the dimensions required if all labels are to have +C their smallest sizes. The caller is expected to use this information +C to determine a final set of box dimensions (stored in DBOX), and then +C call AGLBLS again to actually draw the labels in those boxes. +C +C The arguments of AGLBLS are as follows: +C +C -- ITST specifies whether the call is a test call (ITST .LE. 0) or a +C real call (ITST .GT. 0). If ABSV(ITST) .GT. 1, AGLBLS is allowed +C to shrink the labels if they would not otherwise fit in their box. +C If ABSV(ITST) .EQ. 1, shrinkage of labels is prohibited. If ITST +C .EQ. 0, labels are suppressed. +C +C -- WCWP and HCWP are the width and height of the curve window, in +C plotter-coordinate-system units. AGLBLS assumes that the last call +C to the plot package routine "SET" had arguments XLCW, XRCW, YBCW, +C YTCW, 0., 1., 0., 1., and 1 - defining the most convenient system +C of coordinates for it. +C +C -- FLLB is the array in which the label list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of ten label +C attributes, the second a particular label. The attributes are as +C follows (the name ILLB(M,N) refers to a label attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLB(1,N) specifies the name of label N. If ILLB(1,N) is zero, +C no label is defined. Otherwise, ILLB(1,N) is an identifier +C returned by AGSTCH when the name of the label (a character +C string) was stored away. +C +C -- ILLB(2,N) may be set non-zero to suppress label N. +C +C -- FLLB(3,N) and FLLB(4,N) are the x and y coordinates of a base- +C point relative to which label N is positioned, as fractions of +C the width and height, respectively, of the curve window. The +C position of the base-point determines the box in which label N +C is considered to lie. +C +C -- FLLB(5,N) and FLLB(6,N) are small offsets (typically about the +C size of a character width), stated as fractions of the smaller +C side of the curve window. They are used to offset the label +C base-point (after the box number is determined). Typically, +C this provides a minimum spacing between the label and one side +C of the curve window. +C +C -- ILLB(7,N) is the orientation angle of the label, in degrees +C counter-clockwise from horizontal. The base-line for label N +C is a vector emanating from the base-point at this angle. The +C specified angle must be a multiple of 90 degrees. +C +C -- ILLB(8,N) is the centering option for the label. It specifies +C how each line of the label is to be positioned relative to a +C line perpendicular to the base-line at the base-point. +C +C -- If ILLB(8,N) .LT. 0, the left edge of each line lies on +C the perpendicular. +C +C -- If ILLB(8,N) .EQ. 0, the center of each line lies on the +C perpendicular. +C +C -- If ILLB(8,N) .GT. 0, the right edge of each line lies on +C the perpendicular. +C +C -- ILLB(9,N) is the number of lines in label N. +C +C -- ILLB(10,N) is the second subscript (in the line list) of the +C first line of label N. +C +C -- LBIM is the maximum number of labels the label list will hold. +C +C -- FLLN is the array in which the line list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of six line +C attributes, the second a particular line. The attributes are as +C follows (the name ILLN(M,N) refers to a line attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLN(1,N) is the position number of line N. The lines of a +C label are ordered according to their position numbers, the one +C having the largest position number being top-most. Moreover, +C lines having position numbers .GT. 0 are placed above the label +C base-line, those having position numbers .EQ. 0 (of which there +C should be but one) are placed on the label base-line, and those +C having position numbers .LT. 0 are placed below the label base- +C line. The magnitudes of the position numbers have nothing to +C do with inter-line spacing - that is up to AGLBLS to determine. +C +C -- ILLN(2,N) may be set non-zero to suppress line N. +C +C -- FLLN(3,N) is the desired width of characters in the line, as a +C fraction of the smaller side of the curve window. +C +C -- ILLN(4,N) is the identifier of the character string comprising +C the text of the line, as returned by AGSTCH at the time the +C string was stored. +C +C -- ILLN(5,N) is the number of characters in the line. +C +C -- ILLN(6,N) is the index of the next line of the label. The +C lines of a label must be ordered by position number (largest +C to smallest). +C +C -- DBOX and SBOX, dimensioned 6 X 4, contain box dimensions, as dis- +C cussed above. D/SBOX(M,N) is the Nth edge-coordinate of box M, +C where N .EQ. 1 for the left edge, 2 for the right edge, 3 for the +C bottom edge, and 4 for the top edge, of the box. The first two are +C stated as fractions of the width, the second two as fractions of +C the height, of the curve window. +C +C RBOX, dimensioned 6, holds reduction factors for the sizes of the +C characters in labels in each of the six boxes. Each RBOX(M) is +C +C -- negative to specify smallest-size characters, or +C +C -- zero to specify that no reduction factor has been chosen, or +C +C -- positive, between 0. and 1. (an actual reduction factor). +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only one of +C interest here is MWCL, which is the minimum usable character width, +C in plotter units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C HCFW(WDTH) specifies the height of a character as a function of width. +C + HCFW(WDTH)=2.*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the main section of AGLBLS. +C +C Compute the length of the smallest side of the curve window. +C + SCWP=AMIN1(WCWP,HCWP) +C +C Preset certain jumps in the internal procedure which follows. +C + ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + ASSIGN 221 TO JMP3 +C +C Jump if this is a test run. +C + IF (ITST.LE.0) GO TO 101 +C +C This is not a test run. If the reduction factors for the six boxes +C are already set, jump directly to the plotting section; otherwise, we +C must first compute the coordinates of the six smallest-size boxes. +C + IF (RBOX(1).NE.0.) GO TO 115 + GO TO 105 +C +C This is a test run. Compute the coordinates of the edges of the six +C desired-size boxes. +C + 101 RWCL=1. + NBOX=0 + ASSIGN 102 TO JMP4 + GO TO 200 +C + 102 DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C This is a test run. Compute the coordinates of the edges of the six +C smallest-size boxes, in one of two ways. +C + IF (IABS(ITST).GT.1) GO TO 105 +C +C This is a test run. Determine smallest-size boxes (no shrinking). +C + DO 104 J=1,4 + DO 103 I=1,6 + SBOX(I,J)=DBOX(I,J) + 103 CONTINUE + 104 CONTINUE + RETURN +C +C Determine smallest-size boxes (shrinking allowed). +C + 105 RWCL=0. + NBOX=0 + ASSIGN 106 TO JMP4 + GO TO 200 +C + 106 SBOX(NBOX,1)=XLBX + SBOX(NBOX,2)=XRBX + SBOX(NBOX,3)=YBBX + SBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C If this is not a test run, jump to compute reduction factors for each +C of the six boxes and then plot the labels. Otherwise, return. +C + IF (ITST.GT.0) GO TO 107 + RETURN +C +C This is not a test run. Compute reduction factors for each of the +C six boxes. +C + 107 NBOX=1 + ASSIGN 110 TO JMP4 +C +C (DBOX(NBOX,I),I=1,4) specifies the box in which the labels are to be +C drawn, (SBOX(NBOX,I),I=1,4) the minimum box in which they can be drawn +C if shrunk. Check first whether the latter is contained in the former. +C If so, we have a chance. If not, the best we can do is shrink the +C labels to minimum size and hope for the best. +C + 108 IF (SBOX(NBOX,1).LT.SBOX(NBOX,2).AND. + + DBOX(NBOX,1)-SBOX(NBOX,1).LT..0001.AND. + + SBOX(NBOX,2)-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-SBOX(NBOX,3).LT..0001.AND. + + SBOX(NBOX,4)-DBOX(NBOX,4).LT..0001 ) GO TO 109 +C + RBOX(NBOX)=-1. + GO TO 114 +C +C Mimimum-size labels will fit. Find the largest value of RBOX(NBOX) +C for which the labels will fit. +C + 109 RWCL=1. + DWCL=.5 + SWCL=0. + GO TO 201 +C +C See if the last value of RBOX(NBOX) gave us labels which would fit or +C not and adjust the value accordingly. +C + 110 IF (DBOX(NBOX,1)-XLBX.LT..0001.AND. + + XRBX-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-YBBX.LT..0001.AND. + + YTBX-DBOX(NBOX,4).LT..0001 ) GO TO 111 +C +C Labels did not fit. Adjust RBOX(NBOX) downward. +C + RWCL=RWCL-DWCL + DWCL=.5*DWCL + IF (DWCL.LT..001) RWCL=SWCL + GO TO 201 +C +C Labels did fit. Adjust RBOX(NBOX) upward, unless it is equal to 1. +C + 111 IF (RWCL.EQ.1.) GO TO 113 + SWCL=RWCL + RWCL=RWCL+DWCL + DWCL=.5*DWCL + IF (DWCL.GT..001) GO TO 201 +C +C The current value of RBOX(NBOX) is acceptable. Do next box, if any. +C + 113 IF (NBOX.GE.5) GO TO 114 +C +C Return updated box-edge coordinates for boxes 1 through 4. +C + DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + 114 NBOX=NBOX+1 + IF (NBOX.LE.6) GO TO 108 +C +C We have done all we can to make the labels fit. Plot them now. +C + 115 NBOX=0 + LBIN=0 + ASSIGN 117 TO JMP3 + ASSIGN 120 TO JMP4 +C +C Get a label to chew on. +C + 116 ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + GO TO 202 +C +C We have a label. Initialize the re-loop through the lines in it. +C + 117 XPLN=XPLB-DTLB*YDLB/WCWP + YPLN=YPLB+DTLB*XDLB/HCWP + PHCL=0. + LNIN=LNII + ASSIGN 118 TO JMP1 + ASSIGN 116 TO JMP2 + GO TO 210 +C +C Get ready to plot the label line. +C + 118 XPLN=XPLN+.5*(PHCL+FHCL)*YDLB/WCWP + YPLN=YPLN-.5*(PHCL+FHCL)*XDLB/HCWP + PHCL=FHCL + CALL AGGTCH (IFIX(FLLN(4,LNIN)),CHS2,LNC2) +C +C Give the user a chance to change the appearance of the label line. +C + CALL AGCHIL (0,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Plot the label line. +C + CALL AGPWRT (XPLN,YPLN,CHS2,LNC2,IWCL,LBOR,LBCN) +C +C Give the user a chance to undo the changes he made above. +C + CALL AGCHIL (1,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Go get the next line, if any. +C + GO TO 215 +C +C All labels are drawn. Return. +C + 120 RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure, which may be entered and exited in a number +C of different ways, is used to scan the label list and the line list +C and to return information about the labels and lines defined there. +C +C Entry occurs here to bump the box number, store away a reduction +C factor for the sizes of labels in that box, and then compute the edge +C coordinates of the box required to hold labels of the size implied by +C that reduction factor. +C + 200 NBOX=NBOX+1 +C +C Entry occurs here to do all of the above except the bumping of the box +C number. +C + 201 RBOX(NBOX)=RWCL +C +C Initialize the label-list index and the box-edge parameters. +C + LBIN=0 + XLBX=+1000. + XRBX=-1000. + YBBX=+1000. + YTBX=-1000. + IF (ITST.EQ.0) GO TO 222 +C +C This is the beginning of the loop through the labels. Entry occurs +C here to find the next label in the list and return positioning info. +C +C Increment the label index and test for end of label list. +C + 202 LBIN=LBIN+1 + IF (LBIN.GT.LBIM) GO TO 222 +C +C Skip this label if it is non-existent, suppressed, or empty. +C + IF (FLLB(1,LBIN).EQ.0..OR.FLLB(2,LBIN).NE.0. + + .OR.FLLB(9,LBIN).EQ.0.) GO TO 202 +C +C Unpack the parameters specifying the label-base-point position. +C + XBLB=FLLB(3,LBIN) + YBLB=FLLB(4,LBIN) + XOLB=FLLB(5,LBIN) + YOLB=FLLB(6,LBIN) +C +C Determine in which of five boxes the label lies: +C +C in the box to the left of the curve window. +C + LBBX=1 + IF (XBLB.EQ.0..AND.XOLB.LE.0.) GO TO 203 +C +C in the box to the right of the curve window, +C + LBBX=2 + IF (XBLB.EQ.1..AND.XOLB.GE.0.) GO TO 203 +C +C in the box below the curve window, +C + LBBX=3 + IF (YBLB.EQ.0..AND.YOLB.LE.0.) GO TO 203 +C +C in the box above the curve window, +C + LBBX=4 + IF (YBLB.EQ.1..AND.YOLB.GE.0.) GO TO 203 +C +C in the curve window, +C + LBBX=5 + IF ( (XBLB.EQ.0..AND.XOLB.GT.0.).OR. + + (XBLB.EQ.1..AND.XOLB.LT.0.).OR. + + (YBLB.EQ.0..AND.YOLB.GT.0.).OR. + + (YBLB.EQ.1..AND.YOLB.LT.0.) ) GO TO 203 +C +C or elsewhere. +C + LBBX=6 +C +C If we are interested in a particular box and this label is not in that +C box, skip it. +C + 203 IF (NBOX.NE.0.AND.LBBX.NE.NBOX) GO TO 202 +C +C On a non-test run, get the label name and length for call to AGCHIL. +C + IF (ITST.GT.0) CALL AGGTCH (IFIX(FLLB(1,LBIN)),CHS1,LNC1) +C +C Unpack the label orientation and compute its direction cosines. +C + LBOR=IFIX(FLLB(7,LBIN)) +C + XDLB=COS(.017453292519943*FLLB(7,LBIN)) + YDLB=SIN(.017453292519943*FLLB(7,LBIN)) +C +C Unpack the label-centering option. +C + LBCN=IFIX(FLLB(8,LBIN)) +C +C Unpack the index of the initial line of the label and save it. +C + LNIN=IFIX(FLLB(10,LBIN)) + LNII=LNIN +C +C If this is not a test run, modify the label-base-point position as +C needed to move the label into the actual box in which it must fit. +C + IF (ITST.LE.0) GO TO 209 +C + GO TO (204,205,206,207,208,209) , LBBX +C + 204 XBLB=XBLB+DBOX(1,2) + GO TO 209 +C + 205 XBLB=XBLB+DBOX(2,1)-1. + GO TO 209 +C + 206 YBLB=YBLB+DBOX(3,4) + GO TO 209 +C + 207 YBLB=YBLB+DBOX(4,3)-1. + GO TO 209 +C + 208 IF (XBLB.EQ.0.) XBLB=XBLB+DBOX(5,1) + IF (XBLB.EQ.1.) XBLB=XBLB+DBOX(5,2)-1. + IF (YBLB.EQ.0.) YBLB=YBLB+DBOX(5,3) + IF (YBLB.EQ.1.) YBLB=YBLB+DBOX(5,4)-1. +C +C Compute the final label-base-point position. +C + 209 XPLB=XBLB+XOLB*SCWP/WCWP + YPLB=YBLB+YOLB*SCWP/HCWP +C +C Before entering the loop through the line list, initialize the label- +C dimension parameters. +C + DLLB=0. + DRLB=0. + DBLB=0. + DTLB=0. +C +C This is the beginning of the loop through the lines in a given label. +C Entry may occur here to find the next line and return info about it. +C +C If the line is suppressed or of zero length, skip it. +C + 210 IF (FLLN(2,LNIN).NE.0..OR.FLLN(5,LNIN).LE.0.) GO TO 215 +C +C Unpack the position-number, character-width, and character-count +C parameters for the line. +C + LNPN=IFIX(FLLN(1,LNIN)) + WCLN=FLLN(3,LNIN) + LNCC=IFIX(FLLN(5,LNIN)) +C +C Compute the integer width (IWCL) and the floating-point width and +C height (FWCL and FHCL) of characters in the label. All are expressed +C in plotter-coordinate-system units. +C + IWCL=MAX0(MWCL,IFIX(RBOX(LBBX)*WCLN*SCWP+.5)) + FWCL=FLOAT(IWCL) + FHCL=HCFW(FWCL) +C +C Jump back with line information or drop through, as directed. +C + GO TO JMP1 , (118,211) +C +C Update the label-dimension parameters. +C + 211 DRLB=AMAX1(DRLB,FLOAT(LNCC)*FWCL) +C + IF (LNPN) 212,213,214 +C + 212 DBLB=DBLB+FHCL + GO TO 215 +C + 213 DBLB=DBLB+.5*FHCL + DTLB=DTLB+.5*FHCL + GO TO 215 +C + 214 DTLB=DTLB+FHCL +C +C Go to the next line in the label, if there is one. +C + 215 LNIN=IFIX(FLLN(6,LNIN)) + IF (LNIN.NE.0) GO TO 210 +C +C Jump back on end of lines or drop through, as directed. +C + GO TO JMP2 , (116,216) +C +C If all the lines in the label were either suppressed or of zero +C length, skip this label. +C + 216 IF (DRLB.EQ.0.) GO TO 202 +C +C Complete the computation of the label dimensions. The four parameters +C DLLB, DRLB, DBLB, and DTLB represent the distances from the base-point +C to the left edge, right edge, bottom edge, and top edge of the label, +C in plotter-coordinate-system units, where left, right, etc., are as +C viewed by a reader of the label. +C + IF (LBCN) 217,218,219 +C +C Left edges of lines are aligned. +C + 217 GO TO 220 +C +C Centers of lines are aligned. +C + 218 DLLB=.5*(DLLB+DRLB) + DRLB=DLLB + GO TO 220 +C +C Right edges of lines are aligned. +C + 219 SWAP=DLLB + DLLB=DRLB + DRLB=SWAP +C +C Jump back with label information or drop through, as directed. +C + 220 GO TO JMP3 , (117,221) +C +C Update the x and y coordinates of the label box edges. +C + 221 XLBX=AMIN1(XLBX,XBLB, + + XPLB-AMAX1(+DLLB*XDLB,-DRLB*XDLB,-DBLB*YDLB,+DTLB*YDLB)/WCWP) + XRBX=AMAX1(XRBX,XBLB, + + XPLB+AMAX1(-DLLB*XDLB,+DRLB*XDLB,+DBLB*YDLB,-DTLB*YDLB)/WCWP) + YBBX=AMIN1(YBBX,YBLB, + + YPLB-AMAX1(+DLLB*YDLB,-DRLB*YDLB,+DBLB*XDLB,-DTLB*XDLB)/HCWP) + YTBX=AMAX1(YTBX,YBLB, + + YPLB+AMAX1(-DLLB*YDLB,+DRLB*YDLB,-DBLB*XDLB,+DTLB*XDLB)/HCWP) +C +C Go back for the next label. +C + GO TO 202 +C +C End of label list. Jump as directed. +C + 222 GO TO JMP4 , (102,106,110,120) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C + END diff --git a/sys/gio/ncarutil/autograph/agmaxi.f b/sys/gio/ncarutil/autograph/agmaxi.f new file mode 100644 index 00000000..9c981e0d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmaxi.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMAXI (SVAL,ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMAXI returns the maximum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or more than ZHGH, if ZHGH is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and NEVZ is returned. +C + AGMAXI=FLOAT(NEVZ) + IF (IIEZ.EQ.0) RETURN +C + AGMAXI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZHGH.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).GT.ZHGH) GO TO 102 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agmini.f b/sys/gio/ncarutil/autograph/agmini.f new file mode 100644 index 00000000..be4b6d2c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmini.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMINI (SVAL,ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMINI returns the mimimum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or less than ZLOW, if ZLOW is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and 1. is returned. +C + AGMINI=1. + IF (IIEZ.EQ.0) RETURN +C + AGMINI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZLOW.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).LT.ZLOW) GO TO 102 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agnumb.f b/sys/gio/ncarutil/autograph/agnumb.f new file mode 100644 index 00000000..24469772 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agnumb.f @@ -0,0 +1,491 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGNUMB (NBTP,SBSE,EXMU , NLTP,NLEX,NLFL , + + BFRM,MCIM,NCIM,IPXM , BFRE,MCIE,NCIE) +C + CHARACTER*(*) BFRM,BFRE +C +C The routine AGNUMB converts the number specified by the arguments +C NBTP, SBSE, and EXMU to the label format specified by the arguments +C NLTP, NLEX, and NLFL, returning the characters of the mantissa in the +C buffer BFRM and the characters of the exponent in the buffer BFRE, +C ready for plotting. The arguments of AGNUMB are as follows: +C +C -- NBTP is an integer specifying the type of number to be converted. +C There are three possibilities: +C +C NBTP = 1 - number of the form SBSE * EXMU. +C +C NBTP = 2 - number of the form SBSE * 10**EXMU. +C +C NBTP = 3 - number of the form SIGN(SBSE) * ABSV(SBSE)**EXMU. +C +C -- SBSE is a base value for a set of labels. See NBTP description. +C +C -- EXMU is an exponent or a multiplier for a given label. Although it +C is a floating-point number, its value should be integral, unless +C NBTP equals 1 and/or NLTP equals 1. Using a non-integral EXMU in +C other cases will have undesirable effects. See NBTP description. +C +C -- NLTP is an integer specifying the type of label to be generated. +C There are three possibilities: +C +C -- NLTP = 1 - label is to have an exponent portion and is to be +C expressed in scientific notation. +C +C -- NLTP = 2 - label is to have an exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C -- NLTP = 3 - label is to have no exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C The possible label types will be described in greater detail below. +C +C -- NLEX (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the value of the exponent portion +C of the label. See the detailed discussion of label types, below. +C +C -- NLFL (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the length of the fractional por- +C tion of the mantissa of the label. See the detailed discussion of +C label types, below. +C +C -- BFRM is a character variable in which the mantissa portion of the +C label is to be returned. +C +C -- MCIM specifies the maximum number of characters BFRM can hold. +C +C -- NCIM is the number of characters returned in BFRM by AGNUMB. +C +C -- IPXM is the position of the character X in the mantissa. If IPXM +C is zero, the character X does not occur in the mantissa. +C +C -- BFRE, MCIE, and NCIE are analogous to BFRM, MCIM, and NCIM, but +C pertain to the exponent portion of the label. +C +C Label types: AGNUMB will produce many different types of labels, as +C directed by the various input parameters. Each of these is described +C below. The general form of a label is +C +C (-) (1/) (I) (.) (F) (X 10) (E) +C +C where the parentheses are used to mark portions which may either be +C present or absent. The minus sign is included only if the label value +C is negative. I is the integer portion of the mantissa, included only +C if its value is non-zero. The decimal point is included if the input +C parameter NLFL does not specifically direct that it should be omitted +C or if the fractional portion of the mantissa (F) is present. F is the +C fractional portion of the mantissa. The "X 10" is included if it is +C appropriate, and is considered to be a part of the mantissa; if it is +C included, a blank is actually returned for the character X, so the +C routine which plots the label should construct this character by +C drawing two short lines. E is the exponent, returned in a separate +C buffer so that it may be plotted in a superscript form. The possible +C label types are, then, as follows: +C +C -- Scientific notation - if the label type NLTP equals 1, the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the length of I (thus also specifying the +C value of the exponent E). If NLEX is .LE. 0, I is omitted. If +C NLEX is .LT. 0 and has the absolute value N, the fraction F is +C forced to have N leading zeroes. NLFL specifies the length of F. +C If NLFL is .LE. 0, F is omitted. If NLFL is .LT. 0, the decimal +C point is omitted. If (I.F) has the value 1, (I.F X) is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- Exponential, but non-scientific notation - if the label type NLTP +C equals 2, the form used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the value of the exponent E. The +C length of F is specified by NLFL. If NLFL is .LE. 0, F is +C omitted. If NLFL is .LT. 0, the decimal point is omitted. If +C the label value is exactly 0, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. The exponent E has the value NLEX+EXMU. The length +C of F is specified by NLFL. If NLFL is .LE. 0, F is omitted. +C If NLFL is .LT. 0, the decimal point is omitted. If the label +C value is exactly 0, the character 0 is used. If (I.F) has the +C value 1., then (I.F X) is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) (E) +C +C is used. The exponent E has the value EXMU. The length of F +C is specified by NLFL. If NLFL is .LE. 0, F is omitted. If +C NLFL is .LT. 0, the decimal point is omitted. +C +C -- No-exponent notation - if the label type NLTP equals 3, the form +C used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. NLFL specifies the length of F. If NLFL is .LE. 0, +C F is omitted. If NLFL is .LT. 0, the decimal point is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. The length of F is specified by the function +C +C MAX(NLFL,0)-EXMU (if EXMU is .LT. MAX(NLFL,0)) +C MIN(NLFL,0) (if EXMU is .GE. MAX(NLFL,0)) +C +C which may appear somewhat formidable, but produces a simple, +C desirable result. Suppose, for example, that SBSE = 3.6, +C NLFL = 1, and EXMU ranges from -3 to +3 - the labels produced +C are as follows: +C +C .0036 .036 .36 3.6 36. 360. 3600. +C +C NLFL may be viewed as specifying the length of F if EXMU is 0. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) +C +C is used if EXMU is positive (or zero), and the form +C +C (-) 1 / (I) (.) (F) +C +C is used if EXMU is negative. The length of F is specified by +C the function +C +C NLFL * ABSV(EXMU) (if EXMU is .NE. 0) +C MIN(NLFL,0) (if EXMU is .EQ. 0) +C +C Again, this function produces a simple result. Suppose that +C SBSE = 1.1, NLFL = 1, and EXMU ranges from -3 to +3 - the +C labels produced are as follows: +C +C 1/1.331 1/1.21 1/1.1 1. 1.1 1.21 1.331 +C +C NLFL may be viewed as specifying the length of F if EXMU is 1. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. As another +C example, suppose that SBSE = 2., NLFL = -1, and EXMU ranges +C from -4 to +4. The labels produced are as follows: +C +C 1/16 1/8 1/4 1/2 1 2 4 8 16 +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C KHAR holds single characters to be stored away in BFRM or BFRE. +C + CHARACTER*1 KHAR +C +C Zero character counters and pointers. +C + NCIM=0 + NCIE=0 + IPXM=0 +C +C Compute a jump parameter to allow a quick sorting-out of the possible +C number-type/label-type combinations below. +C + NTLT=NBTP+3*(NLTP-1) +C +C Compute the value (XMAN) from which the characters of the mantissa +C will be generated. +C + GO TO (101,102,103,101,102,104,101,102,105) , NTLT +C + 101 XMAN=SBSE*EXMU + GO TO 106 +C + 102 XMAN=SBSE*SNGL(10.D0**DBLE(EXMU)) + GO TO 106 +C + 103 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(EXMU)) + GO TO 106 +C + 104 XMAN=SBSE + GO TO 106 +C + 105 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(ABS(EXMU))) +C +C If the mantissa-generator is negative, make it positive and put a +C minus sign in the mantissa buffer. +C + 106 IF (XMAN.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='-' + XMAN=-XMAN + END IF +C +C If the number is zero, put a zero in the mantissa buffer and quit. +C + IF (XMAN.EQ.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' + RETURN + END IF +C +C Reduce the mantissa-generator to the range (1.,10.), keeping track of +C the power of 10 required to do it. Round the result, keeping in mind +C that the rounding may kick the value past 10. . +C + IMAN=IFIX(ALOG10(XMAN)) + IF (XMAN.LT.1.) IMAN=IMAN-1 + XMAN=XMAN*SNGL(10.D0**(-IMAN))+SMRL + IF (XMAN.GE.10.) THEN + XMAN=XMAN/10. + IMAN=IMAN+1 + END IF +C +C Jump (depending on the number-type/label-type combination) to set up +C the label-generation control parameters, as follows: +C +C NDPD - number of digits to precede decimal point - if NDPD .LT. 0, +C ABS(NDPD) leading zeroes follow the decimal point, preceding +C the first digit generated from XMAN. +C NDFD - number of digits to follow decimal point - if NDFD .LT. 0, +C the decimal point is suppressed. +C IF10 - flag, set non-zero to force generation of the (X 10) portion +C of the label. +C IFEX - flag, set non-zero to force generation of an exponent. +C IVEX - value of exponent (if any) - always equals (IMAN+1) - NDPD. +C + GO TO (107,107,107,108,109,110,111,112,113) , NTLT +C +C Scientific notation. +C + 107 NDPD=NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * EXMU. +C + 108 NDPD=IMAN+1-NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * 10**EXMU. +C + 109 NDPD=IMAN+1-(NLEX+IFIX(EXMU+SMRL*EXMU)) + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SIGN(SBSE) * ABSV(SBSE)**EXMU. +C + 110 NDPD=IMAN+1 + IMAN=IMAN+IFIX(EXMU+SMRL*EXMU) + NDFD=NLFL + IF10=0 + IFEX=1 + GO TO 115 +C +C No-exponent notation for SBSE * EXMU. +C + 111 NDPD=IMAN+1 + NDFD=NLFL + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SBSE * 10**EXMU. +C + 112 NDPD=IMAN+1 + NDFD=MAX0(NLFL,0)-IFIX(EXMU+SMRL*EXMU) + IF (NDFD.LE.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SIGN(SBSE) * ABSV(SBSE)**EXMU +C + 113 IF (EXMU.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='/' + END IF +C + NDPD=IMAN+1 + NDFD=NLFL*IFIX(ABS(EXMU+SMRL*EXMU)) + IF (NDFD.EQ.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C If there is an exponent of 10 and the mantissa is precisely 1, omit +C the (I.F X) portion of the mantissa. +C + 114 IF (NDPD.NE.1) GO TO 115 + IF (IFIX(XMAN).NE.1) GO TO 115 + IF (((XMAN-1.)*10.**MAX0(0,NDFD)).GE.1.) GO TO 115 + IVEX=IMAN+1-NDPD + GO TO 123 +C +C Generate the characters of the mantissa (I.F). Check first for zero- +C or-negative-length error. +C + 115 LMAN=MAX0(NDPD,0)+1+MAX0(NDFD,-1) + IF (LMAN.LE.0) GO TO 903 +C +C Make sure the mantissa buffer is big enough to hold (I.F). +C + IF (NCIM+LMAN.GT.MCIM) GO TO 901 +C +C Compute the value of the parameter IVEX before changing NDPD. +C + IVEX=IMAN+1-NDPD +C +C Generate the digits preceding the decimal point, if any. +C + IF (NDPD.LE.0) GO TO 117 +C + ASSIGN 116 TO JUMP + GO TO 121 +C + 116 NDPD=NDPD-1 + IF (NDPD.NE.0) GO TO 121 +C +C Generate the decimal point. +C + 117 KHAR='.' + ASSIGN 118 TO JUMP + GO TO 122 +C +C Generate leading zeroes, if any, after the decimal point. +C + 118 IF (NDPD.EQ.0) GO TO 120 + KHAR='0' + ASSIGN 119 TO JUMP + GO TO 122 +C + 119 NDPD=NDPD+1 + IF (NDPD.NE.0) GO TO 122 +C +C Generate remaining fractional digits. +C + 120 ASSIGN 121 TO JUMP +C +C Generate a digit from the mantissa-generator. It is assumed that, for +C n between 1 and 9, ICHAR('n') = ICHAR('n-1') + 1 . +C + 121 IDGT=IFIX(XMAN) + KHAR=CHAR(ICHAR('0')+IDGT) + XMAN=XMAN-FLOAT(IDGT) + XMAN=XMAN*10. +C +C Store a digit from KHAR into the mantissa buffer. +C + 122 NCIM=NCIM+1 + BFRM(NCIM:NCIM)=KHAR +C +C Check whether (I.F) is complete. +C + LMAN=LMAN-1 + IF (LMAN.NE.0) GO TO JUMP , (116,118,119,121) +C +C If appropriate, leave space in the mantissa buffer for the "X" . +C + IF (IF10.EQ.0) GO TO 124 + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + IPXM=NCIM + BFRM(IPXM:IPXM)=' ' +C +C If appropriate, put a "10" in the mantissa buffer. +C + 123 NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' +C +C If appropriate, generate an exponent in the exponent buffer. +C + 124 IF (IFEX.EQ.0) RETURN +C + IF (IVEX) 126,125,127 +C + 125 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='0' + RETURN +C + 126 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='-' + IVEX=-IVEX +C + 127 NCIE=NCIE+1 + IF (IVEX.GE.10) NCIE=NCIE+1 + IF (IVEX.GE.100) NCIE=NCIE+1 + IF (IVEX.GE.1000) NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 +C + DO 128 I=1,4 + J=NCIE+1-I + BFRE(J:J)=CHAR(ICHAR('0')+MOD(IVEX,10)) + IVEX=IVEX/10 + IF (IVEX.EQ.0) RETURN + 128 CONTINUE +C + IF (IVEX.NE.0) GO TO 902 +C +C Done. +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGNUMB - MANTISSA TOO LONG',4,2) +C + 902 CALL SETER ('AGNUMB - EXPONENT TOO LARGE',5,2) +C + 903 CALL SETER ('AGNUMB - ZERO-LENGTH MANTISSA',6,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agppid.f b/sys/gio/ncarutil/autograph/agppid.f new file mode 100644 index 00000000..145d98d3 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agppid.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPPID (TPID) +C + CHARACTER*(*) TPID +C +C The object of this routine is to print out a parameter identifier +C which has caused some kind of problem. +C +C Define a character variable to hold the print line. +C + CHARACTER*124 TEMP +C +C +NOAO + integer*2 itemp(124) +C -NOAO +C +C Set up the print line. +C + TEMP='0PARAMETER IDENTIFIER - ' +C +C Transfer characters of the parameter identifier, one at a time, until +C 100 have been transferred or a period is encountered, whichever occurs +C first. This is done so as to allow for old programs on the Cray which +C used Hollerith strings as parameter identifiers. +C + I=24 +C + DO 101 J=1,100 + I=I+1 + TEMP(I:I)=TPID(J:J) + IF (TEMP(I:I).EQ.'.') GO TO 102 + 101 CONTINUE +C +C Print the line. +C +C +NOAO - replace FTN write and format statement. +C 102 WRITE (I1MACH(4),1001) TEMP + 102 CONTINUE + call f77upk (temp, itemp, 125) + call pstr (itemp) +C +C Done. +C + RETURN +C +C Format. +C +C1001 FORMAT (A124) +C -NOAO +C + END diff --git a/sys/gio/ncarutil/autograph/agpwrt.f b/sys/gio/ncarutil/autograph/agpwrt.f new file mode 100644 index 00000000..25cc2e52 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agpwrt.f @@ -0,0 +1,31 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPWRT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C + CHARACTER*(*) CHRS +C +C This routine just passes its arguments along to the character-drawing +C routine PWRIT, in the system plot package. By substituting his/her +C own version of AGPWRT, the user can cause a fancier character-drawer +C to be used. +C + CALL PWRIT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agqurv.f b/sys/gio/ncarutil/autograph/agqurv.f new file mode 100644 index 00000000..dc70fc43 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agqurv.f @@ -0,0 +1,322 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGQURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C The curve drawn is windowed. Portions of the curve which would fall +C outside the current curve window, as defined by the last SET call, +C are not drawn. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point and last-point-outside-window flags. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 + LPOW=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C (This greatly simplifies the windowing code.) +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Initialization. Compute mimimum and maximum values of x which are +C slightly outside the linear window. (Note: XLLW and XRLW will not +C be used after this.) +C + IF (XLLW.GT.XRLW) THEN + TEMP=XLLW + XLLW=XRLW + XRLW=TEMP + END IF + XEPS=.000001*(XRLW-XLLW) + XMIN=XLLW-XEPS + XMAX=XRLW+XEPS +C +C Initialization. Compute minimum and maximum values of y which are +C slightly outside the linear window. (Note: YBLW and YTLW will not +C be used after this.) +C + IF (YBLW.GT.YTLW) THEN + TEMP=YBLW + YBLW=YTLW + YTLW=TEMP + END IF + YEPS=.000001*(YTLW-YBLW) + YMIN=YBLW-YEPS + YMAX=YTLW+YEPS +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 120 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + LPOW=0 + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Set the next-point-outside-window flag to a value between -4 and +4, +C inclusive. A non-zero value indicates that the next point is outside +C the window and indicates which of eight possible areas it falls in. +C + NPOW=IFIX(3.*(SIGN(.51,XNXT-XMIN)+SIGN(.51,XNXT-XMAX))+ + + (SIGN(.51,YNXT-YMIN)+SIGN(.51,YNXT-YMAX))) +C +C There are now various possible cases, depending on whether the line- +C drawn-to-last-point flag is set or not, whether the next point is in +C the window or not, and whether the last point was in the window, not +C in the window, or non-existent (point 0 or a special-value point). +C + IF (LDLP.EQ.0) GO TO 102 + IF (NPOW.NE.0) GO TO 103 +C +C Line drawn to last point, next point inside, last point inside. +C + CALL VECTD (XNXT,YNXT) + LDLP=LDLP+1 + GO TO 119 +C + 102 IF (NPOW.NE.0) GO TO 109 + IF (LPOW.NE.0) GO TO 105 +C +C No line drawn to last point, next point inside, no last point. +C + CALL FRSTD (XNXT,YNXT) + LDLP=1 + GO TO 119 +C +C Line drawn to last point, next point outside, last point inside. +C + 103 XPIW=XLST + YPIW=YLST + XPOW=XNXT + YPOW=YNXT + ASSIGN 104 TO JUMP + GO TO 107 + 104 CALL VECTD (XPEW,YPEW) + CALL LASTD + LDLP=0 + GO TO 119 +C +C No line drawn to last point, next point inside, last point outside. +C + 105 XPIW=XNXT + YPIW=YNXT + XPOW=XLST + YPOW=YLST + ASSIGN 106 TO JUMP + GO TO 107 + 106 CALL FRSTD (XPEW,YPEW) + CALL VECTD (XNXT,YNXT) + LDLP=2 + GO TO 119 +C +C The following local procedure, given a point (XPIW,YPIW) inside the +C window and a point (XPOW,YPOW) outside the window, finds the point of +C intersection (XPEW,YPEW) of a line joining them with the window edge. +C + 107 XPEW=XPIW + YPEW=YPIW + XDIF=XPOW-XPIW + YDIF=YPOW-YPIW +C + IF (ABS(XDIF).GT.XEPS) THEN + XPEW=XMIN + IF (XDIF.GE.0.) XPEW=XMAX + YPEW=YPIW+(XPEW-XPIW)*YDIF/XDIF + IF (YPEW.GE.YMIN.AND.YPEW.LE.YMAX) GO TO 108 + END IF +C + IF (ABS(YDIF).GT.YEPS) THEN + YPEW=YMIN + IF (YDIF.GE.0.) YPEW=YMAX + XPEW=XPIW+(YPEW-YPIW)*XDIF/YDIF + END IF +C + 108 GO TO JUMP , (104,106) +C +C No line drawn to last point, next point outside. Jump if no last +C point. +C + 109 IF (LPOW.EQ.0) GO TO 119 +C +C No line drawn to last point, next point outside, last point outside. +C Check whether a portion of the line joining them lies in the window. +C + MPOW=9*LPOW+NPOW+41 +C + GO TO (119,119,119,119,119,110,119,110,110, + + 119,119,119,111,119,110,111,110,110, + + 119,119,119,111,119,119,111,111,119, + + 119,113,113,119,119,110,119,110,110, + + 119,119,119,119,119,119,119,119,119, + + 112,112,119,112,119,119,111,111,119, + + 119,113,113,119,119,113,119,119,119, + + 112,112,113,112,119,113,119,119,119, + + 112,112,119,112,119,119,119,119,119) , MPOW +C + 110 XPE1=XMIN + YPT1=YMIN + XPE2=XMAX + YPT2=YMAX + GO TO 114 +C + 111 XPE1=XMIN + YPT1=YMAX + XPE2=XMAX + YPT2=YMIN + GO TO 114 +C + 112 XPE1=XMAX + YPT1=YMAX + XPE2=XMIN + YPT2=YMIN + GO TO 114 +C + 113 XPE1=XMAX + YPT1=YMIN + XPE2=XMIN + YPT2=YMAX +C + 114 XDIF=XNXT-XLST + YDIF=YNXT-YLST +C + IF (ABS(XDIF).LE.XEPS) GO TO 116 + YPE1=YLST+(XPE1-XLST)*YDIF/XDIF + YPE2=YLST+(XPE2-XLST)*YDIF/XDIF +C + IF (ABS(YDIF).LE.YEPS) GO TO 118 + IF (YPE1.GE.YMIN.AND.YPE1.LE.YMAX) GO TO 115 + YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 115 IF (YPE2.GE.YMIN.AND.YPE2.LE.YMAX) GO TO 118 + GO TO 117 +C + 116 YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 117 YPE2=YPT2 + XPE2=XLST+(YPE2-YLST)*XDIF/YDIF + IF (XPE2.LT.XMIN.OR.XPE2.GT.XMAX) GO TO 119 +C + 118 CALL FRSTD (XPE1,YPE1) + CALL VECTD (XPE2,YPE2) + CALL LASTD +C +C Processing of next point is done. It becomes the last point and we +C go back for a new next point. +C + 119 LPOW=NPOW + XLST=XNXT + YLST=YNXT + GO TO 101 +C +C Last point was final point. Finish up. +C + 120 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGQURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',7,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agrpch.f b/sys/gio/ncarutil/autograph/agrpch.f new file mode 100644 index 00000000..c37a7ae4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrpch.f @@ -0,0 +1,86 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGRPCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine is used to replace a character string previously stored +C by the routine AGSTCH (which see). This could be done by an AGDLCH +C followed by an AGSTCH, and, in fact, under certain conditions, does +C exactly that. Only when it is easy to do so does AGRPCH operate more +C efficiently. Nevertheless, a user who (for example) repeatedly and +C perhaps redundantly defines x-axis labels of the same length may +C greatly benefit thereby; repeated deletes and stores would lead to +C frequent garbage collection by AGSTCH. +C +C AGRPCH has the following arguments: +C +C -- CHST is the new character string, to replace what was originally +C stored. +C +C -- LNCS is the length of the character string in CHST. +C +C -- IDCS is the identifier returned by AGSTCH when the original string +C was stored. The value of IDCS may be changed by the call. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the identifier is positive or is negative but less than -LNIC, the +C original string was never stored in CHRA; just treat the replacement +C as a store and return a new value of IDCS. +C + IF (IDCS.GT.(-1).OR.IDCS.LT.(-LNIC)) THEN + CALL AGSTCH (CHST,LNCS,IDCS) +C + ELSE +C +C The absolute value of the identifier is the index, in INCH, of the +C descriptor of the character string stored in CHRA. If the new string +C is shorter than the old one, store it and zero remaining character +C positions. Otherwise, treat the replacement as a delete followed by +C a store. +C + I=-IDCS + IF (LNCS.LE.INCH(2,I)) THEN + J=INCH(1,I)-1 + DO 101 K=1,LNCS + J=J+1 + CHRA(J)=CHST(K:K) + 101 CONTINUE + DO 102 K=LNCS+1,INCH(2,I) + J=J+1 + CHRA(J)=CHAR(0) + 102 CONTINUE + INCH(2,I)=LNCS + ELSE + CALL AGDLCH (IDCS) + CALL AGSTCH (CHST,LNCS,IDCS) + END IF +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agrstr.f b/sys/gio/ncarutil/autograph/agrstr.f new file mode 100644 index 00000000..72afc643 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrstr.f @@ -0,0 +1,88 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - this subroutine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGRSTR (IFNO) +C +C This subroutine is called to restore the current state of AUTOGRAPH by +C reading all of its important variables from a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Read the record. +C +C READ (IFNO,ERR=901,END=902) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exits. +C +C 901 CALL SETER ('AGRSTR - ERROR ON READ',8,2) +C +C 902 CALL SETER ('AGRSTR - END-OF-FILE ON READ',9,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsave.f b/sys/gio/ncarutil/autograph/agsave.f new file mode 100644 index 00000000..ef0feb7d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsave.f @@ -0,0 +1,93 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - This routine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGSAVE (IFNO) +C +C This subroutine is called to save the current state of AUTOGRAPH by +C writing all of its important variables as a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Write the record. Variables from each COMMON block are together, in +C alphabetical order. +C +C WRITE (IFNO,ERR=901) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exit. +C +C 901 CALL SETER ('AGSAVE - ERROR ON WRITE',10,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agscan.f b/sys/gio/ncarutil/autograph/agscan.f new file mode 100644 index 00000000..222db6c4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agscan.f @@ -0,0 +1,628 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSCAN (TPID,LOPA,NIPA,IIPA) +C + CHARACTER*(*) TPID +C +C The routine AGSCAN is used by AGGETP and AGSETP to scan a parameter +C identifier and return a description of the parameter-list items which +C are specified by that parameter identifier. It has the following +C arguments: +C +C -- TPID is the parameter identifier. +C +C -- LOPA is the index of the first parameter-list item specified. +C +C -- NIPA is the number of parameter-list items specified. +C +C -- IIPA is the index increment between one of the parameter-list items +C specified and the next (meaningless if NIPA=1). +C +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C Originally, this routine used the function "LOC" to return, in LOPA, +C the base address, in core, of the specified parameter group. To some +C degree, it was thereby insulated from changes in the labelled common +C block AGCONP. With the demise of "LOC", LOPA has been re-defined and +C that insulation no longer exists. In the following code, there are +C integers which represent the indices of desired quantities in common. +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine EXTERNAL to force loading of it. +C +C +NOAO - call agdflt as run time initialization +C +C EXTERNAL AGDFLT + call agdflt +C -NOAO +C +C Initialize the parameter-identifier character index. +C + IPID=0 +C +C Initialize the value of the index increment to be returned. +C + IIPA=1 +C +C Find the first keyword in the parameter identifier. +C + CALL AGSRCH (TPID,IPID,IKWL,'PRIMFRAMSET ROW INVEWINDNULLGRAPGRIDX + + Y AXISLEFTRIGHBOTTTOP DASHLABELINESECOBACK') +C + GO TO (101,102,103,104,105,106,107,108,109,110, + + 111,113,114,114,114,114,132,133,147,155,166,901) , IKWL +C +C PRIMARY CONTROL PARAMETERS. +C + 101 LOPA=1 + NIPA=336 + GO TO 203 +C +C FRAME PARAMETER. +C + 102 LOPA=1 + GO TO 202 +C +C SET PARAMETER. +C + 103 LOPA=2 + GO TO 202 +C +C ROW PARAMETER. +C + 104 LOPA=3 + GO TO 202 +C +C X/Y INVERSION PARAMETER. +C + 105 LOPA=4 + GO TO 202 +C +C WINDOWING PARAMETER. +C + 106 LOPA=5 + GO TO 202 +C +C BACKGROUND PARAMETER. +C + 166 LOPA=6 + GO TO 202 +C +C NULL PARAMETER(S). +C + 107 LOPA=7 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1 2 ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C PLOT (GRAPH) WINDOW PARAMETERS. +C + 108 LOPA=9 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + GO TO 201 +C +C GRID WINDOW PARAMETERS. +C + 109 LOPA=13 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP SHAP') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C +C X DATA PARAMETERS. +C + 110 LOPA=18 + GO TO 112 +C +C Y DATA PARAMETERS. +C + 111 LOPA=25 +C +C X OR Y DATA PARAMETERS. +C + 112 NIPA=7 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MINIMAXILOGAORDENICESMALLARG') +C + IF (IKWL.EQ.8) GO TO 901 + GO TO 201 +C +C AXIS PARAMETERS. +C + 113 LOPA=32 + NIPA=92 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + IKWL=IKWL+12 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 114 LOPA=19+IKWL + NIPA=23 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTLINEINTEFUNCTICKMAJOMINONUMETYPEEXPOFRACANGLOFFSWIDT') +C + GO TO (202,201,115,167,116,117,123,126,127,127,127, + + 127,127,127,901) , IKWL +C +C AXIS INTERSECTION PARAMETERS. +C + 115 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'GRIDUSER') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS MAPPING FUNCTION. +C + 167 LOPA=LOPA+16 + GO TO 202 +C +C AXIS TICK PARAMETERS. +C + 116 LOPA=LOPA+20 + NIPA=10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MAJOMINO') +C + LOPA=LOPA-20 + GO TO (117,123,901) , IKWL +C +C AXIS MAJOR-TICK PARAMETERS. +C + 117 LOPA=LOPA+20 + NIPA=6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACTYPEBASECOUNPATTLENGOUTWINWA') +C + GO TO (118,119,119,119,120,121,122,122,901) , IKWL +C +C AXIS MAJOR-TICK SPACING PARAMETERS. +C + 118 NIPA=3 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEBASECOUN') +C + IF (IKWL.EQ.4) GO TO 901 +C + GO TO 201 +C + 119 IKWL=IKWL-1 + GO TO 201 +C +C AXIS MAJOR-TICK DASH PATTERN. +C + 120 LOPA=LOPA+12 + GO TO 202 +C +C AXIS MAJOR-TICK LENGTH PARAMETERS. +C + 121 LOPA=LOPA+16 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 122 LOPA=LOPA+16 + IKWL=IKWL-6 + GO TO 201 +C +C AXIS MINOR-TICK PARAMETERS. +C + 123 LOPA=LOPA+44 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACPATTLENGOUTWINWA') +C + GO TO (202,201,124,125,125,901) , IKWL +C +C AXIS MINOR-TICK LENGTH PARAMETERS. +C + 124 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 125 LOPA=LOPA+8 + IKWL=IKWL-3 + GO TO 201 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 126 LOPA=LOPA+60 + NIPA=8 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEEXPOFRACANGLOFFSWIDT') +C + GO TO 128 +C + 127 LOPA=LOPA+60 + IKWL=IKWL-8 +C + 128 GO TO (202,201,201,129,130,131,901) ,IKWL +C +C AXIS NUMERIC-LABEL ORIENTATION ANGLE. +C + 129 LOPA=LOPA+12 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1ST 2ND ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS NUMERIC-LABEL OFFSET. +C + 130 LOPA=LOPA+20 + GO TO 202 +C +C AXIS NUMERIC-LABEL WIDTH PARAMETERS. +C + 131 LOPA=LOPA+24 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MANTEXPO') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C DASH-PATTERN PARAMETERS. +C + 132 LOPA=124 + NIPA=30 + IF (TPID(IPID:IPID).EQ.'.') RETURN + JPID=IPID + CALL AGSRCH (TPID,IPID,IKWL,'SELELENGCHARDOLLPATT') + IF (IKWL.EQ.6) THEN + IPID=JPID + GO TO 168 + END IF + IF (IKWL.NE.5) GO TO 201 + 168 LOPA=LOPA+4 + NIPA=26 + IF (TPID(IPID:IPID).EQ.'.') RETURN + CALL AGSRCH (TPID,IPID,IKWL, + +'1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 1 + +7 18 19 20 21 22 23 24 25 26 ') + IF (IKWL.EQ.27) GO TO 901 + GO TO 201 +C +C LABEL PARAMETERS. +C + 133 LBIM=IFIX(QBIM) + LBAN=IFIX(QBAN) +C + LOPA=154 + NIPA=3+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTBUFFNAMEDEFISUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO (202,136,139,140,141,141,141,141,141,141,141,901) , IKWL +C +C LABEL BUFFER PARAMETERS. +C + 136 LOPA=155 + NIPA=1+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONTNAME') +C + GO TO (202,137,138,901) , IKWL +C +C LABEL BUFFER CONTENTS. +C + 137 LOPA=156 + NIPA=LBIM*10 + GO TO 203 +C +C LABEL BUFFER NAMES. +C + 138 LOPA=156 + NIPA=LBIM + IIPA=10 + GO TO 203 +C +C LABEL NAME. +C + 139 LOPA=236 + GO TO 202 +C +C LABEL DEFINITION. +C + 140 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + NIPA=9 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO 142 +C + 141 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + IKWL=IKWL-4 +C + 142 GO TO (202,143,144,146,146,146,146,901) , IKWL +C +C LABEL POSITION. +C + 143 LOPA=LOPA+1 + GO TO 145 +C +C LABEL OFFSET. +C + 144 LOPA=LOPA+3 +C +C LABEL POSITION OR OFFSET. +C + 145 NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'X Y ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C OTHER LABEL ATTRIBUTES. +C + 146 LOPA=LOPA+5 + IKWL=IKWL-3 + GO TO 201 +C +C LINE PARAMETERS. +C + 147 LNIM=IFIX(QNIM) + LNAN=IFIX(QNAN) +C + LOPA=237 + NIPA=4+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'MAXIEND BUFFNUMBDEFISUPPCHARTEXTLENGINDE') +C + GO TO (202,201,150,152,153,154,154,154,154,154,901) , IKWL +C +C LINE BUFFER PARAMETERS. +C + 150 LOPA=239 + NIPA=1+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONT') +C + GO TO (202,151,901) , IKWL +C +C LINE BUFFER CONTENTS. +C + 151 LOPA=240 + NIPA=LNIM*6 + GO TO 203 +C +C LINE NUMBER. +C + 152 LOPA=336 + GO TO 202 +C +C LINE DEFINITION. +C + 153 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 +C + LOPA=241+(LNAN-1)*6 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPCHARTEXTLENGINDE') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C + 154 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 + LOPA=241+(LNAN-1)*6 + IKWL=IKWL-5 + GO TO 201 +C +C SECONDARY CONTROL PARAMETERS. +C + 155 LOPA=337 + NIPA=149 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'GRAPUSERCURVDIMEAXISLEFTRIGHBOTTTOP LABE') +C + GO TO (156,157,158,159,160,161,161,161,161,165,901) , IKWL +C +C PLOT (GRAPH) WINDOW EDGES. +C + 156 LOPA=337 + NIPA=4 + GO TO 203 +C +C USER WINDOW PARAMETERS. +C + 157 LOPA=341 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW PARAMETERS. +C + 158 LOPA=345 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW DIMENSIONS. +C + 159 LOPA=349 + NIPA=3 + GO TO 203 +C +C AXIS PARAMETERS. +C + 160 LOPA=352 + NIPA=80 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 +C + IKWL=IKWL+5 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 161 LOPA=346+IKWL + NIPA=20 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'POSITICKNUME') +C + GO TO (162,163,164,901) , IKWL +C +C AXIS POSITIONING PARAMETERS. +C + 162 NIPA=6 + GO TO 203 +C +C AXIS TICK PARAMETERS. +C + 163 LOPA=LOPA+24 + NIPA=3 + GO TO 203 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 164 LOPA=LOPA+36 + NIPA=11 + GO TO 203 +C +C LABEL BOXES. +C + 165 LOPA=432 + NIPA=54 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP CENTGRAP') +C + IF (IKWL.EQ.7) GO TO 901 +C + LOPA=LOPA+IKWL-1 + NIPA=9 + IIPA=6 + GO TO 203 +C +C Normal exits. +C + 201 LOPA=LOPA+(IKWL-1)*IIPA +C + 202 NIPA=1 +C + 203 IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGPPID (TPID) +C +NOAO - following FTN write and fmt statements commented out, SETER is okay. +C +C WRITE (I1MACH(4),1001) + RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ILLEGAL KEYWORD USED IN PARAMETER + +IDENTIFIER',11,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LABEL ATTRIBUTES + + BEFORE SETTING LABEL NAME',12,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LINE ATTRIBUTES + +BEFORE SETTING LINE NUMBER',13,2) +C +C Formats. +C +C1001 FORMAT (' WARNING - ABOVE PARAMETER IDENTIFIER HAS TOO MANY KEYWOR +C +DS') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsetc.f b/sys/gio/ncarutil/autograph/agsetc.f new file mode 100644 index 00000000..bced8458 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetc.f @@ -0,0 +1,100 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGSETC is used to set the values of individual AUTOGRAPH +C parameters which intrinsically represent character strings. TPID is a +C parameter identifier. CUSR is a character string. The situation is +C complicated by the fact that the character string may be either a dash +C pattern, the name of a label, the line-end character, or the text of a +C line, all of which are treated differently. +C +C Define a local variable to hold the "line-end" character. +C + CHARACTER*1 LEND +C +C See what kind of parameter is being set. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Find the length of the string, which may or may not actually be used. +C (On the Cray, at least, it may be zero if the wrong type of argument +C was used.) +C + ILEN=LEN(CUSR) +C +C Retrieve the current (integer) value of the parameter. +C + CALL AGGETI (TPID,ITMP) +C +C Check for a dash pattern. +C + IF (ITCS.EQ.1) THEN + CALL AGGETI ('DASH/LENG.',NCHR) + IF (ILEN.GT.0.AND.ILEN.LT.NCHR) NCHR=ILEN + CALL AGRPCH (CUSR,NCHR,ITMP) +C +C Check for a label name. +C + ELSE IF (ITCS.EQ.2) THEN + CALL AGRPCH (CUSR,MAX0(1,ILEN),ITMP) +C +C Check for the line-end character. +C + ELSE IF (ITCS.EQ.3) THEN + CALL AGRPCH (CUSR,1,ITMP) +C +C Check for the text of a label. +C + ELSE IF (ITCS.EQ.4) THEN + CALL AGGETI ('LINE/MAXI.',NCHR) + IF (ILEN.GT.0) NCHR=MIN0(NCHR,ILEN) + CALL AGGETC ('LINE/END .',LEND) + DO 101 I=1,NCHR + IF (CUSR(I:I).EQ.LEND) THEN + NCHR=I-1 + GO TO 102 + END IF + 101 CONTINUE +C + 102 CALL AGRPCH (CUSR,NCHR,ITMP) +C + END IF +C +C Transfer the generated value to the list of AUTOGRAPH parameters. +C + FURA(1)=FLOAT(ITMP) + CALL AGSETP (TPID,FURA,1) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETC - PARAMETER TO SET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',14,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsetf.f b/sys/gio/ncarutil/autograph/agsetf.f new file mode 100644 index 00000000..36fca46e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETF may be used to set the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + FURA(1)=FUSR + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agseti.f b/sys/gio/ncarutil/autograph/agseti.f new file mode 100644 index 00000000..06e3b3f1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agseti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETI may be used to set the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + FURA(1)=FLOAT(IUSR) + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agsetp.f b/sys/gio/ncarutil/autograph/agsetp.f new file mode 100644 index 00000000..95e98a6d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetp.f @@ -0,0 +1,447 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(LURA) +C +C The routine AGSETP stores user-provided values of the AUTOGRAPH +C parameters specified by the parameter identifier TPID. The arguments +C are as follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array from which parameter values are to be taken. +C +C -- LURA is the length of the user array. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C Define the array DUMI, which allows access to the control-parameter +C list as an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C +NOAO - Make sure common has been initialized. +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters affected. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of values to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C If character-string dash patterns are being replaced by integer dash +C patterns, reclaim the space used in the character-storage arrays. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.LE.LODP+NIDP-1.AND.LOPA+NURA-1.GE.LODP) THEN + MINI=MAX0(LOPA,LODP)-LOPA+1 + MAXI=MIN0(LOPA+NURA-1,LODP+NIDP-1)-LOPA+1 + DO 100 I=MINI,MAXI + IF (FURA(I).GT.0.) CALL AGDLCH (IFIX(DUMI(LOPA+I-1))) + 100 CONTINUE + END IF +C +C Save the current values of special values 1 and 2. +C + SVL1=SVAL(1) + SVL2=SVAL(2) +C +C Transfer the user-provided values to the parameter list. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + DUMI(IDMI)=FURA(IURA) + 101 CONTINUE +C +C If a specific item was changed, we may have a bit more work to do; +C otherwise, return to the user. +C + IF (NIPA.NE.1) RETURN +C +C If the specific item was special value 1 or 2, scan the primary list +C of parameters for other occurrences of the special value and change +C them to the new value. +C + IF (SVAL(1).NE.SVL1) THEN + SVLO=SVL1 + SVLN=SVAL(1) + GO TO 102 + END IF +C + IF (SVAL(2).NE.SVL2) THEN + SVLO=SVL2 + SVLN=SVAL(2) + GO TO 102 + END IF +C + GO TO 104 +C + 102 CALL AGSCAN ('PRIM.',LOPR,NIPR,IIPR) +C + IDMI=LOPR-IIPR +C + DO 103 I=1,NIPR + IDMI=IDMI+IIPR + IF (DUMI(IDMI).EQ.SVLO) DUMI(IDMI)=SVLN + 103 CONTINUE +C + RETURN +C +C If the specific item was the label control flag and it was set +C negative, delete all labels and lines. +C + 104 CALL AGSCAN ('LABE/CONT.',LOLC,NILC,IILC) + IF (LOPA.NE.LOLC) GO TO 107 + IF (QDLB.GE.0.) RETURN +C + QBAN=0. + QNAN=0. +C + LBIM=IFIX(QBIM) +C + DO 105 I=1,LBIM + IF (FLLB(1,I).NE.0.) THEN + CALL AGDLCH (IFIX(FLLB(1,I))) + FLLB(1,I)=0. + END IF + 105 CONTINUE +C + LNIM=IFIX(QNIM) +C + DO 106 I=1,LNIM + IF (FLLN(1,I).NE.SVAL(1)) THEN + CALL AGDLCH (IFIX(FLLN(4,I))) + FLLN(1,I)=SVAL(1) + END IF + 106 CONTINUE +C + RETURN +C +C If the specific item was the label name, reset it to an appropriate +C index in the label list, providing initial values if appropriate. +C + 107 CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 109 +C + LBAN=0 + LBIM=IFIX(QBIM) + QNAN=0. +C + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) +C + DO 108 I=1,LBIM + IF (LBAN.EQ.0.AND.FLLB(1,I).EQ.0.) LBAN=I + CALL AGGTCH (IFIX(FLLB(1,I)),CHS2,LCS2) + IF (LCS1.NE.LCS2) GO TO 108 + IF (CHS1(1:LCS1).NE.CHS2(1:LCS2)) GO TO 108 + QBAN=FLOAT(I) + RETURN + 108 CONTINUE +C + IF (LBAN.EQ.0) GO TO 901 +C + QBAN=FLOAT(LBAN) +C + FLLB( 1,LBAN)=FURA(1) + FLLB( 2,LBAN)=0. + FLLB( 3,LBAN)=.5 + FLLB( 4,LBAN)=.5 + FLLB( 5,LBAN)=0. + FLLB( 6,LBAN)=0. + FLLB( 7,LBAN)=0. + FLLB( 8,LBAN)=0. + FLLB( 9,LBAN)=0. + FLLB(10,LBAN)=0. +C + RETURN +C +C If the label access name is not set, skip. +C + 109 IF (QBAN.LE.0.) GO TO 122 +C + LBAN=IFIX(QBAN) + LBIM=IFIX(QBIM) + LNAN=IFIX(QNAN) + LNIM=IFIX(QNIM) +C +C If the specific item was the suppression flag for the current label +C and it was set negative, delete the label and/or its lines. +C + CALL AGSCAN ('LABE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 111 + IF (FLLB(2,LBAN).GE.0.) RETURN +C + ITMP=IFIX(FLLB(2,LBAN)) + FLLB(2,LBAN)=0. + FLLB(9,LBAN)=0. + LNIN=IFIX(FLLB(10,LBAN)) + FLLB(10,LBAN)=0. + QNAN=0. + IF (ITMP.EQ.(-1)) GO TO 110 + CALL AGDLCH (IFIX(FLLB(1,LBAN))) + FLLB(1,LBAN)=0. + QBAN=0. +C + 110 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + FLLN(1,LNIN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNIN))) + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 110 +C +C If the specific item was the line number, reset it to an appropriate +C index in the line list, providing initial values if appropriate. +C + 111 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 118 +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 112 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) GO TO 115 + IF (LNAN-IFIX(FLLN(1,LNIN))) 113,114,115 +C + 113 LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 112 +C + 114 QNAN=FLOAT(LNIN) + RETURN +C + 115 DO 116 I=1,LNIM + LNIT=I + IF (FLLN(1,I).EQ.SVAL(1)) GO TO 117 + 116 CONTINUE +C + GO TO 903 +C + 117 CALL AGSTCH (' ',1,ITMP) +C + FLLN(1,LNIT)=FLOAT(LNAN) + FLLN(2,LNIT)=0. + FLLN(3,LNIT)=.015 + FLLN(4,LNIT)=ITMP + FLLN(5,LNIT)=1. + FLLN(6,LNIT)=FLOAT(LNIN) +C + LNAN=LNIT + IF (LNIL.EQ.0) FLLB(10,LBAN)=FLOAT(LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLOAT(LNAN) +C + FLLB(9,LBAN)=FLLB(9,LBAN)+1. +C + QNAN=FLOAT(LNAN) + RETURN +C +C If the line access number is not set, skip. +C + 118 IF (LNAN.LE.0) GO TO 122 +C +C If the specific item was the suppression flag for the current line and +C it was set negative, delete the line. +C + CALL AGSCAN ('LINE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 121 + IF (FLLN(2,LNAN).GE.0.) RETURN +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 119 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + IF (LNAN.EQ.LNIN) GO TO 120 + LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 119 +C + 120 IF (LNIL.EQ.0) FLLB(10,LBAN)=FLLN(6,LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLLN(6,LNAN) + FLLN(1,LNAN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNAN))) + QNAN=0. + RETURN +C +C If the specific item was the text of a line, set the length of the +C line, as well. +C + 121 CALL AGSCAN ('LINE/TEXT.',LOLT,NILT,IILT) + IF (LOPA.NE.LOLT) GO TO 123 + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) + FLLN(5,LNAN)=FLOAT(LCS1) + RETURN +C +C See if the user is trying to get at a line of a non-existent label. +C + 122 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) GO TO 902 +C +C If the specific item was the background parameter, set up the back- +C ground requested by the user. +C + 123 CALL AGSCAN ('BACK.',LOBG,NIBG,IIBG) + IF (LOPA.NE.LOBG) GO TO 130 +C + QBAC=AMAX1(1.,AMIN1(4.,QBAC)) + IBAC=IFIX(QBAC) + GO TO (124,125,126,127) , IBAC +C +C Perimeter background. +C + 124 QLBC=4. + QRTC=4. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C Grid background. +C + 125 QLBC=4. + QRTC=-1. + WMJI=1. + WMNI=1. + GO TO 128 +C +C Half-axis background. +C + 126 QLBC=4. + QRTC=0. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C No background. +C + 127 QLBC=0. + QRTC=0. + WMJI=.015 + WMNI=.010 +C + 128 QDAX(1)=QLBC + QDAX(2)=QRTC + QDAX(3)=QLBC + QDAX(4)=QRTC +C + DO 129 I=1,4 + WMJR(I)=WMJI + WMNR(I)=WMNI + 129 CONTINUE +C + QDLB=FLOAT(2-2*(IBAC/4)) + RETURN +C +C If the specific item was the get-limits-from-last-SET-call parameter, +C do what is necessary. +C + 130 CALL AGSCAN ('SET .',LOSE,NISE,IISE) + IF (LOPA.NE.LOSE) GO TO 131 +C + QSET=SIGN(AMAX1(1.,AMIN1(4.,ABS(QSET))),QSET) +C + XLGD=.15 + XRGD=.95 + YBGD=.15 + YTGD=.95 + SOGD=0. +C + XMIN=SVAL(1) + XMAX=SVAL(1) + QLUX=AMIN1(QLUX,0.) + QOVX=0. + QCEX=-1. + XLOW=SVAL(1) + XHGH=SVAL(1) +C + YMIN=SVAL(1) + YMAX=SVAL(1) + QLUY=AMIN1(QLUY,0.) + QOVY=0. + QCEY=-1. + YLOW=SVAL(1) + YHGH=SVAL(1) +C + RETURN +C +C Return to caller. +C + 131 RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LABEL LIST OVERFLOW - SEE AUTOGRAPH SPECIALI + +ST',15,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGSETP - ATTEMPT TO DEFINE LINE OF NON-EXISTENT LABEL + +',16,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LINE LIST OVERFLOW - SEE AUTOGRAPH SPECIALIS + +T',17,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsrch.f b/sys/gio/ncarutil/autograph/agsrch.f new file mode 100644 index 00000000..366c46cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsrch.f @@ -0,0 +1,96 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSRCH (TPID,IPID,IKWL,TKWL) +C + CHARACTER*(*) TPID,TKWL +C +C The routine AGSRCH is used by AGSCAN to search a parameter identifier +C for the next keyword and return the index of that keyword in a list of +C keywords. It has the following arguments. +C +C -- TPID is the parameter identifier, a character string. +C +C -- IPID is the index of the last character examined in TPID. It is +C updated by AGSRCH to point to the first slash or period following +C the next keyword. +C +C -- IKWL is returned containing the index (in the keyword list) of the +C next keyword in the parameter identifier (list length, plus one, +C if the keyword is not found in the list). +C +C -- TKWL is the keyword list - 4*LKWL characters in all. +C +C ICHR is used to hold up to four characters of a keyword. +C + CHARACTER*4 ICHR +C +C LPID is the assumed maximum length of a parameter identifier. +C + DATA LPID / 100 / +C +C Compute the number of 4-character keywords in the keyword list. +C + LKWL=LEN(TKWL)/4 +C +C Find the next non-blank in the parameter identifier. +C + 101 IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + IF (TPID(IPID:IPID).EQ.' ') GO TO 101 +C +C Pick up at most four characters of the keyword, stopping on the first +C blank, slash, or period encountered. +C + NCHR=0 +C + 102 IF (TPID(IPID:IPID).EQ.' '.OR. + + TPID(IPID:IPID).EQ.'/'.OR. + + TPID(IPID:IPID).EQ.'.') GO TO 103 +C + NCHR=NCHR+1 + ICHR(NCHR:NCHR)=TPID(IPID:IPID) +C + IPID=IPID+1 +C + IF (NCHR.LT.4) GO TO 102 +C +C If the keyword found has zero length, error. +C + 103 IF (NCHR.EQ.0) GO TO 107 +C +C Scan ahead for the next slash or period. +C + 104 IF (TPID(IPID:IPID).EQ.'/'.OR.TPID(IPID:IPID).EQ.'.') GO TO 105 +C + IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + GO TO 104 +C +C Search the keyword list for the keyword found. +C + 105 DO 106 I=1,LKWL + IKWL=I + ISTR=(I-1)*4+1 + IEND=(I-1)*4+NCHR + IF (ICHR(1:NCHR).EQ.TKWL(ISTR:IEND)) RETURN + 106 CONTINUE +C +C Keyword not found - set IKWL to impossible value and return. +C + 107 IKWL=LKWL+1 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agstch.f b/sys/gio/ncarutil/autograph/agstch.f new file mode 100644 index 00000000..2b2906bd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstch.f @@ -0,0 +1,124 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine stores strings of characters for later retrieval and/or +C modification by the routines AGGTCH, AGRPCH, and AGDLCH. It has the +C following arguments: +C +C -- CHST is the character string to be stored. +C +C -- LNCS is the length of the character string in CHST. LNCS must be +C less than or equal to the value of the FORTRAN function LEN(CHST). +C +C -- IDCS is an identifying integer, returned to the caller by AGSTCH +C for later use in calls to AGGTCH, AGRPCH, and AGDLCH. If CHST is +C more than one character long, it is stashed in the array CHRA, and +C the value returned in IDCS is a negative number between -LNIC and +C -1, inclusive, the absolute value of which is the index of an entry +C in the array INCH describing where in the array CHRA the string was +C stored. If CHST is only one character long, IDCS is returned as +C the value of the FORTRAN expression -(LNIC+1+ICHAR(CHST(1:1))). +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the string is short enough, just embed it in a negative integer +C and return that value to the caller as the identifier of the string. +C + IF (LNCS.LE.1) THEN + IDCS=-(LNIC+1+ICHAR(CHST(1:1))) + RETURN + END IF +C +C Otherwise, the string must be stashed in CHRA and the negative of the +C index, in INCH, of its descriptor returned to the caller. Loop, on I, +C through the index of character strings. +C + DO 104 I=1,LNIC +C +C If the next entry in the index is zeroed, use it for the new string. +C + IF (INCH(1,I).EQ.0) THEN +C +C Zeroed entry found. Return the negative of its index to the user. +C + IDCS=-I +C +C If there isn't enough room for the character string at the end of the +C character-storage array, do some garbage-collecting, eliminating all +C strings of all-zero characters. +C + IF (LNCS.GT.LNCA-INCA) THEN + J=0 + K=0 + DO 102 L=1,INCA + IF (CHRA(L).EQ.CHAR(0)) THEN + IF (J.EQ.0) J=L + ELSE + IF (J.NE.0) THEN + DO 101 M=1,LNIC + IF (INCH(1,M).GT.K) INCH(1,M)=INCH(1,M)+J-L + 101 CONTINUE + J=0 + END IF + K=K+1 + CHRA(K)=CHRA(L) + END IF + 102 CONTINUE + INCA=K + END IF +C +C If there still isn't enough room for the character string at the end +C of the character-storage array, take an error exit. Otherwise, stash +C it and return. All-zero characters are changed to blanks. +C + IF (LNCS.GT.LNCA-INCA) GO TO 901 + INCH(1,I)=INCA+1 + INCH(2,I)=LNCS + DO 103 J=1,LNCS + INCA=INCA+1 + CHRA(INCA)=CHST(J:J) + IF (ICHAR(CHRA(INCA)).EQ.0) CHRA(INCA)=' ' + 103 CONTINUE + RETURN +C + END IF +C + 104 CONTINUE +C +C If no zeroed entry was found in the index of character strings, jump +C to log an error and quit. +C + GO TO 902 +C +C Error exits. +C + 901 CALL SETER ('AGSTCH - CHARACTER-STRING BUFFER OVERFLOW - SEE CONSU + +LTANT',18,2) +C + 902 CALL SETER ('AGSTCH - CHARACTER-STRING INDEX OVERFLOW - SEE CONSUL + +TANT',19,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agstup.f b/sys/gio/ncarutil/autograph/agstup.f new file mode 100644 index 00000000..41a97674 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstup.f @@ -0,0 +1,543 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX, + + YDRA,NVIY,IIVY,NEVY,IIEY) +C + DIMENSION XDRA(1),YDRA(1) +C +C The routine AGSTUP is called to examine the parameter list, to provide +C default values for missing parameters, and to check for and cope with +C label overlap problems. +C +C The arguments describe the x and y data arrays to be used for the next +C graph. See the routine AGEXUS for a description of them. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C EXTERNAL AGDFLT +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','AGSTUP','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO - Block data replaced with run time initialization +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Compute the width and height of the plotter frame. +C + CALL GETSI (IWFP,IHFP) + WOFP=2.**IWFP-1. + HOFP=2.**IHFP-1. +C +C Examine the get-limits-from-last-set-call parameter. +C + IF (ABS(QSET).EQ.1.) GO TO 141 +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XMNT,XMXT,YMNT,YMXT,LILO) +C + QLUX=FLOAT((1-LILO)/2) + QLUY=FLOAT(MOD(1-LILO,2)) +C + IF (ABS(QSET).EQ.3.) GO TO 140 +C + XLGD=(XLCW-XLGF)/(XRGF-XLGF) + XRGD=(XRCW-XLGF)/(XRGF-XLGF) + YBGD=(YBCW-YBGF)/(YTGF-YBGF) + YTGD=(YTCW-YBGF)/(YTGF-YBGF) + SOGD=0. +C + IF (ABS(QSET).EQ.2.) GO TO 141 +C + 140 XMIN=AMIN1(XMNT,XMXT) + XMAX=AMAX1(XMNT,XMXT) + QOVX=0. + IF (XMNT.GT.XMXT) QOVX=1. + QCEX=0. +C + YMIN=AMIN1(YMNT,YMXT) + YMAX=AMAX1(YMNT,YMXT) + QOVY=0. + IF (YMNT.GT.YMXT) QOVY=1. + QCEY=0. +C + 141 CONTINUE +C +C Examine the graph-window parameters. +C + XLGF=AMAX1(0.,AMIN1(1.,XLGF)) + XRGF=AMAX1(0.,AMIN1(1.,XRGF)) + YBGF=AMAX1(0.,AMIN1(1.,YBGF)) + YTGF=AMAX1(0.,AMIN1(1.,YTGF)) +C + IF (XLGF.GE.XRGF.OR.YBGF.GE.YTGF) GO TO 901 +C +C Examine the grid-window parameters. +C + XLGD=AMAX1(0.,AMIN1(1.,XLGD)) + XRGD=AMAX1(0.,AMIN1(1.,XRGD)) + YBGD=AMAX1(0.,AMIN1(1.,YBGD)) + YTGD=AMAX1(0.,AMIN1(1.,YTGD)) +C + IF (XLGD.GE.XRGD.OR.YBGD.GE.YTGD) GO TO 902 +C +C Examine the user-window minima and maxima for special values. Compute +C tentative values of the user-window edge parameters. +C + QIXY=AMAX1(0.,AMIN1(1.,QIXY)) +C + IF (QIXY.NE.0.) GO TO 142 +C + CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,YBUW,YTUW) + GO TO 143 +C + 142 CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,YBUW,YTUW) +C + 143 CONTINUE +C +C Examine the user-window nice-value-at-ends parameters. INAX and INAY +C specify which axis has the nice values (if any). +C + QCEX=AMAX1(-1.,AMIN1(+1.,QCEX)) + INAX=IFIX(QCEX) + IF (INAX.NE.0) INAX=(INAX+7)/2 +C + QCEY=AMAX1(-1.,AMIN1(+1.,QCEY)) + INAY=IFIX(QCEY) + IF (INAY.NE.0) INAY=(INAY+3)/2 +C +C Examine the user-window linear-log flags. +C + QLUX=AMAX1(-1.,AMIN1(1.,QLUX)) + QLUY=AMAX1(-1.,AMIN1(1.,QLUY)) +C +C Examine the axis parameters. +C + QLUD=ABS(QLUY) + INAD=INAY + UMIN=YBUW + UMAX=YTUW + QMIN=YBUW + QMAX=YTUW +C + I=0 +C + 101 I=I+1 + IF (I.EQ.5) GO TO 104 +C + IF (I.EQ.3) THEN + QLUD=ABS(QLUX) + INAD=INAX + UMIN=XLUW + UMAX=XRUW + QMIN=XLUW + QMAX=XRUW + END IF +C + QDAX(I)=AMAX1(-1.,AMIN1(4.,QDAX(I))) + IF (QDAX(I).LE.0.) GO TO 102 + QLUA(I)=QLUD + QBTP(I)=QBTD(I) + IF (QBTD(I).EQ.SVAL(1).OR.QBTD(I).EQ.SVAL(2)) QBTP(I)=1.+QLUD + QBTP(I)=AMAX1(0.,AMIN1(3.,QBTP(I))) + IF (QBTD(I).EQ.SVAL(2)) QBTD(I)=QBTP(I) +C + CALL AGEXAX (I,SVAL,UMIN,UMAX,INAD-I,QLUD,FUNS(I),QBTP(I),BASD(I), + + BASE(I),QMJD(I),QMND(I),QMNT(I),QLTD(I),QLTP(I), + + QLED(I),QLEX(I),QLFD(I),QLFL(I),QMIN,QMAX) +C + QSPA(I)=AMAX1(0.,AMIN1(1.,QSPA(I))) + IF (QJDP(I).EQ.SVAL(1).OR.QJDP(I).EQ.SVAL(2)) QJDP(I)=65535. + IF (QNDP(I).EQ.SVAL(1).OR.QNDP(I).EQ.SVAL(2)) QNDP(I)=65535. +C + 102 IF (I.EQ.2) THEN + YBUW=QMIN + YTUW=QMAX + ELSE IF (I.EQ.4) THEN + XLUW=QMIN + XRUW=QMAX + END IF +C + GO TO 101 +C +C Examine the user-window min-max/max-min ordering parameters. Compute +C final values of the user-window edge parameters. +C + 104 QOVX=AMAX1(0.,AMIN1(1.,QOVX)) + IF (QOVX.EQ.0.) GO TO 105 + TEMP=XLUW + XLUW=XRUW + XRUW=TEMP +C + 105 QOVY=AMAX1(0.,AMIN1(1.,QOVY)) + IF (QOVY.EQ.0.) GO TO 106 + TEMP=YBUW + YBUW=YTUW + YTUW=TEMP +C +C Determine the exact size and shape of the curve window. +C + 106 XLGW=XLGF*WOFP + XRGW=XRGF*WOFP + YBGW=YBGF*HOFP + YTGW=YTGF*HOFP +C + XLCW=XLGW+XLGD*(XRGW-XLGW) + XRCW=XLGW+XRGD*(XRGW-XLGW) + YBCW=YBGW+YBGD*(YTGW-YBGW) + YTCW=YBGW+YTGD*(YTGW-YBGW) +C + WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + ARWH=WCWP/HCWP +C + IF (SOGD) 107,115,108 +C + 107 DRWH=ABS(SOGD) + GO TO 111 +C + 108 DRWH=ABS((XRUW-XLUW)/(YTUW-YBUW)) + IF (SOGD-1.) 109,110,110 +C + 109 IF (DRWH.LT.SOGD.OR.(1./DRWH).LT.SOGD) GO TO 115 + GO TO 111 +C + 110 IF (DRWH.GT.SOGD.OR.(1./DRWH).GT.SOGD) DRWH=1. +C + 111 IF (DRWH-ARWH) 112,115,113 +C + 112 XLCW=XLCW+.5*(WCWP-HCWP*DRWH) + XRCW=XRCW-.5*(WCWP-HCWP*DRWH) + GO TO 114 +C + 113 YBCW=YBCW+.5*(HCWP-WCWP/DRWH) + YTCW=YTCW-.5*(HCWP-WCWP/DRWH) +C + 114 WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + 115 SCWP=AMIN1(WCWP,HCWP) +C + XLGW=(XLGW-XLCW)/WCWP + XRGW=(XRGW-XLCW)/WCWP + YBGW=(YBGW-YBCW)/HCWP + YTGW=(YTGW-YBCW)/HCWP +C + XLCW=XLCW/WOFP + XRCW=XRCW/WOFP + YBCW=YBCW/HOFP + YTCW=YTCW/HOFP +C +C Make sure the number of dash patterns is in range. +C + QODP=AMAX1(-26.,AMIN1(+26.,QODP)) + IF (QODP.EQ.0.) QODP=-1. +C +C Examine the windowing parameter. +C + QWND=AMAX1(0.,AMIN1(1.,QWND)) +C +C Do a test run of the routine AGLBLS to find out how much space will be +C required for labels in each of the six label boxes. +C + QDLB=AMAX1(0.,AMIN1(2.,QDLB)) + IDLB=IFIX(QDLB) + LBIM=IFIX(QBIM) +C + CALL AGLBLS (-IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Compute the desired and smallest-possible widths of the labels in +C boxes 1 and 2. +C + DWB1=AMAX1(0.,DBOX(1,2)-DBOX(1,1)) + SWB1=AMAX1(0.,SBOX(1,2)-SBOX(1,1)) + DWB2=AMAX1(0.,DBOX(2,2)-DBOX(2,1)) + SWB2=AMAX1(0.,SBOX(2,2)-SBOX(2,1)) +C +C Compute the desired and smallest-possible heights of the labels in +C boxes 3 and 4. +C + DHB3=AMAX1(0.,DBOX(3,4)-DBOX(3,3)) + SHB3=AMAX1(0.,SBOX(3,4)-SBOX(3,3)) + DHB4=AMAX1(0.,DBOX(4,4)-DBOX(4,3)) + SHB4=AMAX1(0.,SBOX(4,4)-SBOX(4,3)) +C +C Do test runs of AGAXIS for each of the four axes to see how much space +C will be required for numeric labels. +C + I=0 +C + 118 I=I+1 + IF (I.EQ.5) GO TO 128 +C + XYPI=FLOAT(1-MOD(I,2)) + IF (QDAX(I).EQ.0.) GO TO 121 + IF (PING(I).NE.SVAL(1)) XYPI=PING(I) +C + IF (I.GE.3) GO TO 119 +C + XYMN=XLGW + XYMX=XRGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-XLUW)/(XRUW-XLUW) + IF (QLUX.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(XLUW))/ + + (ALOG10(XRUW)-ALOG10(XLUW)) + GO TO 120 +C + 119 XYMN=YBGW + XYMX=YTGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-YBUW)/(YTUW-YBUW) + IF (QLUY.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(YBUW))/ + + (ALOG10(YTUW)-ALOG10(YBUW)) +C + 120 XYPI=AMAX1(XYMN,AMIN1(XYMX,XYPI)) +C + 121 GO TO (122,123,124,125) , I +C +C Left y axis. +C + 122 XBGA(1)=XYPI + YBGA(1)=0. + UBGA(1)=YBUW + XNDA(1)=XYPI + YNDA(1)=1. + UNDA(1)=YTUW + WNLL(1)=XYPI-XLGW-DWB1 + WNLR(1)=XRGW-XYPI-DWB2 + GO TO 126 +C +C Right y axis. +C + 123 XBGA(2)=XYPI + YBGA(2)=1. + UBGA(2)=YTUW + XNDA(2)=XYPI + YNDA(2)=0. + UNDA(2)=YBUW + WNLL(2)=XRGW-XYPI-DWB2 + WNLR(2)=XYPI-XLGW-DWB1 + GO TO 126 +C +C Bottom x axis. +C + 124 XBGA(3)=1. + YBGA(3)=XYPI + UBGA(3)=XRUW + XNDA(3)=0. + YNDA(3)=XYPI + UNDA(3)=XLUW + WNLL(3)=XYPI-YBGW-DHB3 + WNLR(3)=YTGW-XYPI-DHB4 + GO TO 126 +C +C Top x axis. +C + 125 XBGA(4)=0. + YBGA(4)=XYPI + UBGA(4)=XLUW + XNDA(4)=1. + YNDA(4)=XYPI + UNDA(4)=XRUW + WNLL(4)=YTGW-XYPI-DHB4 + WNLR(4)=XYPI-YBGW-DHB3 +C + 126 IF (QDAX(I).GT.0.) THEN + CALL AGAXIS (I,QDAX(I),QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I), + + XNDA(I),YNDA(I),QLUA(I),UBGA(I),UNDA(I),FUNS(I), + + QBTP(I),BASE(I),QJDP(I),WMJL(I),WMJR(I),QMNT(I), + + QNDP(I),WMNL(I),WMNR(I),QLTP(I),QLEX(I),QLFL(I), + + QLOF(I),QLOS(I),DNLA(I),WCLM(I),WCLE(I),RFNL(I), + + QCIM(I),QCIE(I),WNLL(I),WNLR(I),10.,11.) + ELSE + WNLL(I)=0. + WNLR(I)=0. + END IF + GO TO 118 +C +C If no labels are to be drawn, AGSTUP is now done. +C + 128 IF (IDLB.EQ.0) GO TO 138 +C +C Check the label boxes, moving and/or shrinking them to prevent the +C labels in them from overlapping any portion of any axis. The labels +C on an axis may have to be moved, as well. +C +C Box 1 - to the left of the curve window. +C + IF (DBOX(1,2).GT.0.) GO TO 903 + DBOX(1,2)=AMIN1(0.,XBGA(1)-WNLL(1),XBGA(2)-WNLR(2)) + DBOX(1,1)=DBOX(1,2)-DWB1 + IF (DBOX(1,1).LT.XLGW) DBOX(1,1)=AMIN1(DBOX(1,2)-SWB1,XLGW) + IF (DBOX(1,1).GE.XLGW) GO TO 130 + DBOX(1,1)=XLGW + DBOX(1,2)=XLGW+SWB1 + TEMP=XBGA(1)-WNLL(1)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 129 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 129 TEMP=XBGA(2)-WNLR(2)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 130 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 2 - to the right of the curve window. +C + 130 IF (DBOX(2,1).LT.1.) GO TO 904 + DBOX(2,1)=AMAX1(1.,XBGA(1)+WNLR(1),XBGA(2)+WNLL(2)) + DBOX(2,2)=DBOX(2,1)+DWB2 + IF (DBOX(2,2).GT.XRGW) DBOX(2,2)=AMAX1(DBOX(2,1)+SWB2,XRGW) + IF (DBOX(2,2).LE.XRGW) GO TO 132 + DBOX(2,1)=XRGW-SWB2 + DBOX(2,2)=XRGW + TEMP=XBGA(1)+WNLR(1)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 131 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 131 TEMP=XBGA(2)+WNLL(2)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 132 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 3 - below the curve window. +C + 132 IF (DBOX(3,4).GT.0.) GO TO 905 + DBOX(3,4)=AMIN1(0.,YBGA(3)-WNLL(3),YBGA(4)-WNLR(4)) + DBOX(3,3)=DBOX(3,4)-DHB3 + IF (DBOX(3,3).LT.YBGW) DBOX(3,3)=AMIN1(DBOX(3,4)-SHB3,YBGW) + IF (DBOX(3,3).GE.YBGW) GO TO 134 + DBOX(3,3)=YBGW + DBOX(3,4)=YBGW+SHB3 + TEMP=YBGA(3)-WNLL(3)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 133 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 133 TEMP=YBGA(4)-WNLR(4)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 134 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 4 - above the curve window. +C + 134 IF (DBOX(4,3).LT.1.) GO TO 906 + DBOX(4,3)=AMAX1(1.,YBGA(3)+WNLR(3),YBGA(4)+WNLL(4)) + DBOX(4,4)=DBOX(4,3)+DHB4 + IF (DBOX(4,4).GT.YTGW) DBOX(4,4)=AMAX1(DBOX(4,3)+SHB4,YTGW) + IF (DBOX(4,4).LE.YTGW) GO TO 136 + DBOX(4,3)=YTGW-SHB4 + DBOX(4,4)=YTGW + TEMP=YBGA(3)+WNLR(3)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 135 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 135 TEMP=YBGA(4)+WNLL(4)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 136 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 5 - the curve window itself. +C + 136 IF (DBOX(5,1).LT.0..OR.DBOX(5,2).GT.1..OR. + + DBOX(5,3).LT.0..OR.DBOX(5,4).GT.1.) GO TO 907 +C + DBOX(5,1)=AMAX1(XLGW,XBGA(1)+WNLR(1)) + DBOX(5,2)=AMIN1(XRGW,XBGA(2)-WNLR(2)) + DBOX(5,3)=AMAX1(YBGW,YBGA(3)+WNLR(3)) + DBOX(5,4)=AMIN1(YTGW,YBGA(4)-WNLR(4)) +C +C Do a final check on all boxes for labels running outside the graph +C window. +C + DO 137 NBOX=1,6 + DBOX(NBOX,1)=AMAX1(XLGW,DBOX(NBOX,1)) + DBOX(NBOX,2)=AMIN1(XRGW,DBOX(NBOX,2)) + DBOX(NBOX,3)=AMAX1(YBGW,DBOX(NBOX,3)) + DBOX(NBOX,4)=AMIN1(YTGW,DBOX(NBOX,4)) + 137 CONTINUE +C +C Do a "SET" call for the user and return. +C + 138 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGSTUP - GRAPH WINDOW IMPROPERLY SPECIFIED',20,2) +C + 902 CALL SETER ('AGSTUP - GRID WINDOW IMPROPERLY SPECIFIED',21,2) +C + 903 CALL SETER ('AGSTUP - LEFT LABELS IMPROPERLY SPECIFIED',22,2) +C + 904 CALL SETER ('AGSTUP - RIGHT LABELS IMPROPERLY SPECIFIED',23,2) +C + 905 CALL SETER ('AGSTUP - BOTTOM LABELS IMPROPERLY SPECIFIED',24,2) +C + 906 CALL SETER ('AGSTUP - TOP LABELS IMPROPERLY SPECIFIED',25,2) +C + 907 CALL SETER ('AGSTUP - INTERIOR LABELS IMPROPERLY SPECIFIED',26,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agutol.f b/sys/gio/ncarutil/autograph/agutol.f new file mode 100644 index 00000000..02dbf64c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agutol.f @@ -0,0 +1,49 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) +C +C This routine is called to perform the mapping from the "user system" +C along an axis to the "label system" along that axis or vice-versa. It +C may be replaced by the user in order to create a desired graph. The +C arguments are as follows: +C +C -- IAXS is the index of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axis, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.', which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C The default routine simply defines the identity mapping for all axes. +C + VOTP=VINP +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/anotat.f b/sys/gio/ncarutil/autograph/anotat.f new file mode 100644 index 00000000..ed46025b --- /dev/null +++ b/sys/gio/ncarutil/autograph/anotat.f @@ -0,0 +1,63 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE ANOTAT (LABX,LABY,LBAC,LSET,NDSH,DSHL) +C + CHARACTER*(*) LABX,LABY,DSHL(*) +C +C The routine ANOTAT resets background annotation. +C +C Declare the type of the dash-pattern-parameter-name generator. +C + CHARACTER*16 AGDSHN +C +C Set up the x-axis label. +C + IF (ICHAR(LABX(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'B') + CALL AGSETI ('LINE/NUMB.',-100) + CALL AGSETC ('LINE/TEXT.',LABX) + END IF +C +C Set up the y-axis label. +C + IF (ICHAR(LABY(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'L') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABY) + END IF +C +C Set up the background the user wants. +C + IF (LBAC.GT.0) CALL AGSETI ('BACK.',LBAC) +C +C Set the parameter ISET. +C + IF (LSET.NE.0) CALL AGSETI ('SET .',LSET) +C +C Set up the dash patterns the user wants. +C + IF (NDSH.NE.0) THEN + IDSH=MIN0(26,NDSH) + CALL AGSETI ('DASH/SELE.',IDSH) + IF (IDSH.LT.0) RETURN + DO 101 I=1,IDSH + CALL AGSETC (AGDSHN(I),DSHL(I)) + 101 CONTINUE + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/displa.f b/sys/gio/ncarutil/autograph/displa.f new file mode 100644 index 00000000..0749b29b --- /dev/null +++ b/sys/gio/ncarutil/autograph/displa.f @@ -0,0 +1,33 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE DISPLA (LFRA,LROW,LTYP) +C +C The subroutine DISPLA resets the parameters IFRA, IROW, and/or LLUX +C and LLUY. +C + IF (LFRA.NE.0) CALL AGSETI ('FRAM.', MAX0(1,MIN0(3,LFRA))) +C + IF (LROW.NE.0) CALL AGSETI ('ROW .',LROW) +C + IF (LTYP.EQ.0) RETURN +C + ITYP=MAX0(1,MIN0(4,LTYP)) + CALL AGSETI ('X/LOGA.', (1-ITYP)/2) + CALL AGSETI ('Y/LOGA.',MOD(1-ITYP,2)) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmxy.f b/sys/gio/ncarutil/autograph/ezmxy.f new file mode 100644 index 00000000..bc8f6352 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmxy.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMXY draws many curves, each of them defined by points of +C the form (XDRA(I,J),YDRA(I,J)) or (XDRA(J,I),YDRA(J,I)) or, possibly, +C (XDRA(I),YDRA(I,J)) or (XDRA(I),YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (4,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INXD=1+(I-1)*IIVX + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA(INXD),IIEX,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmy.f b/sys/gio/ncarutil/autograph/ezmy.f new file mode 100644 index 00000000..e406465b --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmy.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMY (YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMY draws many curves, each of them defined by points of +C the form (I,YDRA(I,J)) or (I,YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (3,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA,0,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezxy.f b/sys/gio/ncarutil/autograph/ezxy.f new file mode 100644 index 00000000..e6ef3b5e --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezxy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZXY (XDRA,YDRA,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZXY draws one curve through the points (XDRA(I),YDRA(I)), +C for I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (2,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,1,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezy.f b/sys/gio/ncarutil/autograph/ezy.f new file mode 100644 index 00000000..3be54a03 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZY (YDRA,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The subroutine EZY draws one curve through the points (I,YDRA(I)), for +C I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (1,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,0,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/idiot.f b/sys/gio/ncarutil/autograph/idiot.f new file mode 100644 index 00000000..0e2ce5e5 --- /dev/null +++ b/sys/gio/ncarutil/autograph/idiot.f @@ -0,0 +1,64 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) +C + REAL XDRA(*),YDRA(*) +C + INTEGER LDSH(*) +C + CHARACTER*(*) LABX,LABY,LABG +C + CHARACTER*16 AGBNCH +C +C This is an implementation of the routine from which AUTOGRAPH grew. +C It should work pretty much as the original did (if you can figure out +C what that was). +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','IDIOT','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL ANOTAT (LABX,LABY,1,2-ISIGN(1,NPTS),1,AGBNCH(LDSH)) +C + CALL DISPLA (2-MAX0(-1,MIN0(1,LFRA)),1,LTYP) +C + CALL AGEZSU (5,XDRA,YDRA,IABS(NPTS),1,IABS(NPTS),LABG,IIVX,IIEX, + + IIVY,IIEY) + CALL AGBACK +C + CALL AGCURV (XDRA,1,YDRA,1,IABS(NPTS),1) +C + IF (LFRA.GT.0) CALL FRAME +C +C +NOAO +C + call plotit (0, 0, 2) + call initut +C +C -NOAO + RETURN + END diff --git a/sys/gio/ncarutil/autograph/mkpkg b/sys/gio/ncarutil/autograph/mkpkg new file mode 100644 index 00000000..8af0a0d4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/mkpkg @@ -0,0 +1,62 @@ +# Make the NCAR AUTOGRAPH library. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + agdflt.f + agaxis.f + agback.f + agbnch.f + agchax.f + agchcu.f + agchil.f + agchnl.f + agctcs.f + agctko.f + agcurv.f + agdash.f + agdlch.f + agdshn.f + agexax.f + agexus.f + agezsu.f + agfpbn.f + agftol.f + aggetc.f + aggetf.f + aggeti.f + aggetp.f + aggtch.f + aginit.f + agkurv.f + aglbls.f + agmaxi.f + agmini.f + agnumb.f + agppid.f + agpwrt.f + agqurv.f + agrpch.f + agrstr.f + agsave.f + agscan.f + agsetc.f + agsetf.f + agseti.f + agsetp.f + agsrch.f + agstch.f + agstup.f + agutol.f + anotat.f + displa.f + ezmxy.f + ezmy.f + ezxy.f + ezy.f + idiot.f + pstr.x + ; diff --git a/sys/gio/ncarutil/autograph/pstr.x b/sys/gio/ncarutil/autograph/pstr.x new file mode 100644 index 00000000..a40c9fc1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/pstr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PSTR -- Print a character string from a fortran program. The string is +# passed as an unpacked spp string, the result of f77upk in the calling +# program. PSTR is called by agppid.f in the autograph package. + +procedure pstr (spp_string) + +char spp_string[ARB] + +begin + call eprintf ("%s\n") + call pargstr (spp_string) +end diff --git a/sys/gio/ncarutil/conbd.f b/sys/gio/ncarutil/conbd.f new file mode 100644 index 00000000..eaaf2df5 --- /dev/null +++ b/sys/gio/ncarutil/conbd.f @@ -0,0 +1,111 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C BLOCKDATA CONBD + subroutine conbd + integer first, temp + common /conflg/ first + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c +noao: dimension of stline ir array increased from 20000 to 80000 6-93 + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP, + 1 NCRT ,ILAB ,NULBLL ,IOFFD, + 2 EXT ,IOFFM ,ISOLID ,NLA, + 3 NLM ,XLT ,YBT ,SIDE + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C + SAVE +C +C DATA IOFFP,SPVAL/0,0.0/ + data temp /1/ + first = temp + IOFFP = 0 + SPVAL = 0.0 +C DATA ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ +C 1 1, 2, 0, 16, 40,.05,.05, .9, 1023, 6, 4 / + if (first .ne. 1) then + return + endif + + temp = 0 + +c ISIZEL = 1 +c noao: size of contour labels seemed too large. Changed from 1 to 0 + isizel = 0 + ISIZEM = 2 + ISIZEP = 0 + NLA = 16 + NLM = 40 + XLT = .05 + YBT = .05 + SIDE = .9 + ISOLID = 1023 + NREP = 4 + NCRT = 2 +C DATA EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,3,0,1/ +C +noao value of "extreme" axes ratios changed from 1/4 to 1/16 (ShJ 6-10-88) +C EXT = .25 + EXT = .0625 +C -noao + IOFFD = 0 + NULBLL = 3 + IOFFM = 0 + ILAB = 1 +C DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +C 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +C DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +C 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +C DATA NR/500/ +c +noao: dimension of stline array increased from 500 to 5000 6March87 +c +noao: dimension of stline array increased from 5000 to 20000 Jan90 +c +noao: dimension of stline array increased from 20000 to 80000 6-93 + NR = 80000 +C DATA IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ +c +noao: value of irecmj changed so major divisions are high intensity + IRECMJ = 2 + IRECMN = 1 + IRECTX = 1 +C +C - noao +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/conbdn.f b/sys/gio/ncarutil/conbdn.f new file mode 100644 index 00000000..cd7ca00d --- /dev/null +++ b/sys/gio/ncarutil/conbdn.f @@ -0,0 +1,342 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data conbdn changed to run time initialization +c BLOCKDATA CONBDN + subroutine conbdn +C +C +C +C COMMON DATA +C +C NOTE THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY, NOT ALL MEMBERS WILL USE ALL +C THE COMMON DATA. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER ARROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN"S +C AND MAX"S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN , MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGUALTION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IREC-PORT RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING(STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING OF TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT COLOR (INTENSITY) INDEX SETTING +C INMAJ-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MAJOR LINES +C INMIN-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MINOR LINES +C INLAB-TITLE AND MESSAGE COLOR (INTENSITY) INDEX +C INDAT-DATA VALUE COLOR (INTENSITY) INDEX +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM LEFT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y CORRDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVITIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORD FOR SHIELDING +C YVS-ARRAY OF THE Y COORD FOR SHIELDING +C IXVST-POINTER (VIA LOC) TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER (VIA LOC) TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDRY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICTE STATUS OF SHIEDL PLOTTING +C CONR14 +C LINEAR-C1 LINAER INTERPOLATIN FLAG +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210), + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS, + 1 ISCALE ,LOOK ,PLDVLS ,GRD, + 2 CINC ,CHILO ,CON ,LABON, + 3 PMIMX ,SCALE ,FRADV ,EXTRI, + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED, + 1 STPSZ ,IGRAD ,IG ,XRG, + 2 YRG ,BORD ,PXST ,PYST, + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT, + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR, + 1 BR ,TL ,BL ,CONV, + 2 XN ,YN ,ITLL ,IBLL, + 3 ITRL ,IBRL ,XC ,YC, + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT, + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS, + 1 LOOK ,PLDVLS ,GRD ,LABON, + 2 PMIMX ,FRADV ,EXTRI ,CINC, + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + logical first + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C + SAVE +C +C +c +noao: parameter added to avoid clobbering initialization done +c by conop[1-4]. + data first /.true./ + if (.not. first) return + first = .false. +c -noao +C +c DATA ICOUNT,SHIELD,SLDPLT,LINEAR/0,.FALSE.,.FALSE.,.FALSE./ + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. + LINEAR = .FALSE. +c +c DATA REPEAT,EXTRAP,PER/.FALSE.,.FALSE.,.TRUE./ + REPEAT = .FALSE. + EXTRAP = .FALSE. + PER = .TRUE. +c +c DATA FRADV,EXTRI,BPSIZ/.TRUE.,.FALSE.,0.0/ + FRADV = .TRUE. + EXTRI = .FALSE. + BPSIZ = 0.0 +c +c DATA TITLE,MESS,LOOK/.FALSE.,.TRUE.,.FALSE./ + TITLE = .FALSE. + MESS = .TRUE. + LOOK = .FALSE. +c +c DATA PLDVLS,GRD/.FALSE.,.FALSE./ + PLDVLS = .FALSE. + GRD = .FALSE. +c +c DATA CON,CINC,CHILO/.FALSE.,.FALSE.,.FALSE./ + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. +c +c DATA SCALE,PMIMX/1.,.FALSE./ + SCALE = 1. + PMIMX = .FALSE. +c +c DATA ISIZEP,ISIZEM,TENS/8,15,2.5/ + ISIZEP = 8 + ISIZEM = 15 + TENS = 2.5 +c +c DATA INMAJ,INMIN,INLAB,INDAT/1, 1, 1, 1/ + INMAJ = 2 + INMIN = 1 + INLAB = 2 + INDAT = 1 +c +c DATA IRANMJ, IRANMN, IRANTX /1, 1, 1/ + IRANMJ = 2 + IRANMN = 1 + IRANTX = 1 +c +c DATA IRASMJ, IRASMN, IRASTX /1, 1, 1/ + IRASMJ = 2 + IRASMN = 1 + IRASTX = 1 +c +c DATA IRAQMJ, IRAQMN, IRAQTX /1, 1, 1/ + IRAQMJ = 2 + IRAQMN = 1 + IRAQTX = 1 +c +c DATA LABON/.TRUE./,LISTOP/.FALSE./ + LABON = .TRUE. + LISTOP = .FALSE. +c +c DATA BORD,ITICK/.9,10/ + BORD = .9 + ITICK = 10 +c +c DATA ISCALE,ITLSIZ/0,16/ + ISCALE = 0 + ITLSIZ = 16 +c +c DATA ITIPV,NIT,NCL/0,0,0/ + ITIPV = 0 + NIT = 0 + NCL = 0 +c +c DATA NCPSZ/25/ + NCPSZ = 25 +c +c DATA IHIGH/255/ + IHIGH = 255 +c +c DATA NCP /4/ + NCP = 4 +c +c DATA IREC /1/ + IREC = 1 +c +c DATA LEN,IFMT,LEND,IFMTD/0,0,7,10/ + LEN = 0 + IFMT = 0 + LEND = 7 + IFMTD = 10 +c +c DATA IGRAD,IG/40,40/ + IGRAD = 40 + IG = 40 +c +c DATA NREP,NCRT,ISIZEL,MXXY,MINGAP/6,3,9,500,3/ + NREP = 6 + NCRT = 3 + ISIZEL = 9 + MXXY = 500 + MINGAP = 3 +c +c DATA IDASH(1:1)/' '/ + IDASH(1:1) = ' ' +c +c DATA NDASH(1:1)/' '/ + NDASH(1:1) = ' ' +c +c DATA EDASH(1:1)/' '/ + EDASH(1:1) = ' ' +c +c DATA ISHFCT/9/ + ISHFCT = 9 +c +c - noao + END diff --git a/sys/gio/ncarutil/conlib/README b/sys/gio/ncarutil/conlib/README new file mode 100644 index 00000000..69f73877 --- /dev/null +++ b/sys/gio/ncarutil/conlib/README @@ -0,0 +1,3 @@ +CONLIB -- This directory contains the contents of the NCAR files concom.f and +conterp.f, unpacked one subroutine per file. The unpacking operation is +necessary to permit topological ordering of the library. diff --git a/sys/gio/ncarutil/conlib/concal.f b/sys/gio/ncarutil/conlib/concal.f new file mode 100644 index 00000000..e021fa30 --- /dev/null +++ b/sys/gio/ncarutil/conlib/concal.f @@ -0,0 +1,340 @@ + SUBROUTINE CONCAL (XD,YD,ZD,NT,IPT,NL,IPL,PDD,ITI,XII,YII,ZII, + 1 ITPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPO- +C LATION, I.E., DETERMINES THE Z VALUE AT A POINT. +C THE INPUT PARAMETERS ARE +C +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z +C COORDINATES OF DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE END POINTS OF THE BORDER LINE SEGMENTS AND +C THEIR RESPECTIVE TRIANGLE NUMBERS, +C PDD = ARRAY CONTAINING THE PARTIAL DERIVATIVES AT +C THE DATA POINTS, +C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES +C THE POINT FOR WHICH INTERPOLATION IS TO BE +C PERFORMED, +C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH +C INTERPOLATION IS TO BE PERFORMED. +C THE OUTPUT PARAMETER IS +C +C ZII = INTERPOLATED Z VALUE. +C +C DECLARATION STATEMENTS +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,IPT(1) , + 1 IPL(1) ,PDD(1) + DIMENSION X(3) ,Y(3) ,Z(3) ,PD(15) , + 1 ZU(3) ,ZV(3) ,ZUU(3) ,ZUV(3) , + 2 ZVV(3) + REAL LU ,LV + EQUIVALENCE (P5,P50) +C + SAVE +C +C PRELIMINARY PROCESSING +C + IT0 = ITI + NTL = NT+NL + IF (IT0 .LE. NTL) GO TO 100 + IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IF (IL1 .EQ. IL2) GO TO 150 + GO TO 200 +C +C CALCULATION OF ZII BY INTERPOLATION. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 100 IF (IT0 .EQ. ITPV) GO TO 140 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE +C IPI 102 VERTEXES. +C IPI 103 +C + JIPT = 3*(IT0-1) + JPD = 0 + DO 120 I=1,3 + JIPT = JIPT+1 + IDP = IPT(JIPT) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 110 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 110 CONTINUE + 120 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = X(2)-X0 + B = X(3)-X0 + C = Y(2)-Y0 + D = Y(3)-Y0 + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -C/DLT + DP = A/DLT +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE +C TRIANGLE FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 130 I=1,3 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 130 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P10-P20 + H2 = ZU(2)-P10-ZUU(1) + H3 = ZUU(2)-ZUU(1) + P30 = 10.0*H1-4.0*H2+0.5*H3 + P40 = -15.0*H1+7.0*H2-H3 + P50 = 6.0*H1-3.0*H2+0.5*H3 + H1 = Z(3)-P00-P01-P02 + H2 = ZV(3)-P01-ZVV(1) + H3 = ZVV(3)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + LU = SQRT(AA+CC) + LV = SQRT(BB+DD) + THXU = ATAN2(C,A) + THUV = ATAN2(D,B)-THXU + CSUV = COS(THUV) + P41 = 5.0*LV*CSUV/LU*P50 + P14 = 5.0*LU*CSUV/LV*P05 + H1 = ZV(2)-P01-P11-P41 + H2 = ZUV(2)-P11-4.0*P41 + P21 = 3.0*H1-H2 + P31 = -2.0*H1+H2 + H1 = ZU(3)-P10-P11-P14 + H2 = ZUV(3)-P11-4.0*P14 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + THUS = ATAN2(D-C,B-A)-THXU + THSV = THUV-THUS + AA = SIN(THSV)/LU + BB = -COS(THSV)/LU + CC = SIN(THUS)/LV + DD = COS(THUS)/LV + AC = AA*CC + AD = AA*DD + BC = BB*CC + G1 = AA*AC*(3.0*BC+2.0*AD) + G2 = CC*AC*(3.0*AD+2.0*BC) + H1 = -AA*AA*AA*(5.0*AA*BB*P50+(4.0*BC+AD)*P41)- + 1 CC*CC*CC*(5.0*CC*DD*P05+(4.0*AD+BC)*P14) + H2 = 0.5*ZVV(2)-P02-P12 + H3 = 0.5*ZUU(3)-P20-P21 + P22 = (G1*H2+G2*H3-H1)/(G1+G2) + P32 = H2-P22 + P23 = H3-P22 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 140 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*(P13+V*P14))) + P2 = P20+V*(P21+V*(P22+V*P23)) + P3 = P30+V*(P31+V*P32) + P4 = P40+V*P41 + ZII = P0+U*(P1+U*(P2+U*(P3+U*(P4+U*P5)))) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE RECTANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 150 IF (IT0 .EQ. ITPV) GO TO 190 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END +C POINTS OF THE BORDER LINE SEGMENT. +C + JIPL = 3*(IL1-1) + JPD = 0 + DO 170 I=1,2 + JIPL = JIPL+1 + IDP = IPL(JIPL) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 160 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 160 CONTINUE + 170 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = Y(2)-Y(1) + B = X(2)-X(1) + C = -B + D = A + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -BP + DP = AP +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE +C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 180 I=1,2 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 180 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P01-P02 + H2 = ZV(2)-P01-ZVV(1) + H3 = ZVV(2)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + H1 = ZU(2)-P10-P11 + H2 = ZUV(2)-P11 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + P21 = 0.0 + P23 = -ZUU(2)+ZUU(1) + P22 = -1.5*P23 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 190 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*P13)) + P2 = P20+V*(P21+V*(P22+V*P23)) + ZII = P0+U*(P1+U*P2) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE TRIANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 200 IF (IT0 .EQ. ITPV) GO TO 220 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX +C OF THE TRIANGLE. +C + JIPL = 3*IL2-2 + IDP = IPL(JIPL) + X(1) = XD(IDP) + Y(1) = YD(IDP) + Z(1) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 210 KPD=1,5 + JPDD = JPDD+1 + PD(KPD) = PDD(JPDD) + 210 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = PD(1) + P01 = PD(2) + P20 = 0.5*PD(3) + P11 = PD(4) + P02 = 0.5*PD(5) + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 220 U = XII-X(1) + V = YII-Y(1) +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*P02) + P1 = P10+V*P11 + ZII = P0+U*(P1+U*P20) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concld.f b/sys/gio/ncarutil/conlib/concld.f new file mode 100644 index 00000000..6829d5fe --- /dev/null +++ b/sys/gio/ncarutil/conlib/concld.f @@ -0,0 +1,314 @@ + SUBROUTINE CONCLD (ICASE,IOOP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + INTEGER GOOP +C + SAVE + DATA GOOP/0/ +C +C STATEMENT FUNCTIONS FOR CONTOUR PLACEMENT WITHIN CELLS +C + CX(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + CY(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + IC = ICASE + ICASE = 0 +C +C SPECIAL PROCESSING IF SHIELDING ACTIVATED +C + IF (.NOT.SHIELD) GO TO 1 +C +C CHECK IF ANY CELL CORNER CONTAINS A SPECIAL VALUE +C IF SO THEN FLAG AND RETURN +C + IF (TR.NE.SPVAL.AND.BR.NE.SPVAL.AND.TL.NE.SPVAL.AND.BL.NE.SPVAL) + 1 GO TO 1 +C +C SPECIAL VALUE IN CELL FLAG AND RETURN +C + ICASE = -1 + RETURN +C +C IF CURRENT BR VALUE LESS THAN CONTOUR THEN NEIGHBOR WILL BE WHERE +C CONTOUR IS DRAWN. +C + 1 CONTINUE +C + IF (BR.LT.CONV) GO TO 90 +C +C CURRENT LOCATION IS WHERE CONTOUR WILL BE DRAWN +C +C TEST FOR VERTICAL CONTOUR BREAK +C + IF (BL.GE.CONV) GO TO 60 +C +C VERTICAL CONTOUR BREAK +C +C CASE 1 LEFT NEIGHBOR LESS THAN CONTOUR LEVEL AND CURRENT +C LOCATION GE CONTOUR VALUE +C + IF (TR.GE.CONV) GO TO 40 +C +C CASE 1A CONTOUR LOWER RIGHT +C +C +C CONTOUR FROM UPPER RIGHT +C + XO = XC-CX(BR,TR) + YO = YC + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 4 + IF (IC.NE.3) GO TO 10 + ICASE = IOC + XN = XO + YN = YO + RETURN + 10 IF (IOOP.NE.GOOP) GO TO 20 + IF (IC.NE.2) GO TO 30 + 20 ICASE = NC + RETURN +C +C CASE 1B CONTOR UPPER LEFT +C + 30 XN = XC-STPSZ + YN = YC-STPSZ+CY(TL,TR) + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + IOC = 2 + NC = 3 + GO TO 180 +C +C CONTOURS FROM ABOVE AND UPPER LEFT +C + 40 IF (TL.LT.CONV) GO TO 50 +C +C CASE 1C CONTOUR LOWER LEFT +C + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 2 + GO TO 180 +C +C CASE 1D CONTOUR FROM ABOVE +C + 50 XO = XC-STPSZ + YO = YC-CY(TR,TL) + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C +C TEST FOR HORIZONTAL CONTOUR BREAK +C + 60 IF (TR.LT.CONV) GO TO 70 + IF (TL.GE.CONV) GO TO 200 +C +C CASE 2A CONTOUR UPPER LEFT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-CX(BL,TL) + YN = YC-STPSZ + NC = 2 + IOC = 3 + GO TO 180 +C + 70 IF (TL.LT.CONV) GO TO 80 +C +C CASE 2B CONTOUR FROM UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 2C CONTOUR FROM LEFT TO RIGHT +C + 80 XO = XC-CX(BL,TL) + YO = YC-STPSZ + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 2 + GO TO 180 +C +C +C CURRENT BR VALUE LESS THAN CONTOUR +C +C + 90 IF (BL.LT.CONV) GO TO 150 +C +C VERTICAL CONTOUR BREAK +C +C CASE 3 CURRENT SPACE LESS THAN CONTOUR LEVEL AND LEFT +C NEIGHBOR GE CONTOUR LEVEL +C + IF (TL.GE.CONV) GO TO 130 +C +C CASE 3A CONTOUR LOWER LEFT +C + XO = XC-CX(BL,TL) + YO = YC-STPSZ + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 2 + IF (IC.NE.3) GO TO 100 + ICASE = IOC + XN = XO + YN = YO + RETURN + 100 IF (IOOP.NE.GOOP) GO TO 110 + IF (IC.NE.4) GO TO 120 + 110 ICASE = NC + RETURN +C +C CASE 3B CONTOUR UPPERRIGHT +C + 120 XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C + 130 IF (TR.GE.CONV) GO TO 140 +C +C CASE 3C CONTOUR FROM ABOVE +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C CASE 3D CONTOUR LOWER RIGHT +C + 140 XO = XC-STPSZ+CX(TR,BR) + YO = YC + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 4 + GO TO 180 +C +C +C +C TEST FOR HORIZONTAL BREAK POINT +C + 150 IF (TR.GE.CONV) GO TO 160 +C + IF (TL.LT.CONV) GO TO 200 +C +C CASE 4A CONTOUR UPPER LEFT +C + XN = XC-STPSZ+CX(TL,BL) + YN = YC-STPSZ + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + NC = 2 + IOC = 3 + GO TO 180 +C + 160 IF (TL.GE.CONV) GO TO 170 +C +C CASE 4B CONTOUR UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 4C CONTOUR FROM LEFT TO RIGHT +C + 170 YO = YC-STPSZ + XO = XC-STPSZ+CX(TL,BL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 2 +C +C DRAW THE CONTOUR LINES NOT ALREADY TAKEN CARE OF +C + 180 IF (IABS(IC-NC).NE.2) GO TO 190 + ICASE = IOC + XN = XO + YN = YO + RETURN + 190 ICASE = NC + 200 RETURN + END diff --git a/sys/gio/ncarutil/conlib/concls.f b/sys/gio/ncarutil/conlib/concls.f new file mode 100644 index 00000000..02d97a4d --- /dev/null +++ b/sys/gio/ncarutil/conlib/concls.f @@ -0,0 +1,177 @@ + SUBROUTINE CONCLS (ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C GENERATE CONTOUR LEVELS BASED ON THE INPUT DATA +C + DIMENSION ZD(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C IF NOT USER SET COMPUTE CONTOUR LEVELS +C + IF (.NOT.CON) GO TO 150 +C +C OTHERWISE GET HI AND LOW CONTOURS FOR MESSAGE +C + HI = CL(1) + FLO = CL(1) + DO 110 I=1,NCL + IF (HI .GE. CL(I)) GO TO 100 + HI = CL(I) + GO TO 110 + 100 IF (FLO .LE. CL(I)) GO TO 110 + FLO = CL(I) + 110 CONTINUE +C +C GET INCREMENT IF EQUAL SPACED CONTOURS +C + IF (NCL .NE. 1) GO TO 120 + FINC = 0. + RETURN + 120 FINC = ABS(CL(1)-CL(2)) + IF (NCL .EQ. 2) RETURN + DO 130 I=3,NCL + IF (FINC .NE. ABS(CL(I-1)-CL(I))) GO TO 140 + 130 CONTINUE + RETURN + 140 FINC = -1. + RETURN +C +C FIND HIGHEST AND LOWEST INPUT VALUES +C + 150 IF (CHILO) GO TO 180 + FLO = ZD(1) + HI = ZD(1) + DO 170 I=2,NDP + IF (FLO .LE. ZD(I)) GO TO 160 + FLO = ZD(I) + GO TO 170 + 160 IF (HI .GE. ZD(I)) GO TO 170 + HI = ZD(I) + 170 CONTINUE +C +C CALCULATE THE CONTOUR LEVEL INTERVAL +C + 180 IF (CINC) GO TO 200 + FINC = (HI-FLO)/15. + IF (FINC .NE. 0.) GO TO 190 + CALL SETER (' CONCLS - CONSTANT INPUT FIELD',1,1) + RETURN +C +C ROUND FINC TO NICE NUMBER +C + 190 P = 10.**(IFIX(ALOG10(FINC)+500.)-500) + FINC = AINT(FINC/P+0.1)*P +C +C ROUND THE LOW VALUE TO START AT A NICE NUMBER +C + 200 IF (CHILO) GO TO 210 + FLO = AINT(FLO/FINC)*FINC +C +C COMPUTE THE CONTOUR LEVELS +C +C TEST IF BREAK POINT WITHIN RANGE OF HI TO FLO +C + 210 IF (BPSIZ.GE.FLO .AND. BPSIZ.LE.HI) GO TO 240 +C +C BREAK POINT OUT OF RANGE SO GENERATE CONTOURS BASED ON FLO +C + DO 220 I=1,30 + CV = FLO+FLOAT(I-1)*FINC + ICUR = I + CL(I) = CV + IF (CV .GE. HI) GO TO 230 + 220 CONTINUE + 230 NCL = ICUR + HI = CV + RETURN +C +C BREAK POINT WITHIN RANGE SO BASE CONTOURS ON IT +C + 240 DO 250 I=1,30 + CV = BPSIZ-FLOAT(I-1)*FINC + IND = (30-I)+1 + CL(IND) = CV + ICUR = I + IF (CV .LE. FLO) GO TO 260 + 250 CONTINUE +C +C PUT THE CONTOURS IN THE CORRECT ORDER +C + 260 DO 270 I=1,ICUR + IND = (30-ICUR)+I + CL(I) = CL(IND) + 270 CONTINUE +C +C ADD THE GREATER THAN BREAK POINT CONTOURS +C + IEND = 30-ICUR + ISAV = ICUR+1 + DO 280 I=1,IEND + CV = BPSIZ+FLOAT(I)*FINC + CL(ISAV) = CV + ISAV = ISAV+1 + IF (CV .GE. HI) GO TO 290 + 280 CONTINUE +C +C SET NUMBER OF CONTOUR LEVELS AND UPDATE THE HIGH VALUE +C + 290 NCL = ISAV-1 + HI = CV + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concom.f b/sys/gio/ncarutil/conlib/concom.f new file mode 100644 index 00000000..8a5041df --- /dev/null +++ b/sys/gio/ncarutil/conlib/concom.f @@ -0,0 +1,78 @@ + FUNCTION CONCOM (XQ,YQ,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C INTERPOLATE A GIVEN X,Y PAIR AND RETURN ITS LOCATION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,WK(1) , + 1 IWK(1) +C + SAVE +C +C LOCATE PROPER TRIANGLE +C + CALL CONLOC (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),XQ,YQ,LOC, + 1 IWK(JWIWL),WK) +C +C INTERPOLATE THE LOCATION +C + CALL CONCAL (XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK(IPR),LOC,XQ, + 1 YQ,TEMP,ITPV) + CONCOM = TEMP + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condet.f b/sys/gio/ncarutil/conlib/condet.f new file mode 100644 index 00000000..6b3a3077 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condet.f @@ -0,0 +1,128 @@ + SUBROUTINE CONDET (NDP,XD,YD,NCP,IPC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN , CONRAQ AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST +C TO EACH OF THE DATA POINT. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS CONTAINING THE X AND Y COORDINATES +C OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA +C POINTS. +C THE OUTPUT PARAMETER IS +C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE +C POINT NUMBERS OF NCP DATA POINTS CLOSEST TO +C EACH OF THE NDP DATA POINTS ARE TO BE STORED. +C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST +C NOT EXCEED 25 WITHOUT MODIFICATION TO THE ARRAYS DSQ0 AND IPC0. +C DECLARATION STATEMENTS +C + COMMON /CONRA3/ IREC + DIMENSION XD(NDP) ,YD(NDP) ,IPC(1) + DIMENSION DSQ0(25) ,IPC0(25) +C + SAVE +C +C STATEMENT FUNCTION +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 +C +C CALCULATION +C + DO 220 IP1=1,NDP +C +C - SELECTS NCP POINTS. +C + X1 = XD(IP1) + Y1 = YD(IP1) + J1 = 0 + DSQMX = 0.0 + DO 110 IP2=1,NDP + IF (IP2 .EQ. IP1) GO TO 110 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + J1 = J1+1 + DSQ0(J1) = DSQI + IPC0(J1) = IP2 + IF (DSQI .LE. DSQMX) GO TO 100 + DSQMX = DSQI + JMX = J1 + 100 IF (J1 .GE. NCP) GO TO 120 + 110 CONTINUE + 120 IP2MN = IP2+1 + IF (IP2MN .GT. NDP) GO TO 150 + DO 140 IP2=IP2MN,NDP + IF (IP2 .EQ. IP1) GO TO 140 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .GE. DSQMX) GO TO 140 + DSQ0(JMX) = DSQI + IPC0(JMX) = IP2 + DSQMX = 0.0 + DO 130 J1=1,NCP + IF (DSQ0(J1) .LE. DSQMX) GO TO 130 + DSQMX = DSQ0(J1) + JMX = J1 + 130 CONTINUE + 140 CONTINUE +C +C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. +C + 150 IP2 = IPC0(1) + DX12 = XD(IP2)-X1 + DY12 = YD(IP2)-Y1 + DO 160 J3=2,NCP + IP3 = IPC0(J3) + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .NE. 0.0) GO TO 200 + 160 CONTINUE +C +C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. +C + NCLPT = 0 + DO 190 IP3=1,NDP + IF (IP3 .EQ. IP1) GO TO 190 + DO 170 J4=1,NCP + IF (IP3 .EQ. IPC0(J4)) GO TO 190 + 170 CONTINUE + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .EQ. 0.0) GO TO 190 + DSQI = DSQF(X1,Y1,XD(IP3),YD(IP3)) + IF (NCLPT .EQ. 0) GO TO 180 + IF (DSQI .GE. DSQMN) GO TO 190 + 180 NCLPT = 1 + DSQMN = DSQI + IP3MN = IP3 + 190 CONTINUE + DSQMX = DSQMN + IPC0(JMX) = IP3MN +C +C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. +C + 200 J1 = (IP1-1)*NCP + DO 210 J2=1,NCP + J1 = J1+1 + IPC(J1) = IPC0(J2) + 210 CONTINUE + 220 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condrw.f b/sys/gio/ncarutil/conlib/condrw.f new file mode 100644 index 00000000..df47eae9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condrw.f @@ -0,0 +1,253 @@ + SUBROUTINE CONDRW (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW ALL CONTOURS AT THIS LEVEL +C IF NOT EXTRAPOLATING +C SEARCH CONVEX HULL FOR CONTOURS INTERSECTING IT AND DRAW THEM +C SEARCH INTERIOR AND DRAW ALL REMAINING UNDRAWN CONTOURS +C +C IF EXTRAPOLATING +C SEARCH FROM X START TO X END AND Y START TO Y END FOR ALL +C CONTOURS AT THIS LEVEL +C +C INPUT +C SCRARR SCRATCH ARRAY USED FOR FAST CONTOURING +C VIA COMMON BLOCKS BELOW +C CONV-THE CURRENT CONTOUR LEVEL +C ITLOC-THE CONVEX HULL BOUNDRIES RELATIVE TO THE SCRATCH +C ARRAY, SCRARR +C PV-REAL Y COOORDINATES OF THE CONVEX HULL RELATIVE TO THE +C USERS COORDINATE SPACE +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C +C OUTPUT +C CONTOUR LINES OUTPUT TO PLOTTER FILE +C +C NOTE +C THIS ROUTINE WILL DETECT AND CORRECT FOR CONRAN ERROR 9 +C + DIMENSION SCRARR(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C +C FLAGS TO ALLOW COMPRESSION OF CONTOUR STORAGE IF IT IS EXAUSTED +C + DATA ICOMP,NOCOMP/1,0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C CLEAR THE CONTOUR STORAGE LIST +C + NP = 0 +C +C SCAN X BOARDERS FOR INTERSECTIONS +C + JX = 2 + ICASE = 1 + X = XST+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 10 IF (.NOT.EXTRAP) GO TO 20 + JY = 2 + JYE = IYMAX + Y = YST+STPSZ + GO TO 30 +C +C NOT EXTRAPOLATING +C + 20 JY = ITLOC(JX*2-1) + IF (JY.EQ.0) GO TO 60 + JYE = ITLOC(JX*2)+1 + IF (JYE.GT.IYMAX) JYE = IYMAX + Y = PV(JX*2-1) + IF (JY.GE.2) GO TO 30 + JY = 2 + Y = YST+STPSZ + 30 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 40 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 50 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 50 TL = TR + BL = BR + JY = JY+1 + Y = Y+STPSZ + IF (JY.LE.JYE) GO TO 40 + 60 IF (JX.EQ.IXMAX) GO TO 70 + JX = IXMAX + ICASE = 3 + X = XMAX + GO TO 10 +C +C SCAN Y BOARDERS +C + 70 IPOS = 1 + ICASE = 4 + 80 JX = 3 + X = XST+STPSZ+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 90 IF (.NOT.EXTRAP) GO TO 100 + JY = 2 + Y = YST+STPSZ + IF (IPOS.NE.0) GO TO 110 + JY = IYMAX + Y = YED + GO TO 110 +C +C NOT EXTRAPOLATING +C + 100 JY = ITLOC(JX*2 - IPOS ) + IF (JY.EQ.0) GO TO 120 + JY = JY + IPOS + Y = PV(JX*2 - IPOS) + STPSZ*(1*IPOS) + 110 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 120 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 120 JX = JX+1 + X = X+STPSZ + IF (JX.LE.IXMAX-1) GO TO 90 + IF (IPOS.EQ.0) GO TO 130 + IPOS = 0 + ICASE = 2 + GO TO 80 +C +C BOARDER SEARCH DONE CONTOUR INTERIOR +C +C INITIALIZE THE SEARCH +C + 130 JX = 3 + ICASE = 0 + X = XST+STPSZ+STPSZ + JXE = IXMAX-1 +C +C IF EXTRAPOLATING GO FROM BORDER TO BORDER +C + 140 IF (.NOT.EXTRAP) GO TO 150 + JY = 3 + JYE = IYMAX-1 + Y = YST+STPSZ+STPSZ + GO TO 160 +C +C NOT EXTRAPOLATING STAY IN HULL +C + 150 JY = ITLOC(JX*2 - 1)+2 + IF (JY.EQ.2) GO TO 190 + JYE = ITLOC(JX*2)-1 + Y = PV(JX*2 - 1)+STPSZ+STPSZ +C + 160 IF (JY.GT.JYE) GO TO 190 + TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 170 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,ICOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 180 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 180 JY = JY+1 + Y = Y+STPSZ + TL = TR + BL = BR + IF (JY.LE.JYE) GO TO 170 +C +C PROCESS EACH ROW OF INTERIOR +C + 190 X = X+STPSZ + JX = JX+1 + IF (JX.LE.JXE) GO TO 140 +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condsd.f b/sys/gio/ncarutil/conlib/condsd.f new file mode 100644 index 00000000..0ea5fb43 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condsd.f @@ -0,0 +1,54 @@ + SUBROUTINE CONDSD +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE OUTLINE OF THE SHIELD ON THE PLOT +C + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C GET THE START POINT +C + XS = XVS(1) + YS = YVS(1) +C +C MOVE TO THE START OF THE OUTLINE +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,0) +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 2,ICOUNT +C +C DRAW THE OUTLINE OF THE SHIELD +C + CALL FL2INT(XVS(IC),YVS(IC),IX,IY) + CALL PLOTIT(IX,IY,1) +C + 100 CONTINUE +C +C DRAW TO THE START +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conecd.f b/sys/gio/ncarutil/conlib/conecd.f new file mode 100644 index 00000000..56d8a934 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conecd.f @@ -0,0 +1,178 @@ + SUBROUTINE CONECD (VAL,IOUT,NUSED) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE +C ON INPUT +C VAL THE NUMBER TO BE ENCODED +C ON OUTPUT +C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO +C HOLD UP TO 9 CHARACTERS. +C +C NUSED NUMBER OF CHARACTERS IN IOUT +C +C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2 +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + CHARACTER*(*) IOUT + CHARACTER*6 IFMT1 +C +C +NOAO - Variables CHTMP and IT are not used. +C +C CHARACTER*9 CHTMP +C CHARACTER*1 IT +C +C -NOAO +C + SAVE +C + V = VAL +C +C IF VAL EQUALS ZERO EASY PROCESSING +C + IF (V.NE.0.) GO TO 20 + IOUT = '0.0' + NUSED = 3 + RETURN +C +C SCALE VALUE +C + 20 V = V*SCALE +C +C GET SIZE OF NUMBER +C + LOG = IFIX(ALOG10(ABS(V))+.1) + IF (IABS(LOG).GT.4) GO TO 60 +C +C COMPUTE FLOATING POINT FIELD +C + NS = IABS(LOG)+3 + ND = 1 + IF (LOG.GT.0) GO TO 40 +C +C LOG = 0 TEST FOR FRACTIONAL PART ONLY +C + IF (ALOG10( ABS(V) ).GE.0.) GO TO 30 +C +C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE +C + NS = 4 + ND = 1 + GO TO 40 +C +C NUMBER LESS THAN 10 BUT GE 1 +C + 30 ND = 1 + NS = 4 +C +C BUILD THE FORMAT +C + 40 IF (V.LT.0) NS = NS+1 + IFMT1 = '(F . )' +C +C INSERT THE FLOATING POINT FORMAT SIZE +C +C +NOAO - Scheme for creating format has been modified because it uses +C FTN internal writes. NOAO mods are written in lower case. +C +C WRITE(IT,'(I1)')NS +C IFMT1(3:3) = IT +C WRITE(IT,'(I1)')ND +C IFMT1(5:5) = IT +C + ifmt1(1:6) = '(f . )' + ifmt1(3:3) = char (ns + ichar ('0') + 1) + ifmt1(5:5) = char (nd + ichar ('0')) +C +C ENCODE THE DESIRED NUMBER +C +C WRITE(CHTMP,IFMT1)V +C IOUT = CHTMP +C + call encode (ns, ifmt1, iout, v) + + NUSED = NS + RETURN +C +C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED +C +C 60 WRITE(CHTMP,'(E8.3)')V +C IOUT = CHTMP +C + 60 call encode (8, '(E8.3)', iout, v) +C +C -NOAO + NUSED = 8 + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONCOM TO ULIB * +C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION * +C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM * +C* AND ERROR MESSAGE 10 * +C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/congen.f b/sys/gio/ncarutil/conlib/congen.f new file mode 100644 index 00000000..c70cfe05 --- /dev/null +++ b/sys/gio/ncarutil/conlib/congen.f @@ -0,0 +1,454 @@ + SUBROUTINE CONGEN (XI,YI,IPACK,SCRARR,ICA) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW A CONTOUR AT THE CURRENT LEVEL +C +C INPUT +C XI YI LOWER RIGHT CORNER OF CELL +C IPACK-FLAG TO ALLOW REDUCTION OF COORDINATE PAIR STORAGE +C IF REQUIRED +C SCRARR-SCRATCH ARRAY OF CONTOUR VALUES +C ICA-ENTERING CASE CONDITIONS IF ANY REQUIRED +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(1) ,IXMOV(2) ,IYMOV(2) + CHARACTER*64 IHOLD + CHARACTER*23 IVOUT + INTEGER GOOP +C + SAVE + DATA NOOP,GOOP/1,0/ +C +C STATEMENT FUNCTIONS FOR MAPPING GRAPHICS OUTPUT +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C DRAW AN ENTIRE CONTOUR LINE WHEN A POTENTIAL START POINT IS +C PROVIDED +C +C SAVE STARTING CELL +C + XCS = XI + YCS = YI +C +C TEST IF VALID START POINT +C + ICASE = ICA + XC = XI + YC = YI + CALL CONCLD (ICASE,NOOP) +C +C IF NO CONTOUR RETURN +C + IF (ICASE.EQ.-1) RETURN + IF (ICASE.EQ.0) RETURN +C +C IF CONTOUR ALREADY DRAWN RETURN +C + ILOC = IOR(ISHIFT(JX,ISHFCT),JY) + IF (NP.EQ.0) GO TO 20 +C +C TEST IF CONTOUR FOUND +C + DO 10 I=1,NP + IF (ILOC.NE.ICOORD(I)) GO TO 10 + RETURN + 10 CONTINUE +C +C GET CORRECT OLD CASE +C + 20 IC = IOC + IF (ICASE.EQ.IOC) IC = NC +C +C SET UP STRUCTURE TO START IN OTHER DIRECTION FROM HERE IF CONTOUR +C UNEXPECTLY ENDS IN THIS DIRECTION +C + IFCASE = IC + IFOCSE = ICASE + FXO = XO + FYO = YO + LOOP = 1 +C +C SET UP IC TO SIMULATE EXIT FROM A PREVIOUS CELL +C + IC = MOD(IC+2,4) +C +C IF EXTRAPOLATING PASS ON +C + IF (EXTRAP) GO TO 60 +C +C TEST IF CONTOUR EXCEEDED BORDER LIMITS +C NOTE THAT ICASER CANNOT EQUAL 3 AT THIS POINT +C + GO TO ( 30, 40, 30, 50),ICASE +C +C EXIT FROM BOTTOM +C + 30 IF (JX.GE.IXMAX) RETURN + GO TO 60 +C +C EXIT FROM LEFT +C + 40 IF (JY.LE.ITLOC(JX*2 - 1)) RETURN + GO TO 60 +C +C EXIT FROM RIGHT +C + 50 IF (JY.GE.ITLOC(JX*2 - 1)) RETURN +C +C SAVE CELL INFO IF COMMING BACK +C + 60 TRT = TR + BRT = BR + TLT = TL + BLT = BL + IX = JX + IY = JY +C +C VALID CONTOUR START FOUND +C + XX = FX(XO,YO) + CALL FRSTD (XX,FY(XO,YO)) +C +C DRAW CONTOUR IN THIS CELL +C + 70 XX = FX(XN,YN) + CALL VECTD (XX,FY(XN,YN)) + XCSTOR = XC + YCSTOR = YC + IXSTOR = IX + IYSTOR = IY + IOLDC = IC + IC = ICASE +C +C ENTER COORDINATE PAIR OF CONTOUR IN LIST +C + NP = NP+1 + IF (NP.GT.MXXY) GO TO 180 + ICOORD(NP) = ILOC +C +C BRANCH TO APPROPIATE CODE DEPENDING ON CONTOUR EXIT FROM THE CELL +C + 80 GO TO ( 90, 110, 130, 150),IC +C +C EXIT FORM BOTTOM +C END CONTOUR IF ON CONVEX HULL +C + 90 IF (EXTRAP) GO TO 100 + IF (IY.LT.ITLOC(IX*2 - 1) .OR. IY-1.GT.ITLOC(IX*2)) GO TO 360 + 100 TR = BR + TL = BL + XC = XC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IX = IX+1 + IF (IX.GT.IXMAX) GO TO 360 + BR = SCRTCH(IX,IY) + BL = SCRTCH(IX,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM LEFT SIDE +C TEST IF IN CONVEX HULL +C + 110 IF (EXTRAP) GO TO 120 + IF (IY-1.LT.ITLOC( (IX-1)*2 - 1 ) .AND. IY-1.LT.ITLOC(IX*2 - 1)) + 1 GO TO 360 + 120 TR = TL + BR = BL + YC = YC-STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY-1 + IF (IY.LT.2) GO TO 360 + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM TOP +C END CONTOUR IF OUT OF CONVEX HULL +C + 130 IF (EXTRAP) GO TO 140 + IF (IY.LT.ITLOC( (IX-1)*2 - 1 ) .OR. IY-1.GT.ITLOC( (IX-1)*2 )) + 1 GO TO 360 + 140 BR = TR + BL = TL + XC = XC-STPSZ +C +C END CONTOUR IF OUTSIDE OF BORDER +C + IX = IX-1 + IF (IX.LT.2) GO TO 360 + TR = SCRTCH(IX-1,IY) + TL = SCRTCH(IX-1,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM RIGHT SIDE +C TEST IF ON CONVEX HULL +C + 150 IF (EXTRAP) GO TO 160 + IF (IY.GT.ITLOC( (IX-1)*2 ) .AND. IY.GT.ITLOC(IX*2)) GO TO 360 + 160 TL = TR + BL = BR + YC = YC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY+1 + IF (IY.GT.IYMAX) GO TO 360 + TR = SCRTCH(IX-1,IY) + BR = SCRTCH(IX,IY) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C END THE CONTOUR +C + 170 CALL LASTD + TR = TRT + BR = BRT + TL = TLT + BL = BLT + RETURN +C +C CONTOUR STORAGE EXCEEDED TRY PACKING +C + 180 IF (IPACK.EQ.0) GO TO 200 + NP = 0 + ITEST = IOR(ISHIFT(JX,ISHFCT),JY) + DO 190 K=1,MXXY + IF (ICOORD(K).LE.ITEST) GO TO 190 + NP = NP+1 + ICOORD(NP) = ICOORD(K) + 190 CONTINUE + IF (NP.LT.MXXY) GO TO 80 +C +C FAILURE NO MORE SPACE ABORT THIS CONTOUR LEVEL +C + 200 IHOLD(1:39) = ' CONDRW-CONTOUR STORAGE EXAUSTED LEVEL=' +C +C BLANK FILL THE ENCODE ARRAY +C + IVOUT = ' ' +C +NOAO - FTN internal write rewritten as encode for IRAF. +C +C WRITE(IVOUT,'(G13.5)')CONV + call encode (13, '(g13.5)', ivout, conv) +C +C -NOAO + IHOLD(40:62) = IVOUT + CALL SETER (IHOLD,10,IREC) + RETURN +C +C BAD TIME THE CONTOUR EXITED A CORNER OF THE CELL MUST SEARCH FOR +C NEW CELL +C + 230 IXSTP = IXSTOR + IYSTP = IYSTOR + GO TO ( 240, 250, 260, 270),IOLDC +C +C PREVIOUS CELL BOTTOM EXIT +C + 240 IXSTP = IXSTP-1 + GO TO 280 +C +C PREVIOUS CELL LEFT EXIT +C + 250 IYSTP = IYSTP+1 + GO TO 280 +C +C PREVIOUS CELL TOP EXIT +C + 260 IXSTP = IXSTP+1 + GO TO 280 +C +C PREVIOUS CELL RIGHT EXIT +C + 270 IYSTP = IYSTP-1 +C +C BRANCH TO CURRENT CELL CASE +C + 280 GO TO ( 290, 300, 310, 320),IC +C +C APPARENT BOTTOM EXIT +C + 290 IXMOV(1) = 0 + IXMOV(2) = 1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT LEFT EXIT +C + 300 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = -1 + GO TO 330 +C +C APPARENT TOP EXIT +C + 310 IXMOV(1) = 0 + IXMOV(2) = -1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT RIGHT EXIT +C + 320 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = 1 +C +C SEARCH THE POSSIBLE CELLS +C + 330 DO 350 K=1,2 + DO 340 L=1,2 + XC = XCSTOR + STPSZ*FLOAT( IXMOV(K) ) + YC = YCSTOR + STPSZ*FLOAT( IYMOV(L) ) + IX = IXSTOR+IXMOV(K) + IY = IYSTOR+IYMOV(L) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C IF BACK TO START END CONTOUR +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 +C +C IF AT PREVIOUS CELL SKIP PROCESSING +C + IF (IX.EQ.IXSTP .AND. IY.EQ.IYSTP) GO TO 340 +C +C COMPUTE CELL VALUES +C + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) + TR = SCRTCH(IX-1,IY) + BL = SCRTCH(IX,IY) + ICASE = IC + CALL CONCLD (ICASE,NOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 +C +C FAILURE TRY AGAIN +C + 340 CONTINUE + 350 CONTINUE +C +C NO MORE CONTOUR TRY OTHER END OF LINE +C + 360 IF (LOOP.EQ.0) GO TO 170 + LOOP = 0 + IX = JX + IY = JY + TR = TRT + TL = TLT + BR = BRT + BL = BLT + IC = IFCASE + ICASE = IC + IOLDC = IFOCSE + XC = XI + YC = YI + IXSTOR = IX + IYSTOR = IY + YCSTOR = YI + XCSTOR = XI + XX = FX(FXO,FYO) + CALL LASTD + CALL FRSTD (XX,FY(FXO,FYO)) + GO TO ( 90, 110, 130, 150),IC + END diff --git a/sys/gio/ncarutil/conlib/conint.f b/sys/gio/ncarutil/conlib/conint.f new file mode 100644 index 00000000..84a1be82 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conint.f @@ -0,0 +1,147 @@ + SUBROUTINE CONINT (NDP,XD,YD,ZD,NCP,IPC,PD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND +C SECOND ORDER AT THE DATA POINTS. +C THE INPUT PARAMETERS ARE +C +C NDP = NUMBER OF DATA POINTS, +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z COORDI- +C NATES OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS TO BE USED FOR ESTIMATION +C OF PARTIAL DERIVATIVES AT EACH DATA POINT, +C IPC = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C NCP DATA POINTS CLOSEST TO EACH OF THE NDP DATA +C POINT. +C THE OUTPUT PARAMETER IS +C +C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED +C +C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA +C POINTS ARE TO BE STORED. +C DECLARATION STATEMENTS +C +C + DIMENSION XD(NDP) ,YD(NDP) ,ZD(NDP) ,IPC(1) , + 1 PD(1) + REAL NMX ,NMY ,NMZ ,NMXX , + 1 NMXY ,NMYX ,NMYY +C + SAVE +C +C PRELIMINARY PROCESSING +C +C + NCPM1 = NCP-1 +C +C ESTIMATION OF ZX AND ZY +C +C + DO 130 IP0=1,NDP + X0 = XD(IP0) + Y0 = YD(IP0) + Z0 = ZD(IP0) + NMX = 0.0 + NMY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 120 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + DZ1 = ZD(IPI)-Z0 + IC2MN = IC1+1 + DO 110 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 110 + DZ2 = ZD(IPI)-Z0 + DNMX = DY1*DZ2-DZ1*DY2 + DNMY = DZ1*DX2-DX1*DZ2 + IF (DNMZ .GE. 0.0) GO TO 100 + DNMX = -DNMX + DNMY = -DNMY + DNMZ = -DNMZ + 100 NMX = NMX+DNMX + NMY = NMY+DNMY + NMZ = NMZ+DNMZ + 110 CONTINUE + 120 CONTINUE + JPD0 = 5*IP0 + PD(JPD0-4) = -NMX/NMZ + PD(JPD0-3) = -NMY/NMZ + 130 CONTINUE +C +C ESTIMATION OF ZXX, ZXY, AND ZYY +C +C + DO 170 IP0=1,NDP + JPD0 = JPD0+5 + X0 = XD(IP0) + JPD0 = 5*IP0 + Y0 = YD(IP0) + ZX0 = PD(JPD0-4) + ZY0 = PD(JPD0-3) + NMXX = 0.0 + NMXY = 0.0 + NMYX = 0.0 + NMYY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 160 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + JPD = 5*IPI + DZX1 = PD(JPD-4)-ZX0 + DZY1 = PD(JPD-3)-ZY0 + IC2MN = IC1+1 + DO 150 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 150 + JPD = 5*IPI + DZX2 = PD(JPD-4)-ZX0 + DZY2 = PD(JPD-3)-ZY0 + DNMXX = DY1*DZX2-DZX1*DY2 + DNMXY = DZX1*DX2-DX1*DZX2 + DNMYX = DY1*DZY2-DZY1*DY2 + DNMYY = DZY1*DX2-DX1*DZY2 + IF (DNMZ .GE. 0.0) GO TO 140 + DNMXX = -DNMXX + DNMXY = -DNMXY + DNMYX = -DNMYX + DNMYY = -DNMYY + DNMZ = -DNMZ + 140 NMXX = NMXX+DNMXX + NMXY = NMXY+DNMXY + NMYX = NMYX+DNMYX + NMYY = NMYY+DNMYY + NMZ = NMZ+DNMZ + 150 CONTINUE + 160 CONTINUE + PD(JPD0-2) = -NMXX/NMZ + PD(JPD0-1) = -(NMXY+NMYX)/(2.0*NMZ) + PD(JPD0) = -NMYY/NMZ + 170 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlcm.f b/sys/gio/ncarutil/conlib/conlcm.f new file mode 100644 index 00000000..80791d49 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlcm.f @@ -0,0 +1,65 @@ + FUNCTION CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE A Z VALUE FOR A GIVEN X,Y VALUE +C NOTE THAT X,Y MUST BE INSIDE THE CONVEX HULL OF THE INPUT DATA +C INORDER FOR THIS FUNCTION TO WORK. +C +C INPUT +C X-X COORDINATE OF REQUESTED POINT +C Y-Y COORDINATE OF REQUESTED POINT +C WK-LIST OF COEFICENTS FOR LINEAR INTERPOLATION FUNCTIONS +C LOCATED BY A = WK((TRI-1)*3+1) +C B = WK((TRI-2)*3+1) +C C = WK((TRI-3)*3+1) +C +C OUTPUT +C LOC-TRIANGLE NUMBER OF REQUESTED POINT +C Z VALUE AS FUNCTION RESULT +C + DIMENSION WK(1),IWK(1),XD(1),YD(1),ZD(1) +C + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV +C + SAVE +C +C LOCATE THE TRIANGLE +C + CALL CONLOC(NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),X,Y,LOC, + 1 IWK(JWIWL),WK) +C +C IF OUTSIDE CONVEX HULL THEN DON'T COMPUTE A VALUE +C + IF (LOC.GT.NT) RETURN +C +C GET THE VECTOR 1 VALUES FOR THE TRIANGLE +C + IVEC = (LOC-1)*3 + JWIPT + IV = IWK(IVEC) + X1 = X - XD(IV) + Y1 = Y - YD(IV) + Z1 = ZD(IV) +C +C COMPUT THE Z VALUE +C + IPOINT = (LOC-1)*3 + IPR +C + Z = (WK(IPOINT)*X1+WK(IPOINT+1)*Y1)/WK(IPOINT+2) + Z1 +C + CONLCM = Z +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlin.f b/sys/gio/ncarutil/conlib/conlin.f new file mode 100644 index 00000000..f940d48c --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlin.f @@ -0,0 +1,68 @@ + SUBROUTINE CONLIN(XD,YD,ZD,NT,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE GENERATES THE COORDINATES USED IN A LINEAR INTERPOLATION +C OF THE TRIANGLES CREATED FROM IRREGULARLY DISTRIBUTED DATA. +C +C INPUT +C XD-X INPUT COORDINATES] +C YD-Y INPUT COORDINATES +C ZD-Z VALUE AT INPUT X,Y +C NT-NUMBER OF TRIANGLES GENERATED +C IWK-LIST OF TRIANGLE POINTS, RELATIVE TO XD,YD +C GROUPED 3 PER TRIANGLE I.E. TRIANGLE 1 IWK(1,2,3), +C TRIANGLE 2 IWK(4,5,6) ETC. +C +C OUTPUT +C WK ARRAY OF COEFICENTS FOR LINEATION FORMUALS +C GROUPED 3 PER TRIANGLE +C POINTS ARE (TRI-1)*3 + 1,2,3 +C + DIMENSION IWK(1),WK(1),XD(1),YD(1),ZD(1) +C + SAVE +C +C LOOP FOR ALL TRIANGLES +C + DO 1000 ITRI = 1,NT +C +C GET THE POINTS OF THE TRIANGLE +C + IPOINT = (ITRI-1)*3 + IP1 = IWK(IPOINT+1) + IP2 = IWK(IPOINT+2) + IP3 = IWK(IPOINT+3) +C +C GET THE VALUES AT THE TRIANBGLE POINTS +C + X1 = XD(IP1) + Y1 = YD(IP1) + Z1 = ZD(IP1) + X2 = XD(IP2) + Y2 = YD(IP2) + Z2 = ZD(IP2) + X3 = XD(IP3) + Y3 = YD(IP3) + Z3 = ZD(IP3) +C +C COMPUTE THE INTERPLOATING COEFICIENTS +C + WK(IPOINT+1) = (Y2-Y1)*(Z3-Z1)-(Y3-Y1)*(Z2-Z1) + WK(IPOINT+2) = (X3-X1)*(Z2-Z1)-(X2-X1)*(Z3-Z1) + WK(IPOINT+3) = (X3-X1)*(Y2-Y1)-(X2-X1)*(Y3-Y1) +C + 1000 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conloc.f b/sys/gio/ncarutil/conlib/conloc.f new file mode 100644 index 00000000..5907c9df --- /dev/null +++ b/sys/gio/ncarutil/conlib/conloc.f @@ -0,0 +1,256 @@ + SUBROUTINE CONLOC (NDP,XD,YD,NT,IPT,NL,IPL,XII,YII,ITI,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE LOCATES A POINT, I.E., DETERMINES TO WHAT TRI- +C ANGLE A GIVEN POINT (XII,YII) BELONGS. WHEN THE GIVEN POINT +C DOES NOT LIE INSIDE THE DATA AREA, THIS SUBROUTINE DETERMINES +C THE BORDER LINE SEGMENT WHEN THE POINT LIES IN AN OUTSIDE +C RECTANGULAR AREA, AND TWO BORDER LINE SEGMENTS WHEN THE POINT +C LIES IN AN OUTSIDE TRIANGULAR AREA. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y +C COORDINATES OF THE DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE +C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE +C POINT NUMBERS OF THE END POINTS OF THE BORDER +C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE +C NUMBERS, +C XII,YII = X AND Y COORDINATES OF THE POINT TO BE +C LOCATED. +C THE OUTPUT PARAMETER IS +C ITI = TRIANGLE NUMBER, WHEN THE POINT IS INSIDE THE +C DATA AREA, OR +C TWO BORDER LINE SEGMENT NUMBERS, IL1 AND IL2, +C CODED TO IL1*(NT+NL)+IL2, WHEN THE POINT IS +C OUTSIDE THE DATA AREA. +C THE OTHER PARAMETERS ARE +C IWK = INTEGER ARRAY OF DIMENSION 18*NDP USED INTER- +C NALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + DIMENSION XD(1) ,YD(1) ,IPT(1) ,IPL(1) , + 1 IWK(1) ,WK(1) +C +C +C + DIMENSION NTSC(9) ,IDSC(9) + COMMON /CONRA5/ NIT ,ITIPV +C + SAVE +C +C STATEMENT FUNCTIONS +C + SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3)-(V1-V3)*(U2-U3) + SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2)+(V1-V2)*(V3-V2) +C +C PRELIMINARY PROCESSING +C + NT0 = NT + NL0 = NL + NTL = NT0+NL0 + X0 = XII + Y0 = YII +C +C PROCESSING FOR A NEW SET OF DATA POINTS +C + IF (NIT .NE. 0) GO TO 170 + NIT = 1 +C +C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. +C + XMN = XD(1) + XMX = XMN + YMN = YD(1) + YMX = YMN + DO 100 IDP=2,NDP + XI = XD(IDP) + YI = YD(IDP) + XMN = AMIN1(XI,XMN) + XMX = AMAX1(XI,XMX) + YMN = AMIN1(YI,YMN) + YMX = AMAX1(YI,YMX) + 100 CONTINUE + XS1 = (XMN+XMN+XMX)/3.0 + XS2 = (XMN+XMX+XMX)/3.0 + YS1 = (YMN+YMN+YMX)/3.0 + YS2 = (YMN+YMX+YMX)/3.0 +C +C - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF +C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. +C + DO 110 ISC=1,9 + NTSC(ISC) = 0 + IDSC(ISC) = 0 + 110 CONTINUE + IT0T3 = 0 + JWK = 0 + DO 160 IT0=1,NT0 + IT0T3 = IT0T3+3 + I1 = IPT(IT0T3-2) + I2 = IPT(IT0T3-1) + I3 = IPT(IT0T3) + XMN = AMIN1(XD(I1),XD(I2),XD(I3)) + XMX = AMAX1(XD(I1),XD(I2),XD(I3)) + YMN = AMIN1(YD(I1),YD(I2),YD(I3)) + YMX = AMAX1(YD(I1),YD(I2),YD(I3)) + IF (YMN .GT. YS1) GO TO 120 + IF (XMN .LE. XS1) IDSC(1) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(2) = 1 + IF (XMX .GE. XS2) IDSC(3) = 1 + 120 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 130 + IF (XMN .LE. XS1) IDSC(4) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(5) = 1 + IF (XMX .GE. XS2) IDSC(6) = 1 + 130 IF (YMX .LT. YS2) GO TO 140 + IF (XMN .LE. XS1) IDSC(7) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(8) = 1 + IF (XMX .GE. XS2) IDSC(9) = 1 + 140 DO 150 ISC=1,9 + IF (IDSC(ISC) .EQ. 0) GO TO 150 + JIWK = 9*NTSC(ISC)+ISC + IWK(JIWK) = IT0 + NTSC(ISC) = NTSC(ISC)+1 + IDSC(ISC) = 0 + 150 CONTINUE +C +C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND +C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. +C + JWK = JWK+4 + WK(JWK-3) = XMN + WK(JWK-2) = XMX + WK(JWK-1) = YMN + WK(JWK) = YMX + 160 CONTINUE + GO TO 200 +C +C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. +C + 170 IT0 = ITIPV + IF (IT0 .GT. NT0) GO TO 180 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF ON THE SAME BORDER LINE SEGMENT. +C + 180 IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (IL2 .NE. IL1) GO TO 190 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. +C + 190 IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 260 +C +C LOCATES INSIDE THE DATA AREA. +C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. +C + 200 ISC = 1 + IF (X0 .GE. XS1) ISC = ISC+1 + IF (X0 .GE. XS2) ISC = ISC+1 + IF (Y0 .GE. YS1) ISC = ISC+3 + IF (Y0 .GE. YS2) ISC = ISC+3 +C +C - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. +C + NTSCI = NTSC(ISC) + IF (NTSCI .LE. 0) GO TO 220 + JIWK = -9+ISC + DO 210 ITSC=1,NTSCI + JIWK = JIWK+9 + IT0 = IWK(JIWK) + JWK = IT0*4 + IF (X0 .LT. WK(JWK-3)) GO TO 210 + IF (X0 .GT. WK(JWK-2)) GO TO 210 + IF (Y0 .LT. WK(JWK-1)) GO TO 210 + IF (Y0 .GT. WK(JWK)) GO TO 210 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 210 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 210 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 210 + GO TO 260 + 210 CONTINUE +C +C LOCATES OUTSIDE THE DATA AREA. +C + 220 DO 240 IL1=1,NL0 + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 240 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 230 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 240 + IL2 = IL1 + GO TO 250 + 230 IL2 = MOD(IL1,NL0)+1 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 250 + 240 CONTINUE + IT0 = 1 + GO TO 260 + 250 IT0 = IL1*NTL+IL2 +C +C NORMAL EXIT +C + 260 ITI = IT0 + ITIPV = IT0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlod.f b/sys/gio/ncarutil/conlib/conlod.f new file mode 100644 index 00000000..d7fc3804 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlod.f @@ -0,0 +1,194 @@ + SUBROUTINE CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION SCRARR(1) +C + SAVE +C +C IFR - FLAG TO REGISTER FIRST PASS IN Y DIRECTION +C +C LOAD THE SCRATCH SPACE AND CONVEX HULL POINTERS +C ITLOC IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO THE SCARTCH +C SPACE. +C PV IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO USER COORDINATES +C +C INITALIZE THE SPECIAL VALUE FEATURE +C + X = (XED-XST)/2. + XST + Y = (YED-YST)/2. + YST + IF(LINEAR) GO TO 1 + SPVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 2 + 1 SPVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 2 CONTINUE +C +C INITIALIZE THE SEARCH +C + IYMAX = 0 + IFR = 1 + JX = 1 + X = XST + 10 JY = 1 + Y = YST +C +C SET HULL POINTERS FOR THIS COLUMN TO NULL +C + ITLOC(JX*2-1) = 0 + ITLOC(JX*2) = 0 +C +C FLAG START OF COLUMN +C + LOOP = 1 +C +C GET INTERPOLATED VALUE +C + 20 IF (LINEAR) GO TO 3 + RVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 4 + 3 RVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 4 CONTINUE + SCRARR(JY+(JX-1)*IYMAX) = RVAL + IF (RVAL.GT.SPVAL) SPVAL = RVAL +C +C IF OUTSIDE CONVEX HULL BRANCH +C + IF (IT.GT.NTNL) GO TO 30 +C +C IF OUTSIDE TRIANGLES AND USING LINEAR INTERPLOATION THEN BRANCH +C + IF(LINEAR.AND.IT.GT.NT) GO TO 30 +C +C IF FIRST OF COLUMN IN HULL CONTINUE THROUGH +C + IF (LOOP.NE.1) GO TO 40 +C +C SET HULL POINTERS +C + PV(JX*2-1) = Y + ITLOC(JX*2-1) = JY +C +C SET FLAG TO LOOK FOR END OF HULL IN COLUMN +C + LOOP = 2 +C +C GO FOR NEXT ENTRY +C + GO TO 40 +C +C TEST FOR END OF CONVEX HULL ON THIS ROW +C + 30 IF (LOOP.NE.2) GO TO 40 +C +C END OF HULL SET POINTERS FOR END OF HULL AND FLAG IT VIA LOOP +C + LOOP = 0 + ITLOC(JX*2) = JY-1 + PV(JX*2) = Y-STPSZ +C +C GET NEXT ELEMENT IN ROW IF NOT OUTSIDE ENCLOSING RECTANGULAR +C BOARDER +C + 40 Y = Y+STPSZ + JY = JY+1 + IF (Y.LE.YED) GO TO 20 +C +C TEST FOR FIRST COLUMN +C + IF (IFR.NE.1) GO TO 50 +C +C FIRST COLUMN OVER SET MAX Y VALUES +C + IYMAX = JY-1 + YMAX = Y-STPSZ + IFR = 0 +C +C IF HULL WENT TO EDGE OF RECTANGULAR BOARDER SET HULL POINTERS HERE +C + 50 IF (LOOP.NE.2) GO TO 60 + PV(JX*2) = Y-STPSZ + ITLOC(JX*2) = JY-1 +C +C END OF COLUMN GET NEXT ONE +C + 60 X = X+STPSZ + JX = JX+1 +C +C IF NOT END OF WORK CONTINUE WITH NEXT COLUMN +C + IF (X.LE.XED) GO TO 10 +C +C END OF WORK SET MAX X VALUES +C + IXMAX = JX-1 + XMAX = X-STPSZ + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop1.f b/sys/gio/ncarutil/conlib/conop1.f new file mode 100644 index 00000000..fc61872d --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop1.f @@ -0,0 +1,465 @@ + SUBROUTINE CONOP1 (IOPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +c +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE OPTION AND ITS VALUE +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C REP FOUND CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'RE') THEN +C +C SWITCH = ON CONTOUR SAME DATA +C + IF (OPT .EQ. 'ON') THEN + REPEAT = .TRUE. + RETURN +C +C SWITCH = OFF CONTOUR NEW DATA +C + ELSEIF (OPT .EQ. 'OF') THEN + REPEAT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXTRAPOLATION FLAG +C + ELSEIF (TAG .EQ. 'EX') THEN +C +C SWITCH = ON EXTRAPOLATE WHEN CONTOURING +C + IF (OPT .EQ. 'ON') THEN + EXTRAP = .TRUE. + RETURN +C +C SWITCH = OFF INTERPOLATE ONLY +C + ELSEIF (OPT .EQ. 'OF') THEN + EXTRAP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PER FOUND SET PERIMETER +C + ELSEIF (TAG .EQ. 'PE') THEN +C +C SWITCH = ON DRAW PERIMETERS +C + IF (OPT .EQ. 'ON') THEN + PER = .TRUE. +C +C TURN GRID OFF, USER WANTS PERIMETER +C + GRD = .FALSE. + RETURN +C +C SWITCH = OFF DO NOT DRAW PERIMETERS +C + ELSEIF (OPT .EQ. 'OF') THEN + PER = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C DEF FOUND SET ALL OPTIONS TO DEFAULT (NO SWITCHES) +C + ELSEIF (TAG .EQ. 'DE') THEN + PER = .TRUE. + LISTOP = .FALSE. + PMIMX = .FALSE. + SCALE = 1. + TENSN = TENS + EXTRAP = .FALSE. + TITLE = .FALSE. + ITLSIZ = 16 + REPEAT = .FALSE. + MESS = .TRUE. + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. + IGRAD = IG + ISCALE = 0 + NCP = 4 + LOOK = .FALSE. + GRD = .FALSE. + PLDVLS = .FALSE. + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + BPSIZ = 0. + LABON = .TRUE. + ISIZEL = 9 + ISIZEP = 8 + ISIZEM = 15 + FRADV = .TRUE. + EXTRI = .FALSE. + MINGAP = 3 + LINEAR = .FALSE. + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. +C +C SET DEFAULT DASH PATTERN +C + IDASH = '$$$$$$$$$$' + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' +C +C SET DEFAULT FORMAT +C + FORM = '(G10.3)' + RETURN +C +C MES FOUND TEST VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'ME') THEN +C +C ACTIVATE CONRAN MESSAGE +C + IF (OPT .EQ. 'ON') THEN + MESS = .TRUE. + RETURN +C +C TURN OFF CONRAN MESSAGE +C + ELSEIF (OPT .EQ. 'OF') THEN + MESS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALING OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'SC') THEN +C +C SET VALUE OF SCALE FLAG +C + IF (OPT .EQ. 'ON') THEN + ISCALE = 0 + RETURN + ELSEIF (OPT .EQ. 'OF') THEN + ISCALE = 1 + RETURN + ELSEIF (OPT .EQ. 'PR') THEN + ISCALE = 2 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TRIANGLE FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'TR') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + LOOK = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + LOOK = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT DATA VALUES FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'PD') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + PLDVLS = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + PLDVLS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C GRID OPTION ACTIVATED GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'GR') THEN +C +C SWITCH ON SET GRID FLAG +C + IF (OPT .EQ. 'ON') THEN + GRD = .TRUE. +C +C TURN PER OFF USER WANTS GRID +C + PER = .FALSE. + RETURN +C +C SWITCH OFF CLEAR GRID FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + GRD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL PLOTTING FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LA') THEN +C +C SWITCH ON LABEL CONTOURS +C + IF (OPT .EQ. 'ON') THEN + LABON = .TRUE. + RETURN +C +C SWITCH OFF DON"T LABEL CONTOURS +C + ELSEIF (OPT .EQ. 'OF') THEN + LABON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT THE RELATIVE MIN"S AND MAX"S +C + ELSEIF (TAG .EQ. 'PM') THEN +C +C SWTICH ON PLOT THE INFO +C + IF (OPT .EQ. 'ON') THEN + PMIMX = .TRUE. + RETURN +C +C SWTICH OFF DO NOT PLOT THE INFO +C + ELSEIF (OPT .EQ. 'OF') THEN + PMIMX = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C ADVANCE FRAME BEFORE TRIANGULATION PLOT +C + ELSEIF (TAG .EQ. 'TF') THEN +C +C SWITCH ON ADVANCE FRAME +C + IF (OPT .EQ. 'ON') THEN + FRADV = .TRUE. + RETURN +C +C SWITCH OFF DO NOT ADVANCE FRAME +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXIT AFTER TRIANGULATION +C + ELSEIF (TAG .EQ. 'TO') THEN +C +C SWITCH ON EXIT AFTER TRIANGULATION +C + IF (OPT .EQ. 'ON') THEN + EXTRI = .TRUE. + LOOK = .TRUE. + FRADV = .FALSE. + RETURN +C +C SWITCH OFF DO NOT EXIT AFTER TRIANGULATION +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .TRUE. + LOOK = .FALSE. + EXTRI = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LIST OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LO') THEN +C +C ON SET LIST OPTIONS FLAG +C + IF (OPT .EQ. 'ON') THEN + LISTOP = .TRUE. + RETURN +C +C TURN OFF LIST OPTIONS FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + LISTOP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE INTERPOLATION SCHEME +C + ELSEIF (TAG .EQ. 'IT') THEN +C +C SET TO C1 SURFACE +C + IF (OPT .EQ. 'C1') THEN + LINEAR = .FALSE. + RETURN +C +C SET TO LINEAR INTERPOLATION +C + ELSEIF (OPT .EQ. 'LI') THEN + LINEAR = .TRUE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE SHIELD PLOT FLAG +C + ELSEIF (TAG .EQ. 'PS') THEN +C +C TURN ON SHIELD PLOT +C + IF (OPT .EQ. 'ON') THEN + SLDPLT = .TRUE. + RETURN +C +C TURN OFF SHIELD PLOT +C + ELSEIF (OPT .EQ. 'OF') THEN + SLDPLT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP1 -- UNDEFINED OPTION',1,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conop2.f b/sys/gio/ncarutil/conlib/conop2.f new file mode 100644 index 00000000..41dc27c3 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop2.f @@ -0,0 +1,316 @@ + SUBROUTINE CONOP2 (IOPT,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ISIZE- INTEGER INPUT +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C SET RESOLUTION OF VIRTUAL GRID +C + IF (TAG .EQ. 'SS') THEN +C +C SWITCH = ON SET RESOLUTION OF VIRTUAL GRID +C + IF (OPT .EQ. 'ON') THEN + IGRAD = ISIZE + RETURN +C +C SWITCH = OFF RESET RESOLUTION TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + IGRAD = IG + RETURN + ELSE + GOTO 120 + ENDIF +C +C NCP OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'NC') THEN +C +C SWITCH ON GET VALUE FOR NUMBER OF SURROUNDING DATA POINTS TO USE +C + IF (OPT .EQ. 'ON') THEN + NCP = ISIZE + RETURN +C +C SWITCH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + NCP = 4 + RETURN + ELSE + GOTO 120 + ENDIF +C +C INTENSITY OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'IN') THEN +C +C SWITCH OFF SET DEFAULT VALUES +C + IF (OPT .EQ. 'OF') THEN + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + RETURN +C +C SET PLOTTED DATA INTENSITY +C + ELSEIF (OPT .EQ. 'DA') THEN + INDAT = ISIZE + RETURN +C +C SET TITLE AND MESSAGE INTENSITY +C + ELSEIF (OPT .EQ. 'LA') THEN + INLAB = ISIZE + IRANTX = ISIZE + IRASTX = ISIZE + IRAQTX = ISIZE + RETURN +C +C SET ALL INTENSITIES TO THE SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IRANMJ = ISIZE + IRANMN = ISIZE + IRANTX = ISIZE + IRASMJ = ISIZE + IRASMN = ISIZE + IRASTX = ISIZE + IRAQMJ = ISIZE + IRAQMN = ISIZE + IRAQTX = ISIZE + INMAJ = ISIZE + INMIN = ISIZE + INLAB = ISIZE + INDAT = ISIZE + RETURN +C +C SET MAJOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MA') THEN + IRANMJ = ISIZE + IRASMJ = ISIZE + IRAQMJ = ISIZE + INMAJ = ISIZE + RETURN +C +C SET MINOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MI') THEN + IRANMN = ISIZE + IRASMN = ISIZE + IRAQMN = ISIZE + INMIN = ISIZE + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL SIZE OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LS') THEN +C +C SWITCH ON GET USER LABEL SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEL = ISIZE + RETURN +C +C SWITCH OFF SET LABEL SIZE TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEL = 9 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZES OF MINIMUM AND MAXIMUM LABELS +C + ELSEIF (TAG .EQ. 'SM') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEM = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEM = 15 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZE OF THE PLOTTED DATA +C + ELSEIF (TAG .EQ. 'SP') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEP = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEP = 8 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TITLE SIZE SWITCH +C + ELSEIF (TAG .EQ. 'ST') THEN +C +C SWITCH ON SET THE TITLE SIZE +C + IF (OPT .EQ. 'ON') THEN + ITLSIZ = ISIZE + RETURN +C +C SWITCH OFF SET TITLE SIZE TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ITLSIZ = 16 + RETURN + ELSE + GOTO 120 + ENDIF +C +C MINOR LINE COUNT OPTION +C + ELSEIF (TAG .EQ. 'MI') THEN +C +C SET MINOR LINE COUNT +C + IF (OPT .EQ. 'ON') THEN + MINGAP = ISIZE+1 + RETURN +C +C SET MINOR LINE COUNT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + MINGAP = 3 + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP2 - UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop3.f b/sys/gio/ncarutil/conlib/conop3.f new file mode 100644 index 00000000..e4632478 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop3.f @@ -0,0 +1,266 @@ + SUBROUTINE CONOP3 (IOPT,ARRAY,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ARRAY- REAL ARRAY OF DIMENSION ISIZE +C ISIZE- SIZE OF ARRAY +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + DIMENSION ARRAY(ISIZE) + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C CON CONTOUR LEVELS CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'CO') THEN +C +C SWITCH = ON SET CONTOUR LEVELS +C + IF (OPT .EQ. 'ON') THEN + IF (CHILO .OR. CINC) GOTO 140 +C +C TEST IF NUMBER OF CONTOURS IS ACCEPTABLE +C + IF (ISIZE .GT. 30) + 1 CALL SETER (' CONOP3-NUMBER OF CONTOUR LEVELS EXCEEDS 30', + 2 1,1) + DO 200 I=1,ISIZE + CL(I) = ARRAY(I) + 200 CONTINUE + CON = .TRUE. + NCL = ISIZE + RETURN +C +C SWITCH = OFF CLEAR CONTOUR LEVEL ARRAY (PROGRAM SELECTS) +C + ELSEIF (OPT .EQ. 'OF') THEN + CON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR HI LO OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CH') THEN +C +C SWITCH ON SET HI AND FLO +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + HI = ARRAY(1) + FLO = ARRAY(2) + CHILO = .TRUE. + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CHILO = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR INCREMENT OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CI') THEN +C +C SWITCH ON SET INCREMENT +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + CINC = .TRUE. + FINC = ARRAY(1) + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CINC = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALE THE DATA PLOTTED ON THE CONTOURS AND MIN MAX POINTS +C + ELSEIF (TAG .EQ. 'SD') THEN +C +C SWTICH ON GET SCALE FACTOR +C + IF (OPT .EQ. 'ON') THEN + SCALE = ARRAY(1) + RETURN +C +C SWTICH OFF SET FOR NO SCALING +C + ELSEIF (OPT .EQ. 'OF') THEN + SCALE = 1. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE TENSION VALUE FOR SMOOTHING +C + ELSEIF (TAG .EQ. 'TE') THEN +C +C SWTICH ON SET TENSION FACTOR +C + IF (OPT .EQ. 'ON') THEN + TENSN = ARRAY(1) + RETURN +C +C SWTICH OFF SET TO DEFAULT TENSION +C + ELSEIF (OPT .EQ. 'OF') THEN + TENSN = TENS + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN BREAK POINT SWITCH +C + ELSEIF (TAG .EQ. 'DB') THEN +C +C SWITCH ON GET USERS BREAKPOINT +C + IF (OPT .EQ. 'ON') THEN + BPSIZ = ARRAY(1) + RETURN +C +C SWITCH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + BPSIZ = 0. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SHIELD OPTION +C + ELSEIF (TAG .EQ. 'SL') THEN +C +C TURN SHIELDING ON AND SET THE SHIELD COORD POINTERS +C + IF (OPT .EQ. 'ON') THEN + NISIZE = ISIZE/2 + CALL CONSSD(ARRAY(1),ARRAY(NISIZE+1),NISIZE) + RETURN +C +C DEACTIVATE SHIELDING +C + ELSEIF (OPT .EQ. 'OF') THEN + ICOUNT = 0 + SHIELD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP3-UNDEFINED OPTION',1,1) + RETURN +C +C ILLEGAL USE OF CON WITH CIL OR CHL +C + 140 CALL SETER + 1('CONOP3-ILLEGAL USE OF CON OPTION WITH CIL OR CHL OPTION', + 2 1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop4.f b/sys/gio/ncarutil/conlib/conop4.f new file mode 100644 index 00000000..f963dcf9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop4.f @@ -0,0 +1,197 @@ + SUBROUTINE CONOP4 (IOPT,ARRAY,ISIZE,IFORT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT -- CHARACTER STRING OF OPTION VALUE +C ARRAY -- CHARACTER INPUT DATA +C ISIZE -- INTEGER INPUT +C IFORT -- INTEGER. THIS VALUE IS USED ONLY WHEN IOPT IS +C "FMT=ON". IN THIS CASE, IFORT IS THE TOTAL NUMBER +C OF CHARACTERS TO BE PROCESSED BY THE FORMAT +C STATEMENT. FOR EXAMPLE, FOR THE FORMAT "F10.3", +C IFORT SHOULD BE SET TO 10. +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*(*) ARRAY + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C TITLE OPTION GET VALUE OF SWITCH +C + IF (TAG .EQ. 'TL') THEN +C +C SWITCH ON GET TITLE AND COUNT FROM INPUT +C + IF (OPT .EQ. 'ON') THEN + TITLE = .TRUE. + ISTRNG = ARRAY + ICNT = ISIZE + RETURN +C +C SWITCH OFF OPTION DEACTIVATED +C + ELSEIF (OPT .EQ. 'OF') THEN + TITLE = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CHANGE DATA VALUE FORMAT +C + ELSEIF (TAG .EQ. 'FM') THEN +C +C SWITCH ON GET USER FORMAT +C + IF (OPT .EQ. 'ON') THEN + FORM = ARRAY + LEN = ISIZE + IFMT = IFORT + RETURN +C +C SWITCH OFF SET FORMAT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'DA') THEN +C +C SWITCH OFF DEFAULT PATTERNS +C + IF (OPT .EQ. 'OF') THEN + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' + IDASH = '$$$$$$$$$$' + RETURN +C +C SWITCH ALL SET GTR,LSS,AND EQU TO SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IDASH = ARRAY + EDASH = ARRAY + NDASH = ARRAY + RETURN +C +C SWITCH SET TO POS CHANGE POS DASH PATTERN +C + ELSEIF (OPT .EQ. 'GT') THEN + IDASH = ARRAY + RETURN +C +C SWITCH SET TO NEG SET NEG DASH PATTERN +C + ELSEIF (OPT .EQ. 'LS') THEN + NDASH = ARRAY + RETURN +C +C SWITCH SET TO EQU SET EQUAL DASH PATTERN +C + ELSEIF (OPT .EQ. 'EQ') THEN + EDASH = ARRAY + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP4-UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conot2.f b/sys/gio/ncarutil/conlib/conot2.f new file mode 100644 index 00000000..f2bc6aed --- /dev/null +++ b/sys/gio/ncarutil/conlib/conot2.f @@ -0,0 +1,178 @@ + SUBROUTINE CONOT2 (IVER,IUNIT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C OUTPUT THE OPTION VALUES TO THE LINE PRINTER +C +C CONTINUE FOR CONRAN AND CONRAS +C +C +C +C COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , +C 1 FINC ,HI ,FLO +C COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , +C 1 ISCALE ,LOOK ,PLDVLS ,GRD , +C 2 CINC ,CHILO ,CON ,LABON , +C 3 PMIMX ,SCALE ,FRADV ,EXTRI , +C 4 BPSIZ ,LISTOP +C COMMON /CONRA3/ IREC +C COMMON /CONRA4/ NCP ,NCPSZ +C COMMON /CONRA5/ NIT ,ITIPV +C COMMON /CONRA6/ XST ,YST ,XED ,YED , +C 1 STPSZ ,IGRAD ,IG ,XRG , +C 2 YRG ,BORD ,PXST ,PYST , +C 3 PXED ,PYED ,ITICK +C COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ +C COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , +C 1 LEN ,IFMT ,LEND , +C 2 IFMTD ,ISIZEP ,INMIN +C COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , +C 1 BR ,TL ,BL ,CONV , +C 2 XN ,YN ,ITLL ,IBLL , +C 3 ITRL ,IBRL ,XC ,YC , +C 4 ITLOC(210) ,JX ,JY ,ILOC , +C 5 ISHFCT ,XO ,YO ,IOC ,NC +C COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , +C 1 JWIWL ,JWIWP ,JWIPL ,IPR , +C 2 ITPV +C COMMON /CONR11/ NREP ,NCRT ,ISIZEL , +C 1 MINGAP ,ISIZEM , +C 2 TENS +C COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX +C LOGICAL REPEAT ,EXTRAP ,PER ,MESS , +C 1 LOOK ,PLDVLS ,GRD ,LABON , +C 2 PMIMX ,FRADV ,EXTRI ,CINC , +C 3 TITLE ,LISTOP ,CHILO ,CON +C COMMON /CONR15/ ISTRNG +C CHARACTER*64 ISTRNG +C COMMON /CONR16/ FORM +C CHARACTER*10 FORM +C COMMON /CONR17/ NDASH, IDASH, EDASH +C CHARACTER*10 NDASH, IDASH, EDASH +C +C +C SAVE +C +C LABEL THE CONTOURS +C +C WRITE (IUNIT,1001) +C IF (LABON) GO TO 100 +C WRITE (IUNIT,1002) +C GO TO 110 +C 100 WRITE (IUNIT,1003) +C +C LABEL SIZE +C +C 110 WRITE (IUNIT,1004) ISIZEL +C +C SCALE DATA ON CONTOURS +C +C WRITE (IUNIT,1005) +C IF (SCALE .NE. 1.) GO TO 120 +C WRITE (IUNIT,1006) +C GO TO 130 +C 120 WRITE (IUNIT,1007) SCALE +C +C TENSION FACTOR +C +C 130 WRITE (IUNIT,1008) TENS +C +C PLOT RELATIVE MINS AND MAXS +C +C WRITE (IUNIT,1009) +C IF (PMIMX) GO TO 140 +C WRITE (IUNIT,1010) +C GO TO 150 +C 140 WRITE (IUNIT,1011) +C +C SIZE OF MINIMUM AND MAXIMUM LABELS +C +C 150 WRITE (IUNIT,1012) ISIZEM +C +C DASH PATTERN +C +C WRITE (IUNIT,1013) +C IF (IDASH(1:1) .EQ. ' ') GO TO 170 +C WRITE (IUNIT,1014) IDASH +C GO TO 180 +C 170 WRITE (IUNIT,1015) +C 180 IF (EDASH(1:1) .EQ. ' ') GO TO 200 +C WRITE (IUNIT,1016) EDASH +C GO TO 210 +C 200 WRITE (IUNIT,1017) +C 210 IF (NDASH(1:1) .EQ. ' ') GO TO 230 +C WRITE (IUNIT,1018) NDASH +C GO TO 240 +C 230 WRITE (IUNIT,1019) +C +C DASH PATTERN BREAK POINT +C +C 240 WRITE (IUNIT,1020) BPSIZ +C +C PRINT MINOR LINE GAP +C +C ITT = MINGAP-1 +C WRITE (IUNIT,1021) ITT +C RETURN +C +C 1001 FORMAT (5X,'LABEL THE CONTOURS, LAB=') +C 1002 FORMAT ('+',28X,'OFF') +C 1003 FORMAT ('+',28X,'ON') +C 1004 FORMAT (5X,'CONTOUR LABEL SIZE IN PWRIT UNITS, LSZ=',I4) +C 1005 FORMAT (5X,'SCALE THE DATA ON CONTOUR LINES, SDC=') +C 1006 FORMAT ('+',41X,'OFF') +C 1007 FORMAT ('+','ON, SCALE FACTOR=',G10.3) +C 1008 FORMAT (5X,'TENSION FACTOR (USED FOR SMOOTH AND SUPER), TEN=', +C 1 F6.2) +C 1009 FORMAT (5X,'PLOT RELATIVE MINIMUMS AND MAXIMUMS, PMM=') +C 1010 FORMAT ('+',45X,'OFF') +C 1011 FORMAT ('+',45X,'ON') +C 1012 FORMAT (5X,'SIZE OF MIN AND MAX LABELS IN PWRIT UNITS SML=', +C 1 I4) +C 1013 FORMAT (5X,'DASH PATTERN GTR=GREATER, EQU=EQUAL, LSS=LESS') +C 1014 FORMAT (10X,'GTR=',A10) +C 1015 FORMAT (10X,'GTR=$$$$$$$$$$') +C 1016 FORMAT (10X,'EQU=',A10) +C 1017 FORMAT (10X,'EQU=$$$$$$$$$$') +C 1018 FORMAT (10X,'LSS=',A10) +C 1019 FORMAT (10X,'LSS=$$$$$$$$$$') +C 1020 FORMAT (5X,'DASH PATTERN BREAK POINT, DBP=',G10.3) +C 1021 FORMAT (5X,'MINOR LINE COUNT=',I3) +C +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONTERP TO ULIB * +C* AUGUST 1980 FIXED THE FOLLOWING PROBLEMS * +C* 1.PLOTTING OF INPUT DATA VALUES * +C* 2.SETTING OF MINIMUM INTENSITY IN ALL OPTION * +C* 3.SETTING OF EQU FLAG IN CONTOUR DASH PATTERN * +C* 4.TURNING OFF OF SIZE OF PLOTTED DATA OPTION * +C* DECEMBER 1980 FIXED CONTOUR SELECTION ALGORITHM AND MOVED IN * +C* DASH PACKAGE COMMON BLOCK INTPR +C* MARCH 1981 FIXED NON-PORTABLE STATEMENT ORDERING IN CONSET * +C* APRIL 1981 FIXED OPTION LISTING ROUTINE * +C* ADDED MINOR LINE COUNT OPTION * +C* JULY 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED LOC (MACHINE DEPENDENT FUNCTION), CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/conout.f b/sys/gio/ncarutil/conlib/conout.f new file mode 100644 index 00000000..c2684de9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conout.f @@ -0,0 +1,350 @@ + SUBROUTINE CONOUT (IVER) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C LIST OUT ALL THE CONRAN OPTION VALUES ON THE LINE PRINTER +C +C THE VALUE OF IVER DETERMINES WHICH ENTRY POINT CALLED THIS ROUTINE +C +C 1. CONRAQ +C 2. CONRAN +C 3. CONRAS +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C +C GET THE STANDARD OUTPUT UNIT TO WRITE THE OPTION VALUE LIST +C + IUNIT = I1MACH(2) +C +C PRINT OUT HEADER AND ALL OPTIONS WHICH APPLY TO CALLING VERSION +C +C GO TO ( 100, 110, 120),IVER +C 100 WRITE (IUNIT,1001) +C GO TO 130 +C 110 WRITE (IUNIT,1002) +C GO TO 130 +C 120 WRITE (IUNIT,1003) +C 130 WRITE (IUNIT,1004) +C +C PERIMETER +C +C WRITE (IUNIT,1005) +C IF (PER) GO TO 140 +C WRITE (IUNIT,1006) +C GO TO 150 +C 140 WRITE (IUNIT,1007) +C +C GRID +C +C 150 WRITE (IUNIT,1008) +C IF (GRD) GO TO 160 +C WRITE (IUNIT,1009) +C GO TO 170 +C 160 WRITE (IUNIT,1010) +C +C SCALING OF DATA ON FRAME +C +C 170 WRITE (IUNIT,1011) +C GO TO ( 180, 190, 200),ISCALE+1 +C 180 WRITE (IUNIT,1012) +C GO TO 210 +C 190 WRITE (IUNIT,1013) +C GO TO 210 +C 200 WRITE (IUNIT,1014) +C +C SAME DATA ANOTHER PLOT +C +C 210 WRITE (IUNIT,1015) +C IF (REPEAT) GO TO 220 +C WRITE (IUNIT,1016) +C GO TO 230 +C 220 WRITE (IUNIT,1017) +C +C SHIELDING +C +C 230 WRITE(IUNIT,2000) +C IF (SHIELD) GO TO 231 +C WRITE(IUNIT,2001) +C GO TO 232 +C 231 WRITE(IUNIT,2002) +C +C INTERPOLATION +C +C 232 WRITE(IUNIT,2003) +C IF (LINEAR) GO TO 233 +C WRITE(IUNIT,2004) +C GO TO 234 +C 233 WRITE(IUNIT,2005) +C +C PLOT THE SHIELD +C +C 234 WRITE(IUNIT,2006) +C IF (SLDPLT) GO TO 235 +C WRITE(IUNIT,2007) +C GO TO 236 +C 235 WRITE(IUNIT,2008) +C +C EXTRAPOLATION +C +C 236 WRITE (IUNIT,1018) +C IF (EXTRAP) GO TO 240 +C WRITE (IUNIT,1019) +C GO TO 250 +C 240 WRITE (IUNIT,1020) +C +C STEP SIZE OR RESOLUTION OF THE GRID +C +C 250 WRITE (IUNIT,1021) IGRAD +C +C MESSAGE AT BOTTOM OF PLOT +C +C WRITE (IUNIT,1022) +C IF (MESS) GO TO 260 +C WRITE (IUNIT,1023) +C GO TO 270 +C 260 WRITE (IUNIT,1024) +C +C TITLE AT TOP OF PLOT +C +C 270 WRITE (IUNIT,1025) +C IF (TITLE) GO TO 280 +C WRITE (IUNIT,1026) +C GO TO 290 +C 280 WRITE (IUNIT,1027) +C +C SIZE OF TITLE +C +C 290 WRITE (IUNIT,1028) ITLSIZ +C +C PRINT TITLE +C +C IF (ICNT.EQ.0 .OR. .NOT.TITLE) GO TO 310 +C ICC = 100 +C IF (ICC .GT. ICNT) ICC = ICNT +C WRITE (IUNIT,1029) ISTRNG +C +C DATA POINTS USED FOR PARTIAL DERIVATIVE ESTIMATION +C +C 310 WRITE (IUNIT,1030) NCP +C +C LOOK AT TRIANGLES SWITCH +C +C WRITE (IUNIT,1031) +C IF (LOOK) GO TO 320 +C WRITE (IUNIT,1032) +C GO TO 330 +C 320 WRITE (IUNIT,1033) +C +C ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C +C 330 WRITE (IUNIT,1034) +C IF (FRADV) GO TO 340 +C WRITE (IUNIT,1035) +C GO TO 350 +C 340 WRITE (IUNIT,1036) +C +C TRIANGLES ONLY PLOT +C +C 350 WRITE (IUNIT,1037) +C IF (EXTRI) GO TO 360 +C WRITE (IUNIT,1038) +C GO TO 370 +C 360 WRITE (IUNIT,1039) +C +C PLOT THE INPUT DATA VALUES +C +C 370 WRITE (IUNIT,1040) +C IF (PLDVLS) GO TO 380 +C WRITE (IUNIT,1041) +C GO TO 390 +C 380 WRITE (IUNIT,1042) +C +C FORMAT OF THE PLOTTED INPUT DATA +C +C 390 WRITE (IUNIT,1043) +C IF (LEN .NE. 0) GO TO 400 +C WRITE (IUNIT,1044) +C GO TO 420 +C 400 WRITE (IUNIT,1045) FORM +C +C SIZE OF THE PLOTTED DATA VALUES +C +C 420 WRITE (IUNIT,1046) ISIZEP +C +C INTENSITY SETTINGS +C +C WRITE (IUNIT,1047) +C WRITE (IUNIT,1048) INMAJ,INMIN,INLAB,INDAT +C +C DISTLAY CONTOUR SETTING +C +C WRITE (IUNIT,1049) +C IF (CON) GO TO 430 +C WRITE (IUNIT,1050) +C GO TO 440 +C 430 WRITE (IUNIT,1051) NCL,(CL(I),I=1,NCL) +C +C CONTOUR INCREMENT +C +C 440 WRITE (IUNIT,1052) +C IF (CINC) GO TO 450 +C WRITE (IUNIT,1053) +C GO TO 460 +C 450 WRITE (IUNIT,1054) FINC +C +C CONTOUR HIGH AND LOW VALUES +C +C 460 WRITE (IUNIT,1055) +C IF (CHILO) GO TO 470 +C WRITE (IUNIT,1056) +C GO TO 480 +C 470 WRITE (IUNIT,1057) HI,FLO +C +C CALL CONOT2 IF NOT QUICK VERSION +C +C 480 IF (IVER .NE. 1) CALL CONOT2 (IVER,IUNIT) +C +C THE ROUTINE CONOT2 WAS GENERATED TO ELIMINATE COMPILER ERRORS +C RESULTING FROM TOO MANY FORMAT STATEMENTS IN ONE SUBROUTINE +C +C RETURN +C +C +C1001 FORMAT (1X,'CONRAQ') +C1002 FORMAT (1X,'CONRAN') +C1003 FORMAT (1X,'CONRAS') +C1004 FORMAT ('+',6X,'-OPTION VALUE SETTINGS',/ +C 1 ,7X,'ALL NON-PWRIT VALUES APPLY TO THE UNSCALED DATA') +C1005 FORMAT (5X,'PERIMETER, PER=') +C1006 FORMAT ('+',19X,'OFF') +C1007 FORMAT ('+',19X,'ON') +C1008 FORMAT (5X,'GRID, GRD=') +C1009 FORMAT ('+',14X,'OFF') +C1010 FORMAT ('+',14X,'ON') +C1011 FORMAT (5X,'SCALING OF PLOT ON FRAME, SCA=') +C1012 FORMAT ('+',34X,'ON') +C1013 FORMAT ('+',34X,'OFF') +C1014 FORMAT ('+',34X,'PRI') +C1015 FORMAT (5X,'SAME DATA FOR ANOTHER PLOT, REP=') +C1016 FORMAT ('+',36X,'OFF') +C1017 FORMAT ('+',36X,'ON') +C1018 FORMAT (5X,'EXTRAPOLATION, EXT=') +C1019 FORMAT ('+',23X,'OFF') +C1020 FORMAT ('+',23X,'ON') +C1021 FORMAT (5X,'RESOLUTION, SSZ=',I4) +C1022 FORMAT (5X,'MESSAGE, MES=') +C1023 FORMAT ('+',17X,'OFF') +C1024 FORMAT ('+',17X,'ON') +C1025 FORMAT (5X,'TITLE, TLE=') +C1026 FORMAT ('+',15X,'OFF') +C1027 FORMAT ('+',15X,'ON') +C1028 FORMAT (5X,'TITLE SIZE IN PWRIT UNITS, STL=',I4) +C1029 FORMAT (5X,'TITLE=',A64) +C1030 FORMAT (5X,'DATA POINTS USED FOR PARTIAL DERIVATIVE', +C 1' ESTIMATION, NCP=',I4) +C1031 FORMAT (5X,'LOOK AT TRIANGLES, TRI=') +C1032 FORMAT ('+',27X,'OFF') +C1033 FORMAT ('+',27X,'ON') +C1034 FORMAT (5X,'ADVANCE FRAME BEFORE PLOTTING TRIANGULATION,', +C 1' TFR=') +C1035 FORMAT ('+',53X,'OFF') +C1036 FORMAT ('+',53X,'ON') +C1037 FORMAT (5X,'TRIANGULATION ONLY PLOT, TOP=') +C1038 FORMAT ('+',33X,'OFF') +C1039 FORMAT ('+',33X,'ON') +C1040 FORMAT (5X,'PLOT THE INPUT DATA VALUES, PDV=') +C1041 FORMAT ('+',36X,'OFF') +C1042 FORMAT ('+',36X,'ON') +C1043 FORMAT (5X,'FORMAT OF THE PLOTTED INPUT DATA, FMT=') +C1044 FORMAT ('+',42X,'(G10.3)') +C1045 FORMAT ('+',42X,A10) +C1046 FORMAT (5X,'SIZE OF THE PLOTTED DATA VALUES IN PWRIT', +C 1' UNITS, SPD=',I4) +C1047 FORMAT (5X,'COLOR (INTENSITY) INDICES FOLLOW.', +C 1' FOR CONRAQ MAJOR CONTOURS ARE ONLY USED') +C1048 FORMAT (10X,'MAJOR CONTOUR LINES, MAJ=',I4,/ +C 1 ,10X,'MINOR CONTOUR LINES, MIN=',I4,/ +C 2 ,10X,'TITLE AND MESSAGE, LAB=',I4,/ +C 3 ,10X,'PLOTTED DATA VALUES, DAT=',I4) +C1049 FORMAT (5X,'CONTOUR LEVELS, CON=') +C1050 FORMAT ('+',25X,'OFF') +C1051 FORMAT ('+',25X,'ON, NCL=',I4,' ARRAY='/(10(2X,F10.3))) +C1052 FORMAT (5X,'CONTOUR INCREMENT, CIL=') +C1053 FORMAT ('+',27X,'OFF') +C 1054 FORMAT ('+',27X,'ON, INCREMENT=',G10.3) +C 1055 FORMAT (5X,'CONTOUR HIGH AND LOW VALUES, CHL=') +C 1056 FORMAT ('+',37X,'OFF') +C 1057 FORMAT ('+',37X,'ON, HI=',G10.3,' FLO=',G10.3) +C 2000 FORMAT (5X,'SHIELDING, SLD=') +C 2001 FORMAT ('+',19X,'OFF') +C 2002 FORMAT ('+',19X,'ON') +C 2003 FORMAT (5X,'INTERPOLATION, ITP=') +C 2004 FORMAT ('+',23X,'C1 SURFACE') +C 2005 FORMAT ('+',23X,'LINEAR') +C 2006 FORMAT (5X,'PLOT THE SHIELD, SPT=') +C 2007 FORMAT ('+',25X,'OFF') +C 2008 FORMAT ('+',25X,'ON') +C + END diff --git a/sys/gio/ncarutil/conlib/conpdv.f b/sys/gio/ncarutil/conlib/conpdv.f new file mode 100644 index 00000000..49c1f61f --- /dev/null +++ b/sys/gio/ncarutil/conlib/conpdv.f @@ -0,0 +1,118 @@ + SUBROUTINE CONPDV (XD,YD,ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C PLOT THE DATA VALUES ON THE CONTOUR MAP +C CURRENTLY UP TO 10 CHARACTERS FOR EACH VALUE ARE DISPLAYED +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C + CHARACTER*10 ISTR + DIMENSION XD(1) ,YD(1) ,ZD(1) +C + SAVE +C +C DATA TO CONVERT 0-32767 COORIDNATES TO 1-1024 VALUES +C + DATA TRANS/32./ +C +C SET INTENSITY +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C SET FORMAT IF NONE SPECIFIED +C + IF (LEN .NE. 0) GO TO 110 + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD +C +C LOOP AND PLOT ALL VALUES +C + 110 DO 120 K=1,NDP + CALL FL2INT (XD(K),YD(K),MX,MY) + MX = IFIX(FLOAT(MX)/TRANS)+1 + MY = IFIX(FLOAT(MY)/TRANS)+1 +C +C + NOAO - FTN internal write rewritten as call to encode for IRAF +C +C WRITE(ISTR,FORM)ZD(K) + call encode (len, form, istr, zd(k)) +C +C - NOAO +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) +C + CALL WTSTR(XC,YC,ISTR,ISIZEP,0,0) + CALL GSELNT(ICN) + 120 CONTINUE + IF (INDAT .NE. 1) THEN + CALL GSTXCI (IRANTX) + ENDIF + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conreo.f b/sys/gio/ncarutil/conlib/conreo.f new file mode 100644 index 00000000..c029c0bb --- /dev/null +++ b/sys/gio/ncarutil/conlib/conreo.f @@ -0,0 +1,129 @@ + SUBROUTINE CONREO (MAJLNS) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MAJLNS. PV IS USED AS A WORK SPACE. MINGAP IS +C THE NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS +C BETWEEN MAJOR LEVELS). +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C + NL = NCL + IF (NL.LE.4 .OR. MINGAP.LE.1) GO TO 160 + NML = MINGAP-1 + IF (NL.LE.10) NML = 1 +C +C CHECK FOR BREAK POINT IN THE LIST OF CONTOURS FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 10 I=1,NL + ISAVE = I + IF (CL(I).EQ.BPSIZ) GO TO 40 + 10 CONTINUE +C +C NO BREAKPOINT FOUND SO TRY FOR A NICE NUMBER +C + L = NL/2 + L = ALOG10( ABS( CL(L) ) )+1. + Q = 10.**L + DO 30 J=1,3 + Q = Q/10. + DO 20 I=1,NL + ISAVE = I + IF (AMOD( ABS( CL(I) + 1.E-9*CL(I) )/Q,FLOAT(NMLP1) ).LE. + 1 .0001) GO TO 40 + 20 CONTINUE + 30 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN PV +C + 40 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART.EQ.0) ISTART = NMLP1 + NMAJL = 0 + DO 50 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + PV(NMAJL) = CL(I) + 50 CONTINUE + MAJLNS = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN PV +C + IC = NML/2 + 1 + L = MAJLNS+1 + DO 100 LOOP=1,NML + IC1 = IC + DO 90 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 60 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + IF (IC1.GE.NMLP1) GO TO 90 + IF (IC1.LE.0) GO TO 90 + 60 DO 70 K=ISTART,NL,NMLP1 + IND = K+IC1 + IF (IND.GT.NL) GO TO 80 + PV(L) = CL(IND) + L = L+1 + 70 CONTINUE + 80 IF (LOOP.EQ.1) GO TO 100 + 90 CONTINUE + 100 CONTINUE +C +C IF MAJOR LINES DID NOT START ON THE FIRST ENTRY PICK UP THE MISSING +C LEVELS +C + IF (ISTART.EQ.1) GO TO 140 + DO 130 LOOP=1,NML + IC1 = IC + DO 120 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 110 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + 110 IF (IC1.GE.ISTART) GO TO 120 + IF (IC1.LE.0) GO TO 120 + PV(L) = CL(IC1) + L = L+1 + IF (LOOP.EQ.1) GO TO 130 + 120 CONTINUE + 130 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 140 DO 150 I=1,NL + CL(I) = PV(I) + 150 CONTINUE + RETURN + 160 MAJLNS = NL + RETURN + END diff --git a/sys/gio/ncarutil/conlib/consld.f b/sys/gio/ncarutil/conlib/consld.f new file mode 100644 index 00000000..fd40e10d --- /dev/null +++ b/sys/gio/ncarutil/conlib/consld.f @@ -0,0 +1,165 @@ + SUBROUTINE CONSLD (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE IS USED TO GENERATE A SHIELD WHERE CONTOUR +C DRAWING IS ALLOWED. +C +C THE ROUTINE TAKES THE SILHOUETTE INFORMATION FROM COMMON BLOCK +C CONR13 AND TRANSFORMS THIS INTO A SHIELD TO BE USED IN THE +C SCRATCH ARRAY PASSED IN BY THE USER (THE SCRATCH ARRAY HOLDS THE +C GRIDED DATA FROM THE INTERPOLATION). +C +C INPUT +C SCRARR-THE SCRATCH ARRAY HOLDING THE INTERPOLATED DATA +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C +C INCREASE THE RESOLUTION OF THE SHIELD PROFILE +C + DIMENSION SCRARR(1) +C + SAVE + DATA RESINC/8.0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C +C +NOAO +C These statement functions are never called. +C SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C IARVL(IXX,IYY) = IYY+(IXX-1)*IYMAX +C -NOAO + IGADDR(XXX,YYY) = + 1 IFIX((YYY-YST)/STPSZ+.5)+(IFIX((XXX-XST)/STPSZ+.5))*IYMAX +C +C SET THE SPECIAL VALUE +C + SPVAL = SPVAL * 2. +C +C SET THE USER ARRAY LOCATIONS TO TEMPORARY POINTERS +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 1,ICOUNT +C +C ASSIGN LINE SEGMENT END POINTS +C + X1 = XVS(IC) + Y1 = YVS(IC) + IF (IC .EQ. ICOUNT) GO TO 10 + X2 = XVS(IC+1) + Y2 = YVS(IC+1) + GO TO 15 + 10 CONTINUE + X2 = XVS(1) + Y2 = YVS(1) + 15 CONTINUE +C +C INSURE THAT ALL POINTS ARE IN THE CONVEX HULL +C + IF (X1.GT.XED) X1 = XED + IF (X1.LT.XST) X1 = XST + IF (X2.GT.XED) X2 = XED + IF (X2.LT.XST) X2 = XST + IF (Y1.GT.YED) Y1 = YED + IF (Y1.LT.YST) Y1 = YST + IF (Y2.GT.YED) Y2 = YED + IF (Y2.LT.YST) Y2 = YST +C +C SET THE START OF THE LINE SEGMENT SCRATCH LOCATION TO +C THE SPECIAL VALUE +C + II = IGADDR(X1,Y1) + SCRARR(II) = SPVAL +C +C FIND THE LENGTH OF THE LINE SEGMENT +C + DIST = SQRT(((X2-X1)**2)+((Y2-Y1)**2)) +C +C IF LENGTH SHORTER THAN STEP SIZE THEN THERE IS NOTHING TO DO +C + IF (DIST .LE. STPSZ) GO TO 100 +C +C SET UP LOOP TO SET ALL CELLS ON THE LINE SEGMENT +C + NSTPS = (DIST/STPSZ)*RESINC + XSTP = (X2-X1)/FLOAT(NSTPS) + YSTP = (Y2-Y1)/FLOAT(NSTPS) + X = X1 + Y = Y1 + DO 20 K = 1,NSTPS + X = X + XSTP + Y = Y + YSTP + II = IGADDR(X,Y) + SCRARR(II) = SPVAL + 20 CONTINUE +C + 100 CONTINUE +C +C FILL THE SHIELDED AREAS +C FOR EACH COLUMN THE ELEMENTS ARE SET TO SPVAL IF FILL IS TRUE. +C THE VALUE OF FILL IS NEGATED EVERY TIME A SPVAL IS ENCOUNTERED, +C AND THAT CELL REMAINS UNCHANGED. +C +C LOOP THROUGH THE GRID +C + DO 39 I = 1,IXMAX +C +C GET THE START AND END FOR THE COLUMN +C + IYS = (I-1)*IYMAX+1 + IYE = I*IYMAX +C +C ADVANCE IN THE FORWARD DIRECTION +C + DO 32 J = IYS,IYE +C +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(J).EQ.SPVAL) GO TO 33 + SCRARR(J) = SPVAL + 32 CONTINUE + GO TO 39 +C +C ADVANCE IN THE BACKWARD DIRECTION +C + 33 CONTINUE + DO 34 J = 1,IYMAX + NJ =IYE+1-J +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(NJ).EQ.SPVAL) GO TO 39 + SCRARR(NJ) = SPVAL + 34 CONTINUE + 39 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conssd.f b/sys/gio/ncarutil/conlib/conssd.f new file mode 100644 index 00000000..26ac20d1 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conssd.f @@ -0,0 +1,61 @@ + SUBROUTINE CONSSD(X,Y,IC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE SETS THE SHIELDING FLAG AND CONNECTS THE +C USERS SHIELD ARRAYS TO SOME INTERNAL POINTERS +C +C INPUT +C X-X COORDINATE STRING +C Y-Y COORDINATE STRING +C IC-NUMBER OF COORDINATES +C +C NOTE THE USERS ARRAYS CANNOT BE MUCKED WITH DURING EXECUTION +C THOSE ARRAYS ARE USED DURING CONRAN EXECUTION +C + DIMENSION X(1),Y(1) + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C SET COUNTER +C + ICOUNT = IC +C +C CHECK THE DIMENSION OF SHIELD ARRAYS +C + IERUNT = I1MACH(4) + IF (ICOUNT .GT. 50) THEN + CALL SETER (' CONSSD -- NUMBER OF SHIELD POINTS .GT. 50',1,1) +C +C + NOAO - FTN write and format statement commented out; SETER is enough. +C WRITE(IERUNT,1001) + ICOUNT = 50 + ENDIF +C1001 FORMAT(' ERROR 1 IN CONSSD -- NUMBER OF SHIELD POINTS .GT. 50') +C - NOAO +C +C SET THE SHIELDING FLAG TO TRUE +C + SHIELD = .TRUE. +C +C COMPUTE POINTERS FOR THE USERS SHIELDING ARRAYS +C + DO 300 I = 1,ICOUNT + XVS(I) = X(I) + 300 YVS(I) = Y(I) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/constp.f b/sys/gio/ncarutil/conlib/constp.f new file mode 100644 index 00000000..8df0e23b --- /dev/null +++ b/sys/gio/ncarutil/conlib/constp.f @@ -0,0 +1,135 @@ + SUBROUTINE CONSTP (XD,YD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE STEP SIZE IN X AND Y DIRECTION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) +C + SAVE +C +C FIND SMALLEST AND LARGST X AND Y +C + XST = XD(1) + XED = XD(1) + YST = YD(1) + YED = YD(1) + DO 130 I=2,NDP + IF (XST .LE. XD(I)) GO TO 100 + XST = XD(I) + GO TO 110 + 100 IF (XED .GE. XD(I)) GO TO 110 + XED = XD(I) + 110 IF (YST .LE. YD(I)) GO TO 120 + YST = YD(I) + GO TO 130 + 120 IF (YED .GE. YD(I)) GO TO 130 + YED = YD(I) + 130 CONTINUE +C +C COMPUTE STEP SIZE +C + XRG = (ABS(XED-XST)) + YRG = (ABS(YED-YST)) + SQRG = XRG + IF (SQRG .LT. YRG) SQRG = YRG + STPSZ = SQRG/FLOAT(IGRAD-1) +C +C COMPUTE PARAMETERS FOR SET CALL +C + DIFX = XRG/SQRG + DIFY = YRG/SQRG + PXST = .5-(BORD*DIFX)/2. + PXED = .5+(BORD*DIFX)/2. + PYST = .5-(BORD*DIFY)/2. + PYED = .5+(BORD*DIFY)/2. + XRG = XRG/FLOAT(ITICK) + YRG = YRG/FLOAT(ITICK) +C +C TEST IF THE ASPECT RATIO FOR THE COORDINATES IS REASONABLE. +C REASONABLE IS CURRENTLY DEFINED AS 5 TO 1. +C IF IT IS NOT REASONABLE THEN A POOR PLOT MAY BE GENERATED +C SO IT IS NICE THE WARN THE USER WHEN THIS HAPPENS. +C + TEST = XRG/YRG + IF (TEST.LE.5. .AND. TEST.GE.0.2) RETURN +C +C WARN THE USER ON THE STANDARD OUTPUT UNIT THAT THE PLOT MAY +C NOT BE TOO GOOD. +C +C SET RECOVERY MODE +C + CALL ENTSR(IROLD,IREC) +C +C FLAG THE ERROR +C + CALL SETER(' ASPECT RATIO OF X AND Y GREATER THAN 5 TO 1', + 1 1,1) +C + CALL EPRIN +C +C CLEAR THE ERROR +C + CALL ERROF +C +C RESET USER ERROR MODE +C + CALL ENTSR(IDUM,IROLD) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contlk.f b/sys/gio/ncarutil/conlib/contlk.f new file mode 100644 index 00000000..201b4d07 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contlk.f @@ -0,0 +1,98 @@ + SUBROUTINE CONTLK (XD,YD,NDP,IPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE TRIANGLES CREATED BY CONTNG +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,IPT(1) +C + SAVE +C +C STATEMENT FUNCTIONS TO SCALE DATA FOR OVERLAYS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C ADVANCE PICTURE IF DESIRED +C + IF (FRADV) CALL FRAME +C +C DRAW TRIANGLES +C + DO 100 K=1,NT + I = K*3 + I1 = IPT(I) + I2 = IPT(I-1) + I3 = IPT(I-2) + XX = FX(XD(I1),YD(I1)) + CALL FL2INT (XX,FY(XD(I1),YD(I1)),MX1,MY1) + CALL PLOTIT (MX1,MY1,0) + XX = FX(XD(I2),YD(I2)) + CALL FL2INT (XX,FY(XD(I2),YD(I2)),MX,MY) + CALL PLOTIT (MX,MY,1) + XX = FX(XD(I3),YD(I3)) + CALL FL2INT (XX,FY(XD(I3),YD(I3)),MX,MY) + CALL PLOTIT (MX,MY,1) + CALL PLOTIT (MX1,MY1,1) + 100 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contng.f b/sys/gio/ncarutil/conlib/contng.f new file mode 100644 index 00000000..7ebad596 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contng.f @@ -0,0 +1,432 @@ + SUBROUTINE CONTNG (NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS TRIANGULATION. IT DIVIDES THE X-Y +C PLANE INTO A NUMBER OF TRIANGLES ACCORDING TO GIVEN DATA +C POINTS IN THE PLANE, DETERMINES LINE SEGMENTS THAT FORM THE +C BORDER OF DATA AREA, AND DETERMINES THE TRIANGLE NUMBERS +C CORRESPONDING TO THE BORDER LINE SEGMENTS. +C AT COMPLETION, POINT NUMBERS OF THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. POINT NUMBERS OF THE END POINTS +C OF EACH BORDER LINE SEGMENT ARE LISTED COUNTER-CLOCKWISE, +C LISTING ORDER OF THE LINE SEGMENTS BEING COUNTER-CLOCKWISE. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD = ARRAY OF DIMENSION NDP CONTAINING THE +C X COORDINATES OF THE DATA POINTS, +C YD = ARRAY OF DIMENSION NDP CONTAINING THE +C Y COORDINATES OF THE DATA POINTS. +C THE OUTPUT PARAMETERS ARE +C NT = NUMBER OF TRIANGLES, +C IPT = ARRAY OF DIMENSION 6*NDP-15, WHERE THE POINT +C NUMBERS OF THE VERTEXES OF THE (IT)TH TRIANGLE +C ARE TO BE STORED AS THE (3*IT-2)ND, (3*IT-1)ST, +C AND (3*IT)TH ELEMENTS, IT=1,2,...,NT, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = ARRAY OF DIMENSION 6*NDP, WHERE THE POINT +C NUMBERS OF THE END POINTS OF THE (IL)TH BORDER +C LINE SEGMENT AND ITS RESPECTIVE TRIANGLE NUMBER +C ARE TO BE STORED AS THE (3*IL-2)ND, (3*IL-1)ST, +C AND (3*IL)TH ELEMENTS, IL=1,2,..., NL. +C THE OTHER PARAMETERS ARE +C IWL = INTEGER ARRAY OF DIMENSION 18*NDP USED +C INTERNALLY AS A WORK AREA, +C IWP = INTEGER ARRAY OF DIMENSION NDP USED +C INTERNALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + SAVE +C + INTEGER CONXCH + COMMON /CONRA3/ IREC + DIMENSION XD(*) ,YD(*) ,IPT(*) ,IPL(*) , + 1 IWL(*) ,IWP(*) ,WK(*) + DIMENSION ITF(2) + CHARACTER*4 IP1C, IP2C + CHARACTER*64 ITEMP + DATA RATIO/1.0E-6/, NREP/100/ +C +C STATEMENT FUNCTIONS +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 + SIDE(U1,V1,U2,V2,U3,V3) = (V3-V1)*(U2-U1)-(U3-U1)*(V2-V1) +C +C PRELIMINARY PROCESSING +C + NDPM1 = NDP-1 +C +C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. +C + DSQMN = DSQF(XD(1),YD(1),XD(2),YD(2)) + IPMN1 = 1 + IPMN2 = 2 + DO 140 IP1=1,NDPM1 + X1 = XD(IP1) + Y1 = YD(IP1) + IP1P1 = IP1+1 + DO 130 IP2=IP1P1,NDP + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .NE. 0.) GO TO 120 +C +C ERROR, IDENTICAL INPUT DATA POINTS +C + ITEMP = ' CONTNG-IDENTICAL INPUT DATA POINTS FOUND + 1 AT AND ' +C +C + NOAO - FTN internal writes rewritten as calls to encode for IRAF +C +C WRITE(IP1C,'(I4)')IP1 +C WRITE(IP2C,'(I4)')IP2 + call encode (4, '(I4)', ip1c, ip1) + call encode (4, '(I4)', ip2c, ip2) +C - NOAO +C + CALL SETER (ITEMP,1,1) + ITEMP(46:49) = IP1C + ITEMP(55:58) = IP2C + RETURN + 120 IF (DSQI .GE. DSQMN) GO TO 130 + DSQMN = DSQI + IPMN1 = IP1 + IPMN2 = IP2 + 130 CONTINUE + 140 CONTINUE + DSQ12 = DSQMN + XDMP = (XD(IPMN1)+XD(IPMN2))/2.0 + YDMP = (YD(IPMN1)+YD(IPMN2))/2.0 +C +C SORTS THE OTHER (NDP-2) DATA POINTS IN ASCENDING ORDER OF +C DISTANCE FROM THE MIDPOINT AND STORES THE SORTED DATA POINT +C NUMBERS IN THE IWP ARRAY. +C + JP1 = 2 + DO 150 IP1=1,NDP + IF (IP1.EQ.IPMN1 .OR. IP1.EQ.IPMN2) GO TO 150 + JP1 = JP1+1 + IWP(JP1) = IP1 + WK(JP1) = DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) + 150 CONTINUE + DO 170 JP1=3,NDPM1 + DSQMN = WK(JP1) + JPMN = JP1 + DO 160 JP2=JP1,NDP + IF (WK(JP2) .GE. DSQMN) GO TO 160 + DSQMN = WK(JP2) + JPMN = JP2 + 160 CONTINUE + ITS = IWP(JP1) + IWP(JP1) = IWP(JPMN) + IWP(JPMN) = ITS + WK(JPMN) = WK(JP1) + 170 CONTINUE +C +C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE +C FIRST THREE DATA POINTS ARE NOT COLLINEAR. +C + AR = DSQ12*RATIO + X1 = XD(IPMN1) + Y1 = YD(IPMN1) + DX21 = XD(IPMN2)-X1 + DY21 = YD(IPMN2)-Y1 + DO 180 JP=3,NDP + IP = IWP(JP) + IF (ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21) .GT. AR) GO TO 190 + 180 CONTINUE + CALL SETER (' CONTNG - ALL COLLINEAR DATA POINTS',1,1) + 190 IF (JP .EQ. 3) GO TO 210 + JPMX = JP + JP = JPMX+1 + DO 200 JPC=4,JPMX + JP = JP-1 + IWP(JP) = IWP(JP-1) + 200 CONTINUE + IWP(3) = IP +C +C FORMS THE FIRST TRIANGLE. STORES POINT NUMBERS OF THE VER- +C TEXES OF THE TRIANGLE IN THE IPT ARRAY, AND STORES POINT NUM- +C BERS OF THE BORDER LINE SEGMENTS AND THE TRIANGLE NUMBER IN +C THE IPL ARRAY. +C + 210 IP1 = IPMN1 + IP2 = IPMN2 + IP3 = IWP(3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 220 + IP1 = IPMN2 + IP2 = IPMN1 + 220 NT0 = 1 + NTT3 = 3 + IPT(1) = IP1 + IPT(2) = IP2 + IPT(3) = IP3 + NL0 = 3 + NLT3 = 9 + IPL(1) = IP1 + IPL(2) = IP2 + IPL(3) = 1 + IPL(4) = IP2 + IPL(5) = IP3 + IPL(6) = 1 + IPL(7) = IP3 + IPL(8) = IP1 + IPL(9) = 1 +C +C ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. +C + DO 400 JP1=4,NDP + IP1 = IWP(JP1) + X1 = XD(IP1) + Y1 = YD(IP1) +C +C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. +C + IP2 = IPL(1) + JPMN = 1 + DXMN = XD(IP2)-X1 + DYMN = YD(IP2)-Y1 + DSQMN = DXMN**2+DYMN**2 + ARMN = DSQMN*RATIO + JPMX = 1 + DXMX = DXMN + DYMX = DYMN + DSQMX = DSQMN + ARMX = ARMN + DO 240 JP2=2,NL0 + IP2 = IPL(3*JP2-2) + DX = XD(IP2)-X1 + DY = YD(IP2)-Y1 + AR = DY*DXMN-DX*DYMN + IF (AR .GT. ARMN) GO TO 230 + DSQI = DX**2+DY**2 + IF (AR.GE.(-ARMN) .AND. DSQI.GE.DSQMN) GO TO 230 + JPMN = JP2 + DXMN = DX + DYMN = DY + DSQMN = DSQI + ARMN = DSQMN*RATIO + 230 AR = DY*DXMX-DX*DYMX + IF (AR .LT. (-ARMX)) GO TO 240 + DSQI = DX**2+DY**2 + IF (AR.LE.ARMX .AND. DSQI.GE.DSQMX) GO TO 240 + JPMX = JP2 + DXMX = DX + DYMX = DY + DSQMX = DSQI + ARMX = DSQMX*RATIO + 240 CONTINUE + IF (JPMX .LT. JPMN) JPMX = JPMX+NL0 + NSH = JPMN-1 + IF (NSH .LE. 0) GO TO 270 +C +C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER +C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. +C + NSHT3 = NSH*3 + DO 250 JP2T3=3,NSHT3,3 + JP3T3 = JP2T3+NLT3 + IPL(JP3T3-2) = IPL(JP2T3-2) + IPL(JP3T3-1) = IPL(JP2T3-1) + IPL(JP3T3) = IPL(JP2T3) + 250 CONTINUE + DO 260 JP2T3=3,NLT3,3 + JP3T3 = JP2T3+NSHT3 + IPL(JP2T3-2) = IPL(JP3T3-2) + IPL(JP2T3-1) = IPL(JP3T3-1) + IPL(JP2T3) = IPL(JP3T3) + 260 CONTINUE + JPMX = JPMX-NSH +C +C - ADDS TRIANGLES TO THE IPT ARRAY, UPDATES BORDER LINE +C - SEGMENTS IN THE IPL ARRAY, AND SETS FLAGS FOR THE BORDER +C - LINE SEGMENTS TO BE REEXAMINED IN THE IWL ARRAY. +C + 270 JWL = 0 + DO 310 JP2=JPMX,NL0 + JP2T3 = JP2*3 + IPL1 = IPL(JP2T3-2) + IPL2 = IPL(JP2T3-1) + IT = IPL(JP2T3) +C +C - - ADDS A TRIANGLE TO THE IPT ARRAY. +C + NT0 = NT0+1 + NTT3 = NTT3+3 + IPT(NTT3-2) = IPL2 + IPT(NTT3-1) = IPL1 + IPT(NTT3) = IP1 +C +C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. +C + IF (JP2 .NE. JPMX) GO TO 280 + IPL(JP2T3-1) = IP1 + IPL(JP2T3) = NT0 + 280 IF (JP2 .NE. NL0) GO TO 290 + NLN = JPMX+1 + NLNT3 = NLN*3 + IPL(NLNT3-2) = IP1 + IPL(NLNT3-1) = IPL(1) + IPL(NLNT3) = NT0 +C +C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER +C - - LINE SEGMENTS. +C + 290 ITT3 = IT*3 + IPTI = IPT(ITT3-2) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3-1) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 300 IF (CONXCH(XD,YD,IP1,IPTI,IPL1,IPL2) .EQ. 0) GO TO 310 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(ITT3-2) = IPTI + IPT(ITT3-1) = IPL1 + IPT(ITT3) = IP1 + IPT(NTT3-1) = IPTI + IF (JP2 .EQ. JPMX) IPL(JP2T3) = IT + IF (JP2.EQ.NL0 .AND. IPL(3).EQ.IT) IPL(3) = NT0 +C +C - - SETS FLAGS IN THE IWL ARRAY. +C + JWL = JWL+4 + IWL(JWL-3) = IPL1 + IWL(JWL-2) = IPTI + IWL(JWL-1) = IPTI + IWL(JWL) = IPL2 + 310 CONTINUE + NL0 = NLN + NLT3 = NLNT3 + NLF = JWL/2 + IF (NLF .EQ. 0) GO TO 400 +C +C - IMPROVES TRIANGULATION. +C + NTT3P3 = NTT3+3 + DO 390 IREP=1,NREP + DO 370 ILF=1,NLF + ILFT2 = ILF*2 + IPL1 = IWL(ILFT2-1) + IPL2 = IWL(ILFT2) +C +C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF +C - - THE FLAGGED LINE SEGMENT. +C + NTF = 0 + DO 320 ITT3R=3,NTT3,3 + ITT3 = NTT3P3-ITT3R + IPT1 = IPT(ITT3-2) + IPT2 = IPT(ITT3-1) + IPT3 = IPT(ITT3) + IF (IPL1.NE.IPT1 .AND. IPL1.NE.IPT2 .AND. + 1 IPL1.NE.IPT3) GO TO 320 + IF (IPL2.NE.IPT1 .AND. IPL2.NE.IPT2 .AND. + 1 IPL2.NE.IPT3) GO TO 320 + NTF = NTF+1 + ITF(NTF) = ITT3/3 + IF (NTF .EQ. 2) GO TO 330 + 320 CONTINUE + IF (NTF .LT. 2) GO TO 370 +C +C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE +C - - ON THE LINE SEGMENT. +C + 330 IT1T3 = ITF(1)*3 + IPTI1 = IPT(IT1T3-2) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3-1) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3) + 340 IT2T3 = ITF(2)*3 + IPTI2 = IPT(IT2T3-2) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3-1) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 350 IF (CONXCH(XD,YD,IPTI1,IPTI2,IPL1,IPL2) .EQ. 0) + 1 GO TO 370 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(IT1T3-2) = IPTI1 + IPT(IT1T3-1) = IPTI2 + IPT(IT1T3) = IPL1 + IPT(IT2T3-2) = IPTI2 + IPT(IT2T3-1) = IPTI1 + IPT(IT2T3) = IPL2 +C +C - - SETS NEW FLAGS. +C + JWL = JWL+8 + IWL(JWL-7) = IPL1 + IWL(JWL-6) = IPTI1 + IWL(JWL-5) = IPTI1 + IWL(JWL-4) = IPL2 + IWL(JWL-3) = IPL2 + IWL(JWL-2) = IPTI2 + IWL(JWL-1) = IPTI2 + IWL(JWL) = IPL1 + DO 360 JLT3=3,NLT3,3 + IPLJ1 = IPL(JLT3-2) + IPLJ2 = IPL(JLT3-1) + IF ((IPLJ1.EQ.IPL1 .AND. IPLJ2.EQ.IPTI2) .OR. + 1 (IPLJ2.EQ.IPL1 .AND. IPLJ1.EQ.IPTI2)) + 2 IPL(JLT3) = ITF(1) + IF ((IPLJ1.EQ.IPL2 .AND. IPLJ2.EQ.IPTI1) .OR. + 1 (IPLJ2.EQ.IPL2 .AND. IPLJ1.EQ.IPTI1)) + 2 IPL(JLT3) = ITF(2) + 360 CONTINUE + 370 CONTINUE + NLFC = NLF + NLF = JWL/2 + IF (NLF .EQ. NLFC) GO TO 400 +C +C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. +C + JWL = 0 + JWL1MN = (NLFC+1)*2 + NLFT2 = NLF*2 + DO 380 JWL1=JWL1MN,NLFT2,2 + JWL = JWL+2 + IWL(JWL-1) = IWL(JWL1-1) + IWL(JWL) = IWL(JWL1) + 380 CONTINUE + NLF = JWL/2 + 390 CONTINUE + 400 CONTINUE +C +C REARRANGE THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. +C + DO 410 ITT3=3,NTT3,3 + IP1 = IPT(ITT3-2) + IP2 = IPT(ITT3-1) + IP3 = IPT(ITT3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 410 + IPT(ITT3-2) = IP2 + IPT(ITT3-1) = IP1 + 410 CONTINUE + NT = NT0 + NL = NL0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conxch.f b/sys/gio/ncarutil/conlib/conxch.f new file mode 100644 index 00000000..6309f360 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conxch.f @@ -0,0 +1,67 @@ + INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO +C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION +C BY C. L. LAWSON. +C THE INPUT PARAMETERS ARE +C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA +C POINTS, +C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2, +C P3, AND P4 THAT FORM A QUADRILATERAL +C WITH P3 AND P4 CONNECTED DIADONALLY. +C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS +C NEEDED, AND 0 (ZERO) OTHERWISE. +C DECLARATION STATEMENTS +C + DIMENSION X(1) ,Y(1) + DIMENSION X0(4) ,Y0(4) + EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ), + 1 (B4SQ,A2SQ),(C4SQ,C3SQ) +C + SAVE +C +C STATEMENT FUNCTIONS +C +C CALCULATION +C + X0(1) = X(I1) + Y0(1) = Y(I1) + X0(2) = X(I2) + Y0(2) = Y(I2) + X0(3) = X(I3) + Y0(3) = Y(I3) + X0(4) = X(I4) + Y0(4) = Y(I4) + IDX = 0 + U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3)) + U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4)) + IF (U3*U4 .LE. 0.0) GO TO 100 + U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1)) + U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2)) + A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2 + B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2 + C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2 + A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2 + B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2 + C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2 + S1SQ = U1*U1/(C1SQ*AMAX1(A1SQ,B1SQ)) + S2SQ = U2*U2/(C2SQ*AMAX1(A2SQ,B2SQ)) + S3SQ = U3*U3/(C3SQ*AMAX1(A3SQ,B3SQ)) + S4SQ = U4*U4/(C4SQ*AMAX1(A4SQ,B4SQ)) + IF (AMIN1(S1SQ,S2SQ) .LT. AMIN1(S3SQ,S4SQ)) IDX = 1 + 100 CONXCH = IDX + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/mkpkg b/sys/gio/ncarutil/conlib/mkpkg new file mode 100644 index 00000000..5ebdc2cb --- /dev/null +++ b/sys/gio/ncarutil/conlib/mkpkg @@ -0,0 +1,37 @@ +# Update the CONCOM and CONTERP contributions to LIBNCAR. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + concal.f + concld.f + concls.f + concom.f + condet.f + condrw.f + condsd.f + conecd.f + congen.f + conint.f + conlcm.f + conlin.f + conloc.f + conlod.f + conop1.f + conop2.f + conop3.f + conop4.f + conot2.f + conout.f + conpdv.f + conreo.f + consld.f + conssd.f + constp.f + contlk.f + contng.f + conxch.f + ; diff --git a/sys/gio/ncarutil/conran.f b/sys/gio/ncarutil/conran.f new file mode 100644 index 00000000..bc23a6cc --- /dev/null +++ b/sys/gio/ncarutil/conran.f @@ -0,0 +1,1976 @@ + SUBROUTINE CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C STANDARD AND SMOOTH VERSIONS OF CONRAN +C +C DIMENSION OF XD(NDP),YD(NDP),ZD(NDP),WK(13*NDP) +C ARGUMENTS IWK((27+NCP)*NDP),SCRARR(RESOLUTION**2) +C WHERE NCP = 4 AND RESOLUTION = 40 BY +C DEFAULT. +C +C LATEST REVISION JULY 1984 +C +C OVERVIEW CONRAN PERFORMS CONTOURING OF IRREGULARLY +C DISTRIBUTED DATA. IT IS THE STANDARD AND +C SMOOTH MEMBERS OF THE CONRAN FAMILY. THIS +C VERSION WILL PLOT CONTOURS; SMOOTH THEM USING +C SPLINES UNDER TENSION (IF THE PACKAGE DASHSMTH +C IS LOADED); PLOT A PERIMETER OR GRID; TITLE THE +C PLOT; PRINT A MESSAGE GIVING THE CONTOUR INTERVALS +C BELOW THE MAP; PLOT THE INPUT DATA ON THE MAP; +C AND LABEL THE CONTOUR LINES. +C +C PURPOSE CONRAN PLOTS CONTOUR LINES USING RANDOM, +C SPARSE OR IRREGULAR DATA SETS. THE DATA IS +C TRIANGULATED AND THEN CONTOURED. CONTOURING +C IS PERFORMED USING INTERPOLATION OF THE TRI- +C ANGULATED DATA. THERE ARE TWO METHODS OF +C INTERPOLATION: C1 SURFACES AND LINEAR. +C +C USAGE CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C AN OPTION SETTING ROUTINE CAN ALSO BE IN- +C VOKED, SEE WRITEUP BELOW. FRAME MUST BE +C CALLED BY THE USER. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO BE +C USED FOR NORMAL INTENSITY, LOW INTENSITY OR +C TEXT OUTPUT, THEN THE VALUES IN COMMON BLOCK +C RANINT SHOULD BE CHANGED: +C +C IRANMJ COLOR INDEX FOR NORMAL (MAJOR) INTENSITY +C LINES. +C IRANMN COLOR INDEX FOR LOW INTENSITY LINES +C IRANTX COLOR INDEX FOR TEXT (LABELS) +C +C +C ARGUMENTS +C +C ON INPUT XD +C ARRAY OF DIMENSION NDP CONTAINING THE X- +C COORDINATES OF THE DATA POINTS. +C +C YD +C ARRAY OF DIMENSION NDP CONTAINING THE Y- +C COORDINATES OF THE DATA POINTS. +C +C ZD +C ARRAY OF DIMENSION NDP CONTAINING THE +C DATA VALUES AT THE POINTS. +C +C NDP +C NUMBER OF DATA POINTS (MUST BE 4 OR +C GREATER) TO BE CONTOURED. +C +C WK +C REAL WORK ARRAY OF DIMENSION AT LEAST +C 13*NDP +C +C IWK +C INTEGER WORK ARRAY. WHEN USING C1 SURFACES +C THE ARRAY MUST BE AT LEAST IWK((27+NCP)*NDP). +C WHEN USING LINEAR INTERPOLATION THE ARRAY +C MUST BE AT LEAST IWK((27+4)*NDP). +C +C SCRARR +C REAL WORK ARRAY OF DIMENSION AT LEAST +C (RESOLUTION**2) WHERE RESOLUTION IS +C DESCRIBED IN THE SSZ OPTION BELOW. RESO- +C LUTION IS 40 BY DEFAULT. +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED EXCEPT THE +C SCRATCH ARRAYS IWK, WK, AND SCRARR WHICH HAVE +C BEEN WRITTEN INTO. IF MAKING MULTIPLE RUNS +C ON THE SAME TRIANGULATION IWK AND WK MUST BE +C SAVED AND RETURNED TO THE NEXT INVOCATION OF +C CONRAN. +C +C ENTRY POINTS CONRAN, CONDET, CONINT, CONCAL, CONLOC, CONTNG, +C CONDRW, CONCLS, CONSTP, CONBDN, CONTLK +C CONPDV, CONOP1, CONOP2, CONOP3, CONOP4, +C CONXCH, CONREO, CONCOM, CONCLD, CONPMM, +C CONGEN, CONLOD, CONECD, CONOUT, CONOT2, +C CONSLD, CONLCM, CONLIN, CONDSD, CONSSD +C +C COMMON BLOCKS CONRA1, CONRA2, CONRA3, CONRA4, CONRA5, CONRA6, +C CONRA7, CONRA8, CONRA9, CONR10, CONR11, CONR12, +C CONR13, CONR14, CONR15, CONR16, CONR17, RANINT +C INTPR FROM THE DASH PACKAGE +C +C I/O PLOTS THE CONTOUR MAP AND, VIA THE ERPRT77 +C PACKAGE, OUTPUTS MESSAGES TO THE MESSAGE +C OUTPUT UNIT; AT NCAR THIS UNIT IS THE +C PRINTER. THE OPTION VALUES ARE ALL LISTED ON +C STANDARD ERPRT77 OUTPUT UNIT; AT NCAR THIS +C UNIT IS THE PRINTER. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT NCAR IS +C ROUTINES LOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE CONCOM, CONTERP, GRIDAL +C THE ERPRT77 PACKAGE, AND THE SPPS. +C +C LANGUAGE FORTRAN77 +C +C HISTORY +C +C ALGORITHM THE SPARSE DATA IS TRIANGULATED AND A VIRTUAL +C GRID IS LAID OVER THE TRIANGULATED AREA. +C EACH VIRTUAL GRID POINT RECEIVES AN INTERPO- +C LATED VALUE. THE GRID IS SCANNED ONCE FOR +C EACH CONTOUR LEVEL AND ALL CONTOURS AT THAT +C LEVEL ARE PLOTTED. +C THERE ARE TWO METHODS OF INTERPOLATION. THE +C FIRST IS A SMOOTH DATA INTERPOLATION +C SCHEME BASED ON LAWSON'S C1 +C SURFACE INTERPOLATION ALGORITHM, WHICH HAS +C BEEN REFINED BY HIROSHA AKIMA. PARTS OF +C AKIMA'S ALGORITHM ARE USED IN THIS PACKAGE. +C SEE THE "REFERENCE" SECTION BELOW. +C THE SECOND IS A LINEAR INTERPOLATION SCHEME. +C WHEN DATA IS SPARSE IT IS USUALLY BETTER TO +C USE THE C1 INTERPOLATION. IF YOU HAVE DENSE +C DATA (OVER 100 POINTS) THEN THE LINEAR +C INTERPOLATION WILL GIVE THE BETTER RESULTS. +C +C PORTABILITY ANSI FORTRAN +C +C +C OPERATION CALL CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C FRAME MUST BE CALLED BY THE USER. +C +C CONRAN HAS MANY OPTIONS, EACH OF WHICH MAY +C BE CHANGED BY CALLING ONE OF THE FOUR +C SUBROUTINES CONOP1, CONOP2, CONOP3, OR +C CONOP4. THE NUMBER OF ARGUMENTS TO EACH +C CONOP ROUTINE IS THE SAME AS THE FINAL +C SUFFIX CHARACTER IN THE ROUTINE'S NAME. +C +C THE CONOP ROUTINES ARE CALLED BEFORE CONRAN +C IS CALLED, AND VALUES SET BY THESE CALLS +C CONTINUE TO BE IN EFFECT UNTIL THEY ARE +C CHANGED BY ANOTHER CALL TO A CONOP ROUTINE. +C +C ALL THE CONOP ROUTINES HAVE AS THEIR FIRST +C ARGUMENT A CHARACTER STRING TO IDENTIFY THE +C OPTION BEING CHANGED. THIS IS THE ONLY +C ARGUMENT TO CONOP1. CONOP2 HAS AN INTEGER +C SECOND ARGUMENT. CONOP3 HAS A REAL ARRAY (OR +C CONSTANT) AS ITS SECOND ARGUMENT AND AN +C INTEGER (USUALLY THE DIMENSION OF THE +C ARRAY) AS ITS THIRD ARGUMENT. CONOP4 HAS A +C CHARACTER STRING AS ITS SECOND ARGUMENT AND +C INTEGERS FOR THE THIRD AND FOURTH ARGUMENTS. +C +C ONLY THE FIRST TWO CHARACTERS ON EACH SIDE OF +C THE EQUAL SIGN ARE SCANNED. THEREFORE ONLY 2 +C CHARACTERS FOR EACH OPTION ARE REQUIRED ON +C INPUT TO CONOP (I.E. 'SCA=PRI' AND 'SC=PR' +C ARE EQUIVALENT.) +C +C REMEMBER, THERE MUST BE AT LEAST 4 DATA POINTS. +C THIS IS EQUAL TO THE DEFAULT NUMBER OF +C DATA POINTS TO BE USED FOR ESTIMATION OF PAR- +C TIAL DERIVATIVES AT EACH DATA POINT. +C THE ESTIMATED PARTIAL DERIVATIVES ARE +C USED FOR THE CONSTRUCTION OF THE INTERPOLAT- +C ING POLYNOMIAL'S COEFFICIENTS. +C +C LISTED BELOW ARE OPTIONS WHICH CAN ENHANCE +C YOUR PLOT. AN EXAMPLE OF AN APPROPRIATE +C CONOP CALL IS GIVEN FOR EACH OPTION. A +C COMPLETE LIST OF DEFAULT SETTINGS FOLLOWS +C THE LAST OPTION. +C +C OPTIONS +C +C CHL THIS FLAG DETERMINES HOW THE HIGH AND LOW +C CONTOUR VALUES ARE SET. THESE CONTOUR VALUES +C MAY BE SET BY THE PROGRAM OR BY THE USER. IF +C CHL=OFF, THE PROGRAM EXAMINES THE USER'S IN- +C PUT DATA AND DETERMINES BOTH THE HIGH AND LOW +C VALUES. IF CHL=ON, THE USER MUST SPECIFY THE +C DESIRED HIGH (HI) AND LOW (FLO) VALUES. +C THE DEFAULT IS CHL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CHL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=HI, ARRAY(2)=FLO +C +C NOTE: THE VALUES SUPPLIED FOR CONTOUR INCRE- +C MENT AND CONTOUR HIGH AND LOW VALUES ASSUMES +C THE UNSCALED DATA VALUES. SEE THE SDC FLAG, +C BELOW. +C +C EXAMPLE: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=5020. (THE DESIRED +C HIGH CONTOUR VALUE) AND ARRAY(2)= +C 2000 (THE DESIRED LOW CONTOUR VALUE). +C THESE ARE FLOATING POINT NUMBERS. +C +C CIL THIS FLAG DETERMINES HOW THE CONTOUR INCRE- +C MENT (CINC) IS SET. THE INCREMENT IS EITHER +C CALCULATED BY THE PROGRAM (CIL=OFF) USING THE +C RANGE OF HIGH AND LOW VALUES FROM THE USER'S +C INPUT DATA, OR SET BY THE USER (CIL=ON). THE +C DEFAULT IS CIL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CIL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CIL=ON',CINC,1) +C +C NOTE: BY DEFAULT, THE PROGRAM WILL EXAMINE +C THE USER'S INPUT DATA AND DETERMINE THE CONTOUR +C INTERVAL (CINC) AT SOME APPROPRIATE RANGE BETWEEN +C THE LEVEL OF HIGH AND LOW VALUES SUPPLIED, USUALLY +C GENERATING BETWEEN 15 AND 20 CONTOUR LEVELS. +C ELS. +C +C EXAMPLE: CALL CONOP3('CIL=ON',15.,1) +C WHERE 15. REPRESENTS THE +C CONTOUR INCREMENT DESIRED +C BY THE USER. +C +C CON THIS FLAG DETERMINES HOW THE CONTOUR LEVELS +C ARE SET. IF CON=ON, THE USER MUST SPECIFY +C THE ARRAY OF CONTOUR VALUES AND THE NUMBER OF +C CONTOUR LEVELS. A MAXIMUM OF 30 CONTOUR (NCL) +C LEVELS ARE PERMITTED. IF CON=OFF, DEFAULT +C VALUES ARE USED. IN THIS CASE, THE PROGRAM +C WILL CALCULATE THE VALUES FOR THE ARRAY AND +C NCL USING INPUT DATA. THE DEFAULT IS OFF. +C +C IF PROGRAM SET: CALL CONOP3('CON=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CON=ON',ARRAY,NCL) +C +C NOTE: THE ARRAY (ARRAY) CONTAINS THE CONTOUR +C LEVELS (FLOATING POINT ONLY) AND NCL IS THE +C NUMBER OF LEVELS. THE MAXIMUM NUMBER OF CON- +C TOUR LEVELS ALLOWED IS 30. WHEN ASSIGNING +C THE ARRAY OF CONTOUR VALUES, THE VALUES MUST +C BE ORDERED FROM SMALLEST TO LARGEST. +C +C EXAMPLE: +C DATA RLIST(1),...,RLIST(5)/1.,2.,3.,10.,12./ +C +C CALL CONOP3('CON=ON',RLIST,5) WHERE +C 'RLIST' CONTAINS THE USER SPECIFIED +C CONTOUR LEVELS, AND 5 IS THE +C NUMBER OF USER SPECIFIED CONTOUR +C LEVELS (NCL). +C +C WARNING ON CONTOUR OPTIONS: +C IT IS ILLEGAL TO USE THE CON OPTION WHEN +C EITHER CIL OR CHL ARE ACTIVATED. IF +C THIS IS DONE, THE OPTION CALL THAT DETECTED +C THE ERROR WILL NOT BE EXECUTED. +C +C DAS THIS FLAG DETERMINES WHICH CONTOURS ARE +C REPRESENTED BY DASHED LINES. THE USER SETS +C THE DASHED LINE PATTERN. THE USER MAY SPECI- +C FY THAT DASHED LINES BE USED FOR CONTOURS +C WHOSE VALUE IS LESS THAN, EQUAL TO, OR +C GREATER THAN THE DASH PATTERN BREAKPOINT (SEE +C THE DBP OPTION BELOW), WHICH IS ZERO BY +C DEFAULT. IF DAS=OFF (THE DEFAULT VALUE), ALL +C SOLID LINES ARE USED. +C +C ALL SOLID LINES: CALL CONOP4('DAS=OFF',' ',0,0) +C +C IF GREATER: CALL CONOP4('DAS=GTR',PAT,0,0) +C +C IF EQUAL: CALL CONOP4('DAS=EQU',PAT,0,0) +C +C IF LESS: CALL CONOP4('DAS=LSS',PAT,0,0) +C +C IF ALL SAME: CALL CONOP4('DAS=ALL',PAT,0,0) +C +C NOTE: PAT MUST BE A TEN CHARACTER +C STRING WITH A DOLLAR SIGN ($) FOR SOLID AND A +C SINGLE QUOTE (') FOR BLANK. RECALL THAT IN +C FORTRAN 77, IN A QUOTED STRING A SINGLE QUOTE +C IS REPRESENTED BY TWO SINGLE QUOTES (''). +C +C EXAMPLE: +C CALL CONOP4('DAS=GTR','$$$$$''$$$$',0,0) +C +C DBP THIS FLAG DETERMINES HOW THE DASH PATTERN +C BREAK POINT (BP) IS SET. IF DBP=ON, BP MUST +C BE SET BY THE USER BY SPECIFYING BP. IF +C DBP=OFF THE PROGRAM WILL SET BP TO THE +C DEFAULT VALUE WHICH IS ZERO. +C +C IF PROGRAM SET: CALL CONOP3('DBP=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('DBP=ON',BP,1) +C +C NOTE: BP IS A FLOATING POINT NUMBER WHERE THE +C BREAK FOR GTR AND LSS CONTOUR DASH PATTERNS +C ARE DEFINED. BP IS ASSUMED TO BE GIVEN RELA- +C TIVE TO THE UNTRANSFORMED CONTOURS. +C +C EXAMPLE: CALL CONOP3('DBP=ON',5.,1) +C WHERE 5. IS THE USER SPECI- +C FIED BREAK POINT. +C +C DEF RESET FLAGS TO DEFAULT VALUES. ACTIVATING +C THIS OPTION SETS ALL FLAGS TO THE DEFAULT +C VALUE. DEF HAS NO 'ON' OF 'OFF' STATES. +C +C TO ACTIVATE: CALL CONOP1('DEF') +C +C EXT FLAG TO SET EXTRAPOLATION. NORMALLY ALL +C CONRAN VERSIONS WILL ONLY PLOT THE BOUNDARIES +C OF THE CONVEX HULL DEFINED BY THE USER'S DATA. +C TO HAVE THE CONTOURS FILL THE RECTANGULAR +C AREA OF THE FRAME, SET THE EXT SWITCH ON. +C THE DEFAULT IS OFF. +C +C TO TURN ON: CALL CONOP1('EXT=ON') +C +C TO TURN OFF: CALL CONOP1('EXT=OFF') +C +C FMT FLAG FOR THE FORMAT OF THE PLOTTED INPUT DATA +C VALUES. IF FMT=OFF, THE DEFAULT VALUES FOR +C FT, L, AND IF ARE USED. THE DEFAULT VALUES +C ARE: +C +C FT = '(G10.3)' +C L = 7 CHARACTERS INCLUDING THE PARENTHESES +C IF = 10 CHARACTERS PRINTED IN THE OUTPUT +C FIELD BY THE FORMAT +C +C IF FMT=ON, THE USER MUST SPECIFY VALUES FOR +C FT, L, AND IF. ALL USER SPECIFIED VALUES +C MUST BE GIVEN IN THE CORRECT FORMAT. +C +C IF PROGRAM SET: CALL CONOP4('FMT=OFF',' ',0,0) +C +C IF USER SET: CALL CONOP4('FMT=ON',FT,L,IF) +C +C NOTE: FT IS A CHARACTER STRING CONTAINING THE +C FORMAT. THE FORMAT MUST BE ENCLOSED IN +C PARENTHESES. ANY FORMAT, UP TO 10 CHARACTERS +C WHICH IS ALLOWED AT YOUR INSTALLATION WILL BE +C ACCEPTED. L IS THE NUMBER OF CHARACTERS IN +C FT. IF IS THE LENGTH OF THE FIELD CREATED BY +C THE FORMAT. +C +C EXAMPLE: CALL CONOP4('FMT=ON','(G30.2)',7,30) +C +C WARNING: CONRAN WILL NOT TEST FOR A VALID +C FORMAT. THE FORMAT IS ONLY ALLOWED TO BE +C 10 CHARACTERS LONG. +C +C GRI FLAG TO DISPLAY THE GRID. GRI IS OFF BY DEFAULT. +C +C TO TURN ON: CALL CONOP1('GRI=ON') +C +C TO TURN OFF: CALL CONOP1('GRI=OFF') +C +C NOTE: IF GRI IS ON, THE VIRTUAL GRID WILL +C BE SUPERIMPOSED OVER THE CONTOUR PLOT. +C THE X AND Y TICK INTERVALS WILL BE DISPLAYED +C UNDER THE MAP ONLY IF PER=ON. (SEE PER) +C +C INT FLAG TO DETERMINE THE INTENSITIES OF THE CON- +C TOUR LINES AND OTHER PARTS OF THE PLOT. IF +C INT=OFF, ALL INTENSITIES ARE SET TO THE DEFAULT +C VALUES. IF INT=ALL, ALL INTENSITIES ARE SET +C TO THE GIVEN VALUE, IVAL. IF INT IS SET TO +C ONE OF THE OTHER POSSIBLE OPTIONS (MAJ, MIN, +C LAB OR DAT), THE INTENSITY LEVEL FOR THAT +C OPTION IS SET TO THE GIVEN VALUE, IVAL. +C +C IF PROGRAM SET: CALL CONOP2('INT=OFF',0) +C +C ALL THE SAME: CALL CONOP2('INT=ALL',IVAL) +C +C MAJOR LINES: CALL CONOP2('INT=MAJ',IVAL) +C +C MINOR LINES: CALL CONOP2('INT=MIN',IVAL) +C +C TITLE AND MESSAGE: +C CALL CONOP2('INT=LAB',IVAL) +C +C DATA VALUES: CALL CONOP2('INT=DAT',IVAL) +C +C NOTE: 'INT=DAT' RELATES TO THE PLOTTED DATA +C VALUES AND THE PLOTTED MAXIMUMS AND MINIMUMS. +C +C NOTE: IVAL IS THE INTENSITY DESIRED. FOR AN +C EXPLANATION OF THE OPTION VALUE SETTINGS SEE +C THE OPTN ROUTINE IN THE NCAR SYSTEM PLOT +C PACKAGE DOCUMENTATION. BRIEFLY, IVAL VALUES +C RANGE FROM 0 TO 255 OR THE CHARACTER STRINGS +C 'LO' AND 'HI'. THE DEFAULT IS 'HI' EXCEPT +C FOR INT=MIN WHICH IS SET TO 'LO'. +C +C EXAMPLE: CALL CONOP2('INT=ALL',110) +C +C ITP SET THE INTERPOLATION SCHEME. +C THERE ARE TWO SCHEMES--C1 SURFACES AND LINEAR. +C THE C1 METHOD TAKES LONGER BUT WILL GIVE THE +C BEST RESULTS WHEN THE DATA IS SPARSE (LESS +C THAN 100 POINTS). THE LINEAR METHOD WILL +C PRODUCE A BETTER PLOT WHEN THERE IS A DENSE +C DATA SET. THE DEFAULT IS C1 SURFACE. +C +C FOR C1 SURFACE CALL CONOP1('ITP=C1') +C +C FOR LINEAR CALL CONOP1('ITP=LIN') +C +C LAB THIS FLAG CAN BE SET TO EITHER LABEL THE CON- +C TOURS (LAB=ON) OR NOT (LAB=OFF). THE DEFAULT +C VALUE IS LAB=ON. +C +C TO TURN ON: CALL CONOP1('LAB=ON') +C +C TO TURN OFF: CALL CONOP1('LAB=OFF') +C +C LOT FLAG TO LIST OPTIONS ON THE PRINTER. THE DE- +C FAULT VALUE IS SET TO OFF, AND NO OPTIONS +C WILL BE DISPLAYED. +C +C TO TURN ON: CALL CONOP1('LOT=ON') +C +C TO TURN OFF: CALL CONOP1('LOT=OFF') +C +C NOTE: IF USERS WANT TO PRINT THE OPTION +C VALUES, THEY SHOULD TURN THIS OPTION ON. THE +C OPTION VALUES WILL BE SENT TO THE STANDARD +C OUTPUT UNIT AS DEFINED BY THE SUPPORT +C ROUTINE I1MACH. +C +C LSZ THIS FLAG DETERMINES THE LABEL SIZE. IF +C LSZ=OFF, THE DEFAULT ISZLSZ VALUE WILL BE +C USED. IF LSZ=ON, THE USER SHOULD SPECIFY +C ISZLSZ. THE DEFAULT VALUE IS 9 PLOTTER +C ADDRESS UNITS. +C +C IF PROGRAM SET: CALL CONOP2('LSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('LSZ=ON',ISZLSZ) +C +C NOTE: ISZLSZ IS THE REQUESTED CHARACTER +C SIZE IN PLOTTER ADDRESS UNITS. +C +C EXAMPLE: CALL CONOP2('LSZ=ON',4) +C WHERE 4 IS THE USER DESIRED +C INTEGER PLOTTER ADDRESS +C UNITS. +C +C MES FLAG TO PLOT A MESSAGE. THE DEFAULT IS ON. +C +C TO TURN ON: CALL CONOP1('MES=ON') +C +C TO TURN OFF: CALL CONOP1('MES=OFF') +C +C NOTE: IF MES=ON, A MESSAGE IS PRINTED BELOW +C THE PLOT GIVING CONTOUR INTERVALS AND EXECU- +C TION TIME IN SECONDS. IF PER OR GRI ARE ON, +C THE MESSAGE ALSO CONTAINS THE X AND Y TICK +C INTERVALS. +C +C NCP FLAG TO INDICATE THE NUMBER OF DATA POINTS +C USED FOR THE PARTIAL DERIVATIVE +C ESTIMATION. IF NCP=OFF, NUM IS SET TO +C 4, WHICH IS THE DEFAULT VALUE. IF NCP=ON, +C THE USER MUST SPECIFY NUM GREATER THAN OR +C EQUAL TO 2. +C +C IF PROGRAM SET: CALL CONOP2('NCP=OFF',0) +C +C IF USER SET: CALL CONOP2('NCP=ON',NUM) +C +C NOTE: NUM = NUMBER OF DATA POINTS USED FOR +C ESTIMATION. CHANGING THIS VALUE EFFECTS THE +C CONTOURS PRODUCED AND THE SIZE OF INPUT ARRAY +C IWK. +C +C EXAMPLE: CALL CONOP2('NCP=ON',3) +C +C PDV FLAG TO PLOT THE INPUT DATA VALUES. THE +C DEFAULT VALUE IS PDV=OFF. +C +C TO TURN ON: CALL CONOP1('PDV=ON') +C +C TO TURN OFF: CALL CONOP1('PDV=OFF') +C +C NOTE: IF PDV=ON, THE INPUT DATA VALUES ARE +C PLOTTED RELATIVE TO THEIR LOCATION ON THE +C CONTOUR MAP. IF YOU ONLY WISH TO SEE THE +C LOCATIONS AND NOT THE VALUES, SET PDV=ON AND +C CHANGE FMT TO PRODUCE AN ASTERISK (*) SUCH AS +C (I1). +C +C PER FLAG TO SET THE PERIMETER. THE DEFAULT VALUE +C IS PER=ON, WHICH CAUSES A PERIMETER TO BE +C DRAWN AROUND THE CONTOUR PLOT. +C +C TO TURN ON: CALL CONOP1('PER=ON') +C +C TO TURN OFF: CALL CONOP1('PER=OFF') +C +C NOTE: IF MES IS ON, THE X AND Y TICK INTERVALS +C WILL BE GIVEN. THESE ARE THE INTERVALS IN USER +C COORDINATES THAT EACH TICK MARK REPRESENTS. +C +C PMM FLAG TO PLOT RELATIVE MINIMUMS AND MAXIMUMS. +C THIS FLAG IS OFF BY DEFAULT. +C +C TO TURN OFF: CALL CONOP1('PMM=OFF') +C +C TO TURN ON: CALL CONOP1('PMM=ON') +C +C PSL FLAG WHICH SETS THE PLOT SHIELD OPTION. +C THE OUTLINE OF THE SHIELD WILL BE DRAWN ON +C THE SAME FRAME AS THE CONTOUR PLOT. +C BY DEFAULT THIS OPTION IS OFF. +C (SEE SLD OPTION). +C +C DRAW THE SHIELD: CALL CONOP1('PSL=ON') +C +C DON'T DRAW IT: CALL CONOP1('PSL=OFF') +C +C REP FLAG INDICATING THE USE OF THE SAME DATA IN +C A NEW EXECUTION. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP1('REP=ON') +C +C TO TURN OFF: CALL CONOP1('REP=OFF') +C +C NOTE: IF REP=ON, THE SAME X-Y DATA AND TRIANGU- +C LATION ARE TO BE USED BUT IT IS ASSUMED +C THE USER HAS CHANGED CONTOUR VALUES OR RESOLUTION +C FOR THIS RUN. SCRATCH ARRAYS WK AND IWK MUST +C REMAIN UNCHANGED. +C +C SCA FLAG FOR SCALING OF THE PLOT ON A FRAME. +C THIS FLAG IS ON BY DEFAULT. +C +C USER SCALING: CALL CONOP1('SCA=OFF') +C +C PROGRAM SCALING: CALL CONOP1('SCA=ON') +C +C PRIOR WINDOW: CALL CONOP1('SCA=PRI') +C +C NOTE: WITH SCA=OFF, PLOTTING INSTRUCTIONS +C WILL BE ISSUED USING THE USER'S INPUT COORDI- +C NATES, UNLESS THEY ARE TRANSFORMED VIA FX AND +C FY TRANSFORMATIONS. USERS WILL FIND AN +C EXTENDED DISCUSSION IN THE "INTERFACING WITH +C OTHER GRAPHICS ROUTINES" SECTION BELOW. THE SCA +C OPTION ASSUMES THAT ALL INPUT DATA FALLS INTO +C THE CURRENT WINDOW SETTING. WITH SCA=ON, THE +C ENTRY POINT WILL ESTABLISH A VIEWPORT SO THAT +C THE USER'S PLOT WILL FIT INTO THE CENTER 90 +C PERCENT OF THE FRAME. WHEN SCA=PRI, THE +C PROGRAM MAPS THE USER'S PLOT INSTRUCTIONS INTO +C THE PORTION OF THE FRAME DEFINED BY THE +C CURRENT NORMALIZATION TRANSFORMATION. SCA=OFF +C SHOULD BE USED TO INTERFACE WITH EZMAP. +C +C SDC FLAG TO DETERMINE HOW TO SCALE THE DATA ON +C THE CONTOURS. IF SDC=OFF, THE FLOATING POINT +C VALUE IS GIVEN BY SCALE. IF SDC=ON, THE USER +C MAY SPECIFY SCALE. THE DEFAULT VALUE FOR SCALE +C IS 1. +C +C IF PROGRAM SET: CALL CONOP3('SDC=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('SDC=ON',SCALE,1) +C +C NOTE: THE DATA PLOTTED ON CONTOUR LINES AND +C THE DATA PLOTTED FOR RELATIVE MINIMUMS AND +C MAXIMUMS WILL BE SCALED BY THE FLOATING POINT +C VALUE GIVEN BY SCALE. TYPICAL SCALE VALUES +C ARE 10., 100., 1000., ETC. THE ORIGINAL DATA +C VALUES ARE MULTIPLIED BY SCALE. SCALE MUST BE +C A FLOATING POINT NUMBER AND IS DISPLAYED IN THE +C MESSAGE (SEE MES). +C +C EXAMPLE: CALL CONOP2('SDC=ON',100.,1) +C +C SLD ACTIVATE OR DEACTIVATE THE SHIELDING OPTION. +C WHEN THIS OPTION IS ACTIVATED, ONLY THOSE +C CONTOURS WITHIN THE SHIELD ARE DRAWN. THE SHIELD +C IS A POLYGON SPECIFIED BY THE USER WHICH MUST +C BE GIVEN IN THE SAME COORDINATE RANGE AS THE +C THE DATA. IT MUST DEFINE ONLY ONE POLYGON. +C +C TO ACTIVATE THE SHIELD: +C CALL CONOP3('SLD=ON',ARRAY,ICSD) +C +C TO DEACTIVATE THE SHIELD: +C CALL CONOP3('SLD=OFF',0.,0) +C +C NOTE: ARRAY IS A REAL ARRAY ICSD ELEMENTS LONG. +C THE FIRST ICSD/2 ELEMENTS ARE X COORDINATES AND +C THE SECOND ICSD/2 ELEMENTS ARE Y COORDINATES. +C ICSD IS THE LENGTH OF ENTIRE ARRAY, THE +C NUMBER OF (X + Y) SHIELD COORDS. THE POLYGON +C MUST BE CLOSED, THAT IS THE FIRST AND LAST +C POINTS DESCRIBING IT MUST BE THE SAME. +C +C EXAMPLE: DIMENSION SHLD +C DATA SHLD/ 7.,10.,10.,7.,7., +C 1 7.,7.,10.,10.,7./ +C CALL CONOP3 (6HSLD=ON,SHLD,10) +C +C +C SML FLAG TO DETERMINE THE SIZE OF MINIMUM AND +C MAXIMUM CONTOUR LABELS. IF SML=OFF, THE +C ISZSML DEFAULT VALUE OF 15 IS USED. +C IF SML=ON, THE USER MUST SPECIFY ISZSML. +C +C IF PROGRAM SET: CALL CONOP2('SML=OFF',0) +C +C IF USER SET: CALL CONOP2('SML=ON',ISZSML) +C +C NOTE: ISZSML IS AN INTEGER NUMBER WHICH IS +C THE SIZE OF LABELS IN PLOTTER ADDRESS UNITS +C AS DEFINED IN THE SPPS ENTRY WTSTR. +C +C EXAMPLE: CALL CONOP2('SML=ON',12) +C +C SPD FLAG FOR THE SIZE OF THE PLOTTED INPUT DATA +C VALUES. IF SPD=OFF, THE VALUE OF ISZSPD IS +C 8, WHICH IS THE DEFAULT. IF SPD=ON, THE USER +C MUST SPECIFY ISZSPD. +C +C IF PROGRAM SET: CALL CONOP2('SPD=OFF',0) +C +C IF USER SET: CALL CONOP2('SPD=ON',ISZSPD) +C +C NOTE: ISZSPD IS AN INTEGER NUMBER GIVING THE +C SIZE TO PLOT THE DATA VALUES IN PLOTTER ADDRESS +C UNITS AS DEFINED IN THE SPPS ENTRY WTSTR. . +C +C EXAMPLE: CALL CONOP2('SPD=ON',6) +C +C SSZ FLAG TO DETERMINE THE RESOLUTION (NUMBER OF +C STEPS IN EACH DIRECTION). IF SSZ=ON, THE +C USER SETS ISTEP, OR, IF SSZ=OFF, THE PROGRAM +C WILL AUTOMATICALLY SET ISTEP AT THE DEFAULT +C VALUE OF 40. +C +C IF PROGRAM SET: CALL CONOP2('SSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('SSZ=ON',ISTEP) +C +C NOTE: ISTEP IS AN INTEGER SPECIFYING THE DENSITY +C OF THE VIRTUAL GRID. IN MOST CASES, THE DEFAULT +C VALUE OF 40 PRODUCES PLEASING CONTOURS. FOR +C COARSER BUT QUICKER CONTOURS, LOWER THE +C VALUE. FOR SMOOTHER CONTOURS AT +C THE EXPENSE OF TAKING LONGER TIME, RAISE +C THE VALUE. NOTE: FOR STEP SIZES GREATER +C THAN 200 IN CONRAN, THE ARRAYS PV IN COMMON +C CONRA1 AND ITLOC IN COMMON CONRA9, MUST BE +C EXPANDED TO ABOUT 10 MORE THAN ISTEP. +C SEE CONRA1 AND CONRA9 COMMENTS BELOW FOR MORE +C INFORMATION. +C +C EXAMPLE: CALL CONOP2('SSZ=ON',25) +C THIS ISTEP VALUE WILL PRO- +C DUCE A COARSE CONTOUR. +C +C STL FLAG TO DETERMINE THE SIZE OF THE TITLE. +C ISZSTL MAY BE SET BY THE USER (STL=ON), OR +C THE PROGRAM WILL SET IT TO THE DEFAULT SIZE +C OF 16 PLOTTER ADDRESS UNITS (STL=OFF). +C +C IF PROGRAM SET: CALL CONOP2('STL=OFF',0) +C +C IF USER SET: CALL CONOP2('STL=ON',ISZSTL) +C +C NOTE: WHEN 30 OR 40 CHARACTERS ARE USED FOR +C THE TITLE, THE DEFAULT SIZE OF 16 PLOTTER +C ADDRESS UNITS WORKS WELL. FOR LONGER TITLES, +C A SMALLER TITLE SIZE IS REQUIRED. +C +C EXAMPLE: CALL CONOP2('STL=ON',13) +C +C TEN FLAG TO DETERMINE THE TENSION FACTOR APPLIED +C WHEN SMOOTHING CONTOUR LINES. THE USER MAY +C SET TENS OR ALLOW THE PROGRAM TO SET THE +C VALUE. IF USER SET, TENS MUST HAVE A VALUE +C GREATER THAN ZERO AND LESS THAN OR EQUAL TO +C 30. THE DEFAULT VALUE IS 2.5. +C +C IF PROGRAM SET: CALL CONOP3('TEN=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('TEN=ON',TENS,1) +C +C NOTE: TENS IS NOT AVAILABLE IN THE STANDARD +C VERSION OF CONRAN. +C SMOOTHING OF CONTOUR LINES IS ACCOMPLISHED +C WITH SPLINES UNDER TENSION. TO ADJUST THE +C AMOUNT OF SMOOTHING APPLIED, ADJUST THE TEN- +C SION FACTOR. SETTING TENS VERY LARGE +C (I.E. 30.), EFFECTIVELY SHUTS OFF SMOOTHING. +C +C EXAMPLE: CALL CONOP3('TEN=ON',14.,1) +C +C TFR FLAG TO ADVANCE THE FRAME BEFORE TRIANGULATION. +C THE DEFAULT VALUE IS TFR=ON, WHICH MEANS THAT +C THE CONTOURS AND THE TRIANGLES WILL BE PLOTTED +C ON SEPARATE FRAMES. +C +C IF PROGRAM SET: CALL CONOP1('TFR=ON') +C +C TO TURN OFF: CALL CONOP1('TFR=OFF') +C +C NOTE: TRIANGLES ARE PLOTTED AFTER THE CON- +C TOURING IS COMPLETED. TO SEE THE TRIANGLES +C OVER THE CONTOURS, TURN THIS SWITCH OFF. +C +C TLE FLAG TO PLACE A TITLE AT THE TOP OF THE PLOT. +C IF TLE=ON, THE USER MUST SPECIFY CHARS AND +C INUM. CHARS IS THE CHARACTER STRING CONTAINING +C THE TITLE. INUM IS THE NUMBER OF CHARACTERS +C IN CHARS. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP4('TLE=ON',CHARS,INUM,0) +C +C TO TURN OFF: CALL CONOP4('TLE=OFF',' ',0,0) +C +C NOTE: IF LONGER THAN 64-CHARACTER TITLES ARE +C DESIRED, THE CHARACTER VARIABLE ISTRNG FOUND +C IN CONRA7 MUST BE INCREASED APPROPRIATELY. +C +C EXAMPLE: CALL CONOP4('TLE=ON','VECTOR REVIEW' +C ,13,0) +C +C TOP FLAG TO PLOT ONLY THE TRIANGLES. +C +C TO TURN OFF: CALL CONOP1('TOP=OFF') +C +C TO TURN ON: CALL CONOP1('TOP=ON') +C +C NOTE: THE USER MAY WISH TO OVERLAY THE TRIAN- +C GLES ON SOME OTHER PLOT. 'TOP=ON' WILL +C ALLOW THAT. THIS OPTION WHEN ACTIVATED +C (TOP=ON), WILL SET TRI=ON, AND TFR=OFF. IF +C THE USER WANTS TFR=ON, IT SHOULD BE SET AFTER +C TOP IS SET. IF THE USER SETS TOP=OFF IT WILL +C SET TRI=OFF AND TFR=ON. IF THE USER WANTS TRI +C OR TFR DIFFERENT, SET THEM AFTER THE +C TOP CALL. +C +C TRI FLAG TO PLOT THE TRIANGULATION. THE DEFAULT IS +C OFF AND THEREFORE THE TRIANGLES ARE NOT DRAWN. +C +C TO TURN ON: CALL CONOP1('TRI=ON') +C +C TO TURN OFF: CALL CONOP1('TRI=OFF') +C +C NOTE: PLOTTING THE TRIANGLES WILL INDICATE TO +C THE USER WHERE GOOD AND BAD POINTS OF INTER- +C POLATION ARE OCCURRING IN THE CONTOUR MAP. +C EQUILATERAL TRIANGLES ARE OPTIMAL FOR INTER- +C POLATION. QUALITY DEGRADES AS TRIANGLES +C APPROACH A LONG AND NARROW SHAPE. THE CONVEX +C HULL OF THE TRIANGULATION IS ALSO A POOR +C POINT OF INTERPOLATION. +C +C OPTION DEFAULT BELOW ARE LISTED THE DEFAULT +C VALUES VALUES FOR THE VARIOUS OPTIONS GIVEN ABOVE. +C UNLESS THE USER SPECIFIES OTHERWISE, THESE +C VALUES WILL BE USED IN EXECUTION OF THE VARI- +C OUS OPTIONS. +C +C CHL=OFF LOT=OFF SLD=OFF +C CIL=OFF LSZ=OFF SML=OFF +C CON=OFF MES=ON SPD=OFF +C DAS=OFF NCP=OFF SPT=OFF +C DBP=OFF PDV=OFF SSZ=OFF +C EXT=OFF PER=ON STL=OFF +C FMT=OFF PMM=OFF TEN=OFF +C GRI=OFF REP=OFF TFR=ON +C ITP=C1 SCA=ON TOP=OFF +C LAB=ON SDC=OFF TRI=OFF +C +C DEFAULT VALUES FOR THE OPTION DEFAULT VALUES GIVEN ABOVE, IF +C USER SPECIFIED USED, WILL SET DEFAULT VALUES FOR THE FOLLOW- +C PARAMETERS ING PARAMETERS: +C +C PARAMETER DEFAULT +C --------- ------- +C +C ARRAY UP TO 30 CONTOUR LEVELS ALLOWED. +C VALUES ARE COMPUTED BY THE +C PROGRAM, BASED ON INPUT. +C +C BP 0. +C +C CINC COMPUTED BY THE PROGRAM BASED ON THE +C RANGE OF HI AND LO VALUES OF THE +C INPUT DATA. +C +C FLO COMPUTED BY THE PROGRAM BASED ON THE +C LOWEST UNSCALED INPUT DATA. +C +C FT (G10.3) PARENTHESES MUST BE +C INCLUDED. +C +C HI COMPUTED BY THE PROGRAM BASED ON THE +C HIGHEST UNSCALED INPUT DATA. +C +C CHARS NO TITLE +C +C IF 10 CHARACTERS +C +C INUM NO TITLE +C +C IPAT '$$$$$$$$$$' (THIS IS A 10 CHARACTER +C STRING.) +C +C ISZLSZ 9 PLOTTER ADDRESS UNITS +C +C ISZSML 15 PLOTTER ADDRESS UNITS +C +C ISZSPD 8 PLOTTER ADDRESS UNITS +C +C ISZSTL 16 PLOTTER ADDRESS UNITS +C +C ISTEP 40 +C +C IVAL 'HI' FOR ALL EXCEPT MINOR CON- +C TOUR LINES WHICH ARE 'LO'. +C +C L 7 CHARACTERS (INCLUDING BOTH +C PARENTHESES) +C +C NCL COMPUTED BY THE PROGRAM BASED ON +C INPUT DATA. UP TO 30 CONTOUR +C LEVELS ARE PERMITTED. +C +C NUM 4 DATA POINTS +C +C SCALE 1. (NO SCALING PERFORMED) +C +C TENS 2.5 +C +C ICSD 0 (NO SHIELD) +C +C OPTIONS WHICH THE SHAPE OF THE CONTOURS MAY BE MODIFIED BY +C EFFECT THE CHANGING NCP AND SSZ. NCP CONTROLS THE +C CONTOURS NUMBER OF DATA POINTS TO BE USED IN THE +C INTERPOLATION. INCREASING NCP CAUSES MORE +C OF THE SURROUNDING DATA TO INFLUENCE THE +C POINT OF INTERPOLATION. SOME DATASETS CAUSE +C DIFFICULTY WHEN TRYING TO PRODUCE MEANINGFUL +C CONTOURS (TRIANGLES WHICH ARE LONG AND NARROW). +C BY MODIFYING NCP A USER CAN FINE-TUNE A +C PLOT. INCREASING ISTEP, THE DENSITY OF THE +C VIRTUAL GRID, WILL SMOOTH OUT THE CONTOUR +C LINES AND PICK UP MORE DETAIL (NEW CONTOURS +C WILL APPEAR AS ISTEP INCREASES AND OLD ONES WILL +C SOMETIMES BREAK INTO MORE DISTINCT UNITS). +C ISTEP IS CHANGED BY THE SSD OPTION. +C +C NOTE IF NCP.GT.25, ARRAYS DSQ0 AND IPC0 IN CONDET +C MUST BE ADJUSTED ACCORDINGLY. ALSO NCPSZ IN +C CONBDN (25 BY DEFAULT), MUST BE INCREASED TO +C NCP. THE DEFAULT VALUE OF NCP, WHICH IS 4, +C PRODUCES PLEASING PICTURES IN MOST CASES. +C HOWEVER, FINE-TUNING OF THE INTERPOLATION CAN +C BE OBTAINED BY INCREASING THE SIZE OF NCP, +C WITH A CORRESPONDING LINEAR INCREASE IN WORK +C SPACE. +C +C THE INTERPOLATION METHOD USED WILL ALSO CAUSE +C DIFFERENT LOOKING CONTOURS. THE C1 METHOD +C IS RECOMMENDED WHEN THE DATA IS SPARSE. IT +C WILL SMOOTH THE DATA AND ADD TRENDS (FALSE +C HILLS AND VALLEYS). THE LINEAR METHOD IS +C RECOMMENDED WHEN DATA IS DENSE (GT 50 TO 100) +C IT WILL NOT SMOOTH THE DATA OR ADD TRENDS. +C +C INTERFACING WITH NORMALLY THE SCALING FACTOR WILL BE SET TO OFF. +C OTHER GRAPHICS IN MOST CASES MAPPING CAN BE PERFORMED BEFORE +C ROUTINES CALLING THE CONRAN ENTRY POINT, THUS SAVING THE +C USER FROM MODIFYING THE FILE. IF REASONABLE +C RESULTS CANNOT BE OBTAINED, THE STATEMENT +C FUNCTIONS, FX AND FY, WILL HAVE TO BE REPLACED. +C THE ROUTINES HAVING THESE STATEMENT FUNCTIONS +C ARE: +C +C CONDRW, CONPDV, CONTLK, CONPMS, CONGEN +C +C REFERENCES AKIMA, HIROSHA +C A METHOD OF BIVARIATE INTERPOLATION AND +C SMOOTH SURFACE FITTING FOR IRREGULARLY +C DISTRIBUTED DATA POINTS. +C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE +C VOL 4, NO. 2, JUNE 1978, PAGES 148-159 +C LAWSON, C.L. +C SOFTWARE FOR C1 SURFACE INTERPOLATION +C JPL PUBLICATION 77-30 +C AUGUST 15, 1977 +C +C CONRAN ERROR ERROR ROUTINE MESSAGE +C MESSAGES +C 1 CONRAN INPUT PARAMETER NDP LT NCP +C 2 CONRAN NCP GT MAX SIZE OR LT 2 +C 3 CONTNG ALL COLINEAR DATA POINTS +C 4 CONTNG IDENTICAL INPUT DATA POINTS +C FOUND +C 5 CONOP UNDEFINED OPTION +C 6 CONCLS CONSTANT INPUT FIELD +C 7 CONOP INCORRECT CONOP CALL USED +C 8 CONOP ILLEGAL USE OF CON OPTION +C WITH CIL OR CHL OPTIONS +C 9 CONOP NUMBER OF CONTOUR LEVELS +C EXCEEDS 30 +C 10 CONDRW CONTOUR STORAGE EXHAUSTED +C THIS ERROR IS TRAPPED AND +C NULLIFIED BY CONRAN. IT +C SERVES TO SIGNAL THE USER +C THAT A CONTOUR LEVEL MAY NOT +C BE COMPLETE. +C 11 CONSTP ASPECT RATIO OF X AND Y +C GREATER THAN 5 TO 1. +C (THIS ERROR MAY CAUSE A POOR +C QUALITY PLOT. USUALLY THIS +C CAN BE FIXED BY MULTIPLYING +C X OR Y BY A CONSTANT FACTOR. +C IF THIS SOLUTION IS +C UNACCEPTABLE THEN INCREASING +C SSZ TO A VERY LARGE VALUE +C MAY HELP. NOTE: THIS CAN BE +C EXPENSIVE.) +C +C THE ERRORS LISTED ABOVE ARE DEFINED AS RECOVERABLE +C ERRORS SHOULD THE USER WISH TO USE THEM IN THAT +C FASHION. THE DOCUMENTATION ON THE ERPRT77 PACKAGE +C EXPLAINS HOW TO RECOVER FROM AN ERROR. +C +C NOTE: THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY. NOT ALL MEMBERS WILL USE ALL +C THE COMMON VARIABLES. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER AROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN'S +C AND MAX'S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN, MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IRED-ERPRT77 RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING (STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING CONTAINING THE TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT INTENSITY SETTING +C INMAJ-CONTOUR LEVEL INTENSITY FOR MAJOR LINES +C INMIN-CONTOUR LEVEL INTENSITY FOR MINOR LINES +C INLAB-TITLE AND MESSAGE INTENSITY +C INDAT-DATA VALUE INTENSITY +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM RIGHT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y COORDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVATIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORDINATES FOR SHIELDING +C YVS-ARRAY OF THE Y COORDINATES FOR SHIELDING +C IXVST-POINTER TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDARY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICATE STATUS OF SHIELD PLOTTING +C CONR14 +C LINEAR-C1 LINEAR INTERPOLATING FLAG +C CONR15 +C ISTRNG-TITLE OF THE PLOT +C CONR16 +C FORM-FORMAT USED FOR DATA +C CONR17 +C NDASH-DASH PATTERN USED FOR CONTOUR LINES LESS THAN BP +C IDASH-DASH PATTERN USED FOR CONTOUR LINES GREATER THAN BP +C EDASH-DASH PATTERN USED FOR CONTOUR LINES EQUAL TO THE BP +C RANINT +C IRANMJ-COLOR INDEX FOR NORMAL (MAJOR) INTENSITY LINES +C IRANMN-COLOR INDEX FOR LOW INTENSITY LINES +C IRANMJ-COLOR INDEX FOR TEXT (LABELS) +C +C +NOAO - Blockdata data conbdn rewritten as run time initialization +C Variable LNGTHS not used. +C +C EXTERNAL CONBDN +C DIMENSION LNGTHS(4), HOLD(4) + DIMENSION HOLD(4) +C - NOAO + CHARACTER*110 IWORK + CHARACTER*13 ENCSCR, ENSCRY + CHARACTER*1 ICHAR + CHARACTER*500 DPAT + REAL WIND(4), VIEW(4), NWIND(4), NVIEW(4) + DIMENSION XD(*) ,YD(*) ,ZD(*) ,WK(*) , + 1 IWK(*) ,SCRARR(*) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI + SAVE +C +C +C+NOAO - Variable LNGTHS not used. +C DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4)/13,4,21,6/ +C-NOAO +C +C ICONV CONVERT FORM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C IABOVE AMOUNT TITLE IS PLACED ABOVE PLOT +C IBELOW, IBEL2 AMOUNT MESSAGE IS BELOW PLOT +C +C DATA IABOVE,IBELOW,IBEL2/30,-30,-45/ +C +C + NOAO - Label placement is improved by changed these values. Also, +C call the run time initialization subroutine, conbdn. +C + iabove = 30 + ibelow = -15 + ibel2 = -30 + call conbdn +C - NOAO +C +C THE FOLLOWING CALL IS FOR MONOTORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','CONRAN','CONRAN','VERSION 01') +C +C LIST THE OPTION VALUES IF REQUESTED +C + IF (LISTOP) CALL CONOUT (2) +C +C SET SWITCH TO MAP TRIANGLES, IN CONLOC, FOR QUICK SEARCHES +C + NIT = 0 +C +C TEST TO SEE IF ENOUGH INPUT DATA +C + IF (NDP.GE.NCP) GO TO 10 + CALL SETER (' CONRAN - INPUT PARAMETER NDP LESS THAN NCP',1, + 1 IREC) + RETURN +C + 10 IF (NCPSZ.GE.NCP .AND. NCP.GE.2) GO TO 20 + CALL SETER (' CONRAN - NCP LT 2 OR GT NCPSZ',2,IREC) +C + 20 IWK(1) = NDP + IWK(2) = NCP + IWK(3) = 1 +C +C SET POLYLINE COLOR ASF TO INDIVIDUAL +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE AND TEXT COLOR +C + CALL GQPLCI(IERR,OCOLI) + CALL GQTXCI(IERR,OTEXCI) +C +C SET POLYLINE AND TEXT COLOR TO VALUE IN COMMON +C + CALL GSPLCI(IRANMJ) + CALL GSTXCI(IRANTX) +C +C CONSTRUCTION OF WORK SPACE POINTERS +C +C TRIANGLE POINT NUMBERS +C + JWIPT = 16 +C +C SCRATCH SPACE +C + JWIWL = 6*NDP + 1 +C +C END POINTS OF BORDER LINE SEGMENTS AND TRIANGLE NUMBER +C + JWIPL = 24*NDP + 1 +C +C POINT NUMBERS WHERE THE NCP DATA POINTS AROUND EACH POINT +C + JWIPC = 27*NDP + 1 +C +C SCRATCH SPACE +C + JWIWP = 30*NDP + 1 +C +C PARTIAL DERIVATIVES AT EACH DATA POINT +C + IPR = 8*NDP + 1 +C +C TEST IF REPEAT (JUST NEW CONTOURS OF INTERPOLATED DATA) +C OR NO REPEAT (TRIANGULATE AND CONTOUR) +C + IF (REPEAT) GO TO 30 +C +C TRIANGULATES THE X-Y PLANE. +C + CALL CONTNG (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),IWK(JWIWL), + 1 IWK(JWIWP),WK) + IF (NERRO(ITEMP).NE.0) RETURN +C + IWK(5) = NT + IWK(6) = NL + NTNL = NT+NL +C +C SKIP IF NOT LINEAR INTERPOLATION +C + IF (.NOT.LINEAR) GO TO 25 +C +C FIND THE COEFICENTS FOR LINER INTERPOLATION OF EACH TRIANGLE +C + CALL CONLIN(XD,YD,ZD,NT,IWK(JWIPT),WK(IPR)) + GO TO 35 +C +C +C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. +C + 25 CALL CONDET (NDP,XD,YD,NCP,IWK(JWIPC)) +C +C ESTIMATE THE PARTIAL DERIVATIVES AT ALL DATA POINTS +C + CALL CONINT (NDP,XD,YD,ZD,NCP,IWK(JWIPC),WK(IPR)) +C +C VERIFY DATA VALUES VALID +C + 30 NT = IWK(5) + NL = IWK(6) + NTNL = NT+NL +C +C COMPUTE STEP SIZE FOR CONTOURING +C + 35 CALL CONSTP (XD,YD,NDP) +C +C SAVE ORIGINAL WINDOW, VIEWPORT OF TRANSFORMATION 1, AND ORIGINAL +C LOG SCALING FLAG. +C + CALL GQCNTN(IER,IOLDNT) + CALL GQNT(IOLDNT,IER,WIND,VIEW) + RX1 = VIEW(1) + RX2 = VIEW(2) + RY1 = VIEW(3) + RY2 = VIEW(4) +C SAVE NORMALIZATION TRANSFORMATION 1 + CALL GQNT(1,IER,WIND,VIEW) + CALL GETUSV('LS',IOLLS) +C +C DETERMINE SCALING OPTION +C + ISC = ISCALE+1 + GO TO ( 40, 60, 50),ISC +C +C CONRAN SETS SCALING FACTOR +C + 40 CALL SET(PXST,PXED,PYST,PYED,XST,XED,YST,YED,1) + GO TO 60 +C +C CONRAN PLOTS WITHIN USERS BOUNDARIES +C + 50 CALL SET(RX1,RX2,RY1,RY2,XST,XED,YST,YED,1) +C +C IF TRIANGULATION PLOT ONLY BRANCH +C + 60 IF (EXTRI) GO TO 390 +C +C GENERATE CONTOURS IF NONE SUPPLIED BY USER +C + CALL CONCLS (ZD,NDP) + IF (NERRO(ITEMP).NE.0) RETURN +C +C REORDER THE CONTOUR LINES FOR CORRECT PATTERN DISPLAY +C + MAJLNS = 0 + IF (LABON) CALL CONREO (MAJLNS) +C +C MAKE SURE INTEGER COORDINATES IN 1-1024 RANGE +C + CALL SETUSV('XF',10) + CALL SETUSV('YF',10) +C +C SET THE DASH PATTERNS TO DEFAULT IF THEY HAVE NOT BEEN SET +C +C + IF (IDASH(1:1).NE.' ') GO TO 80 +C +C SET POSITIVE CONTOUR VALUE TO DEFAULT +C + IDASH = '$$$$$$$$$$' + 80 IF (NDASH(1:1).NE.' ') GO TO 100 +C +C SET NEGATIVE CONTOUR DASH PATTERN TO DEFAULT +C + NDASH = '$$$$$$$$$$' + 100 IF (EDASH(1:1).NE.' ') GO TO 120 +C +C SET EQUAL CONTOUR DASH PATTERN TO DEFAULT +C + EDASH = '$$$$$$$$$$' +C +C INITIALIZE THE CONTOURING DATA STRUCTURE +C + 120 IF (.NOT.EXTRAP) YST = YST+STPSZ +C +C LOAD THE SCRATCH SPACE +C + CALL CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C PERFORM SHIELDING IF SO REQUESTED +C + IF (SHIELD) CALL CONSLD(SCRARR) +C +C ******************************************************* +C * * +C * IF THE USER NEEDS TO DIVIDE THE PROGRAM UP * +C * THIS IS THE BREAK POINT. ALL SUBROUTINES CALLED * +C * PRIOR TO THIS MESSAGE ARE NOT USED AGAIN AND * +C * ALL ROUTINES AFTER THIS MESSAGE ARE NOT USED * +C * ANY EARLIER. NOTE THIS ONLY REFEARS TO ENTRY POINTS* +C * WHICH ARE PART OF THE CONRAN PACKAGE. * +C * ALL DATA STRUCTURES AND VARIABLES MUST BE RETAINED. * +C ******************************************************* +C +C +C PLOT RELATIVE MINIMUMS AND MAXIMUMS IF REQUESTED +C + IF (PMIMX) CALL CONPMM (SCRARR) +C +C + LENDAS = NREP*10 +C +C SET THE ERROR MODE TO RECOVERY FOR THE CONTOURING STORAGE ERROR +C + CALL ENTSR (IROLD,1) +C +C DRAW THE CONTOURS +C + DO 250 I=1,NCL +C + CONV = CL(I) + IF (CONV.GE.BPSIZ) GO TO 150 +C +C SET UP NEGATIVE CONTOUR PATTERN +C + DO 140 J=1,10 + ICHAR = NDASH(J:J) + DO 130 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 130 CONTINUE + 140 CONTINUE + GO TO 210 +C +C SET UP POSITIVE CONTOUR DASH PATTERN +C + 150 IF (CONV.EQ.BPSIZ) GO TO 180 + DO 170 J=1,10 + ICHAR = IDASH(J:J) + DO 160 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 160 CONTINUE + 170 CONTINUE + GO TO 210 +C +C SET UP EQUAL CONTOUR DASH PATTERN +C + 180 DO 200 J=1,10 + ICHAR = EDASH(J:J) + DO 190 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 190 CONTINUE + 200 CONTINUE +C + 210 IF (I.GT.MAJLNS) GO TO 230 +C +C SET UP MAJOR LINES +C + CALL GSPLCI (IRANMJ) + CALL CONECD (CONV,IWORK,NCUSED) + NCHAR = LENDAS + NCUSED + DPAT(LENDAS+1:NCHAR) = IWORK(1:NCUSED) + GO TO 240 +C +C SET UP MINOR LINES +C + 230 NCHAR = 10 + CALL GSPLCI (IRANMN) +C +C PROCESS FOR ALL CONTOURS +C + 240 CALL DASHDC (DPAT(1:NCHAR),NCRT,ISIZEL) +C +C DRAW ALL CONTOURS AT THIS LEVEL +C + CALL CONDRW (SCRARR) +C +C GET NEXT CONTOUR LEVEL +C + 250 CONTINUE +C +C CONTOURING COMPLETED CHECK FOR OPTIONAL OUTPUTS ON PLOT +C +C FIRST SET ERROR MODE BACK TO USERS VALUE +C + CALL RETSR (IROLD) +C +C GET PLOT BOUNDRIES FOR TITLING AND MESSAGE POSITIONING +C + CALL GQCNTN(IER,ICN) + CALL GQNT(ICN,IER,NWIND,NVIEW) + XST = NWIND(1) + XED = NWIND(2) + YST = NWIND(3) + YED = NWIND(4) + CALL GETUSV('LS',LT) +C +C RESET POLYLINE COLOR INDEX TO MAJOR (NORMAL) +C + CALL GSPLCI (IRANMJ) +C +C DRAW SHIELD ON PLOT IF REQUESTED +C + IF(SLDPLT.AND.SHIELD) CALL CONDSD +C +C DRAW PERIMETER ARROUND PLOT IF DESIRED +C + IF (PER) CALL PERIM (ITICK,0,ITICK,0) +C +C DRAW GRID IF REQUESTED +C + IF (GRD) CALL GRID (ITICK,0,ITICK,0) +C +C PLOT THE DATA VALUES IF REQUESTED +C + IF (.NOT.PLDVLS) GO TO 260 + CALL CONPDV (XD,YD,ZD,NDP) +C +C OUTPUT TITLE IF REQUESTED +C + 260 IF (.NOT.TITLE) GO TO 270 + CALL GSTXCI (IRANTX) + CALL FL2INT (XED,YED,MX,MY) + MY = (MY/ICONV)+IABOVE + ILAST = 64 + DO 261 I = 64,1,-1 + IF (ISTRNG(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 262 + ENDIF + 261 CONTINUE + 262 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY) + CALL WTSTR(XC,YC,ISTRNG(1:ILAST),ITLSIZ,0,0) + CALL GSELNT(ICN) +C +C +C OUTPUT MESSAGE IF REQUESTED +C + 270 IF (.NOT.MESS) GO TO 390 +C + CALL GSTXCI(IRANTX) + CALL FL2INT (XST,YST,MX,MY) + MY = (MY/ICONV) +C +C IF PERIMETER OR GRID PUT OUT TICK INTERVAL +C + IMSZ = 0 + IF (.NOT.PER .AND. .NOT.GRD) GO TO 300 + IWORK(1:36) = 'X INTERVAL= Y INTERVAL=' +C +C +NOAO - FTN internal writes rewritten as calls to encode. +C WRITE(ENCSCR,'(G13.5)')XRG +C WRITE(ENSCRY,'(G13.5)')YRG + call encode (13, '(f13.5)', encscr, xrg) + call encode (13, '(f13.5)', enscry, yrg) +C -NOAO + IWORK(12:24) = ENCSCR + IWORK(37:49) = ENSCRY + IMSZ = 50 + 300 IF (SCALE .EQ. 1.) GOTO 330 + IWORK(IMSZ:IMSZ+10) = ' SCALED BY ' +C +NOAO +C WRITE(ENCSCR,'(G13.5)')SCALE + call encode (13, '(f13.5)', encscr, scale) +C -NOAO + IWORK(IMSZ+11:IMSZ+23) = ENCSCR + IMSZ = 73 + 330 IF (IMSZ .NE. 0) THEN + ILAST = IMSZ + DO 291 I = IMSZ,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 292 + ENDIF + 291 CONTINUE + 292 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBEL2) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) + ENDIF +C +C PRODUCE CONTOUR INFO +C + IWORK(1:42) = 'CONTOUR FROM TO ' + IWORK(43:77) = 'CONTOUR INTERVAL OF ' + HOLD(1) = FLO + HOLD(2) = HI + HOLD(3) = FINC +C +C +NOAO +C WRITE(ENCSCR,'(G13.5)')HOLD(1) + call encode (13, '(f13.5)', encscr, hold(1)) + IWORK(13:25) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(2) + call encode (13, '(f13.5)', encscr, hold(2)) + IWORK(29:41) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(3) + call encode (13, '(f13.5)', encscr, hold(3)) + IWORK(62:74) = ENCSCR +C -NOAO +C +C IF IRREGULAR SPACED CONTOURS MODIFY CONTOUR INTERVAL STATEMENT +C + IF (FINC.GE.0.) GO TO 380 + NC = 62 + IWORK(NC:NC+15) = ' IRREGULAR ' +C + ILAST = 77 + 380 DO 381 I = 77,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 382 + ENDIF + 381 CONTINUE + 382 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBELOW) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) +C +C +C +C PLOT TRIANGLES IF REQUESTED +C + 390 IF (LOOK) THEN + CALL GSPLCI(IRANMN) + CALL CONTLK (XD,YD,NDP,IWK(JWIPT)) + CALL GSPLCI(IRANMJ) + ENDIF +C RESTORE NORMALIZATION TRANSFORMATION 1 AND LOG SCALING + IF (ISCALE .NE. 1) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER + CALL GSELNT (IOLDNT) +C +C RESTORE ORIGINAL COLOR +C + CALL GSPLCI(OCOLI) + CALL GSTXCI(OTEXCI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IT WAS ON ENTRY TO GRIDAL +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) + RETURN + END + SUBROUTINE CONPMM (SCRARR) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - IXRG IN THE X DIRECTION AND + OR - IYRG IN THE Y DIRECTION. +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(*) + CHARACTER*10 IA + SAVE +C +C CONVERT FROM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C ACCESSING FUNCTION INTO SCRARR +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C GRAPHICS MAPPING FUNCTIONS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C MAPPING FROM INTEGER TO USER INPUT FLOATING POINT +C + CONVX(IXX) = XST + FLOAT(IXX-1)*STPSZ + CONVY(IYY) = YST + FLOAT(IYY-1)*STPSZ +C +C SET INTENSITY TO HIGH +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C COMPUTE THE SEARCH RANGE FOR MIN AND MAX DETERMINATION +C + IXRG = MIN0(15,MAX0(2,IFIX(FLOAT(IXMAX)/8.))) + IYRG = MIN0(15,MAX0(2,IFIX(FLOAT(IYMAX)/8.))) +C +C LOOP THROUGH ALL ROWS OF THE DATA SEARCHING FOR AN IMMEDIATE MIN OR +C MAX. +C + IX = 1 +C +C SCAN A ROW +C +C IF EXTRAPOLATING DONT LIMIT ROW SCANS +C + 10 IF (.NOT.EXTRAP) GO TO 20 + IYST = 1 + IYED = IYMAX + IY = 1 + GO TO 30 +C +C NOT EXTRAPOLATING STAY IN HULL BOUNDRIES +C + 20 IYST = ITLOC(IX*2-1) + IYED = ITLOC(IX*2) + IF (IYST.EQ.0) GO TO 240 + IY = IYST + 30 VAL = SCRTCH(IX,IY) +C +C SEARCH FOR A MIN +C +C +C BRANCH IF NOT FIRST ON A ROW +C + IF (IY.NE.IYST) GO TO 40 + IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 130 + IF (VAL.GE.SCRTCH(IX,IY+2)) GO TO 130 + GO TO 60 +C +C BRANCH IF NOT LAST ON ROW +C + 40 IF (IY.NE.IYED) GO TO 50 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 140 + IF (VAL.GE.SCRTCH(IX,IY-2)) GO TO 140 + GO TO 60 +C +C IN MIDDLE OF ROW +C + 50 IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 150 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 150 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 60 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) +C +C IF NOT EXTRAPOLATING BRANCH +C + 70 IF (.NOT.EXTRAP) GO TO 80 + IYSRS = 1 + IYSRE = IYMAX + GO TO 90 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 80 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 120 +C + 90 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 100 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.LT.CUR) GO TO 110 + IF (VAL.GT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 110 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 110 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 100 + 120 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 70 +C +C SUCCESS, WE HAVE FOUND A RELATIVE MIN +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'L',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C + GO TO 230 +C +C SEARCH FOR A LOCAL MAXIMUM +C +C IF FIRST LOC ON A ROW +C + 130 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY+2)) GO TO 230 + GO TO 160 +C +C IF LAST ON ROW +C + 140 IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-2)) GO TO 230 + GO TO 160 +C +C IN MIDDLE OF ROW +C + 150 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 160 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) + 170 IF (.NOT.EXTRAP) GO TO 180 + IYSRS = 1 + IYSRE = IYMAX + GO TO 190 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 180 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 220 +C + 190 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 200 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.GT.CUR) GO TO 210 + IF (VAL.LT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 210 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 210 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 200 + 220 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 170 +C +C SUCCESS WE HAVE A MAXIMUM +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'H',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C +C END OF SEARCH AT THIS LOCATION TRY NEXT +C + 230 IY = IY+1 + IF (IY.LE.IYED) GO TO 30 + 240 IX = IX+1 + IF (IX.LE.IXMAX) GO TO 10 +C + CALL GSTXCI (IRANTX) +C + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONRAN TO ULIB * +C* AUGUST 1980 CHANGED ACCESS CARD DOCUMENTATION * +C* DECEMBER 1980 MODIFIED COMMENT CARD DOCUMENTATION * +C* MARCH 1983 ADDED ASPECT RATIO ERROR * +C* JULY 1983 ADDED SHIELDING AND LINEAR INTERPOLATION * +C* REMOVED 7600 ACCESS CARDS * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conrec.f b/sys/gio/ncarutil/conrec.f new file mode 100644 index 00000000..b3e246c1 --- /dev/null +++ b/sys/gio/ncarutil/conrec.f @@ -0,0 +1,1313 @@ + SUBROUTINE CONREC (Z,L,M,N,FLO,HI,FINC,NSET,NHI,NDOT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C DIMENSION OF Z(L,N) +C ARGUMENTS +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE CONREC DRAWS A CONTOUR MAP FROM DATA STORED +C IN A RECTANGULAR ARRAY, LABELING THE LINES. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZCNTR (Z,M,N) +C +C ASSUMPTIONS: +C --ALL OF THE ARRAY IS TO BE CONTOURED. +C --CONTOUR LEVELS ARE PICKED +C INTERNALLY. +C --CONTOURING ROUTINE PICKS SCALE +C FACTORS. +C --HIGHS AND LOWS ARE MARKED. +C --NEGATIVE LINES ARE DRAWN WITH A +C DASHED LINE PATTERN. +C --EZCNTR CALLS FRAME AFTER DRAWING THE +C CONTOUR MAP. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL CONREC (Z,L,M,N,FLO,HI,FINC,NSET, +C NHI,NDOT) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZCNTR M BY N ARRAY TO BE CONTOURED. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZCNTR +C +C ON INPUT Z +C FOR CONREC THE (ORIGIN OF THE) ARRAY TO BE +C CONTOURED. Z IS DIMENSIONED L BY N. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING AN ENTIRE +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF THE LOWEST CONTOUR LEVEL. +C IF FLO = HI = 0., A VALUE ROUNDED UP FROM +C THE MINIMUM Z IS GENERATED BY CONREC. +C +C HI +C THE VALUE OF THE HIGHEST CONTOUR LEVEL. +C IF HI = FLO = 0., A VALUE ROUNDED DOWN +C FROM THE MAXIMUM Z IS GENERATED BY +C CONREC. +C +C FINC +C > 0 INCREMENT BETWEEN CONTOUR LEVELS. +C = 0 A VALUE, WHICH PRODUCES BETWEEN 10 +C AND 30 CONTOUR LEVELS AT NICE VALUES, +C IS GENERATED BY CONREC. +C < 0 THE NUMBER OF LEVELS GENERATED BY +C CONREC IS ABS(FINC). +C +C NSET +C FLAG TO CONTROL SCALING. +C = 0 CONREC AUTOMATICALLY SETS THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE THE FRAME TO THE STANDARD +C CONFIGURATION. +C THE GRIDAL ENTRY PERIM IS +C CALLED AND TICK MARKS ARE PLACED +C CORRESPONDING TO THE DATA POINTS. +C > 0 CONREC ASSUMES THAT THE USER +C HAS SET THE WINDOW AND VIEWPORT +C IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING +C INSTRUCTIONS GENERATED BY CONREC. +C PERIM IS NOT CALLED. +C < 0 CONREC GENERATES COORDINATES SO AS +C TO PLACE THE (UNTRANSFORMED) CONTOUR +C PLOT WITHIN THE LIMITS OF THE +C USER'S CURRENT WINDOW AND +C VIEWPORT. PERIM IS NOT CALLED. +C +C NHI +C FLAG TO CONTROL EXTRA INFORMATION ON THE +C CONTOUR PLOT. +C = 0 HIGHS AND LOWS ARE MARKED WITH AN H +C OR L AS APPROPRIATE, AND THE VALUE +C OF THE HIGH OR LOW IS PLOTTED UNDER +C THE SYMBOL. +C > 0 THE DATA VALUES ARE PLOTTED AT +C EACH Z POINT, WITH THE CENTER OF +C THE STRING INDICATING THE DATA +C POINT LOCATION. +C < 0 NEITHER OF THE ABOVE. +C +C NDOT +C A 10-BIT CONSTANT DESIGNATING THE DESIRED +C DASHED LINE PATTERN. +C IF ABS(NDOT) = 0, 1, OR 1023, SOLID LINES +C ARE DRAWN. +C > 0 NDOT PATTERN IS USED FOR ALL LINES. +C < 0 ABS(NDOT) PATTERN IS USED FOR NEGA- +C TIVE-VALUED CONTOUR LINES, AND SOLID IS +C USED FOR POSITIVE-VALUED CONTOURS. +C CONREC CONVERTS NDOT +C TO A 16-BIT PATTERN AND DASHDB IS USED. +C SEE DASHDB COMMENTS IN THE DASHLINE +C DOCUMENTATION FOR DETAILS. +C +C +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR CONREC +C +C +C ENTRY POINTS CONREC, CLGEN, REORD, STLINE, DRLINE, +C MINMAX, PNTVAL, CALCNT, EZCNTR, CONBD +C +C COMMON BLOCKS INTPR, RECINT, CONRE1, CONRE2, CONRE3, +C CONRE4,CONRE5 +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT +C ROUTINES NCAR ISLOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE GRIDAL, THE +C ERPRT77 PACKAGE, AND THE SPPS. +C +C I/O PLOTS CONTOUR MAP. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY REPLACES OLD CONTOURING PACKAGE CALLED +C CALCNT AT NCAR. +C +C ALGORITHM EACH LINE IS FOLLOWED TO COMPLETION. POINTS +C ALONG A LINE ARE FOUND ON BOUNDARIES OF THE +C (RECTANGULAR) CELLS. THESE POINTS ARE +C CONNECTED BY LINE SEGMENTS USING THE +C SOFTWARE DASHED LINE PACKAGE, DASHCHAR. +C DASHCHAR IS ALSO USED TO LABEL THE +C LINES. +C +C NOTE TO DRAW NON-UNIFORM CONTOUR LEVELS, SEE +C THE COMMENTS IN CLGEN. TO MAKE SPECIAL +C MODIFICATIONS FOR SPECIFIC NEEDS SEE THE +C EXPLANATION OF THE INTERNAL PARAMETERS +C BELOW. +C +C TIMING VARIES WIDELY WITH SIZE AND SMOOTHNESS OF +C Z. +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C ISIZEL 1 SIZE OF LINE LABELS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEM 2 SIZE OF LABELS FOR MINIMUMS +C AND MAXIMUMS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEP 0 SIZE OF LABELS FOR DATA +C POINT VALUES AS PER THE SIZE +C DEFINITIONS GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C NLA 16 APPROXIMATE NUMBER OF +C CONTOUR LEVELS WHEN +C INTERNALLY GENERATED. +C +C NLM 40 MAXIMUM NUMBER OF CONTOUR +C LEVELS. IF THIS IS TO BE +C INCREASED, THE DIMENSIONS +C OF CL AND RWORK IN CONREC +C MUST BE INCREASED BY THE +C SAME AMOUNT. +C +C XLT .05 LEFT HAND EDGE OF THE PLOT +C (0.0 IS THE LEFT EDGE OF +C THE FRAME AND 1.0 IS THE +C RIGHT EDGE OF THE FRAME.) +C +C YBT .05 BOTTOM EDGE OF THE PLOT +C (0.0 IS THE BOTTOM OF THE +C FRAME AND 1.0 IS THE TOP +C OF THE FRAME.) +C +C SIDE 0.9 LENGTH OF LONGER EDGE OF +C PLOT (SEE ALSO EXT). +C +C NREP 6 NUMBER OF REPETITIONS OF +C THE DASH PATTERN BETWEEN +C LINE LABELS. +C +C NCRT 2 NUMBER OF CRT UNITS PER +C ELEMENT (BIT) IN THE DASH +C PATTERN. +C +NOAO - Value of ncrt changed from 4 to 2 in conbd. +C -NOAO +C +C ILAB 1 FLAG TO CONTROL THE DRAWING +C OF LINE LABELS. +C . ILAB NON-ZERO MEANS LABEL +C THE LINES. +C . ILAB = 0 MEANS DO NOT +C LABEL THE LINES. +C +C NULBLL 3 NUMBER OF UNLABELED LINES +C BETWEEN LABELED LINES. FOR +C EXAMPLE, WHEN NULBLL = 3, +C EVERY FOURTH LEVEL IS +C LABELED. +C +C IOFFD 0 FLAG TO CONTROL +C NORMALIZATION OF LABEL +C NUMBERS. +C . IOFFD = 0 MEANS INCLUDE +C DECIMAL POINT WHEN +C POSSIBLE (DO NOT +C NORMALIZE UNLESS +C REQUIRED). +C . IOFFD NON-ZERO MEANS +C NORMALIZE ALL LABEL +C NUMBERS AND OUTPUT A +C SCALE FACTOR IN THE +C MESSAGE BELOW THE GRAPH. +C +C EXT .0625 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M +C AND N (WHEN CONREC SETS +C THE WINDOW AND VIEWPORT). +C IN EXTREME CASES, WHEN +C MIN(M,N)/MAX(M,N) IS LESS +C THAN EXT, CONREC +C PRODUCES A SQUARE PLOT. +C +C IOFFP 0 FLAG TO CONTROL SPECIAL +C VALUE FEATURE. +C . IOFFP = 0 MEANS SPECIAL +C VALUE FEATURE NOT IN USE. +C . IOFFP NON-ZERO MEANS +C SPECIAL VALUE FEATURE IN +C USE. (SPVAL IS SET TO THE +C SPECIAL VALUE.) CONTOUR +C LINES WILL THEN BE +C OMITTED FROM ANY CELL +C WITH ANY CORNER EQUAL TO +C THE SPECIAL VALUE. +C +C SPVAL 0. CONTAINS THE SPECIAL VALUE +C WHEN IOFFP IS NON-ZERO. +C +C IOFFM 0 FLAG TO CONTROL THE MESSAGE +C BELOW THE PLOT. +C . IOFFM = 0 IF THE MESSAGE +C IS TO BE PLOTTED. +C . IOFFM NON-ZERO IF THE +C MESSAGE IS TO BE OMITTED. +C +C ISOLID 1023 DASH PATTERN FOR +C NON-NEGATIVE CONTOUR LINES. +C +C +C +NOAO - Block data conbd rewritten as run time initialization. +C EXTERNAL CONBD +C -NOAO +C + SAVE + CHARACTER*1 IGAP ,ISOL ,RCHAR + CHARACTER ENCSCR*22 ,IWORK*126 +C +NOAO - Character variable added for improved label processing. + character*25 string(5) +C -NOAO + DIMENSION LNGTHS(5) ,HOLD(5) ,WNDW(4) ,VWPRT(4) + DIMENSION Z(L,N) ,CL(40) ,RWORK(40) ,LASF(13) + COMMON /INTPR/ PAD1, FPART, PAD(8) + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , + 1 NCRT ,ILAB ,NULBLL ,IOFFD , + 2 EXT ,IOFFM ,ISOLID ,NLA , + 3 NLM ,XLT ,YBT ,SIDE + COMMON /CONRE5/ SCLY + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C +NOAO - Value of LNGTHS have been changed from original defaults. Additional +C common block noaolb added for communication with calling routine. +C + common /noaolb/ hold + DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4),LNGTHS(5) + 1 / 13, 4, 21, 10, 19 / + DATA ISOL, IGAP /'$', ''''/ +C +C -NOAO +C +C ISOL AND IGAP (DOLLAR-SIGN AND APOSTROPHE) ARE USED TO CONSTRUCT PAT- +C TERNS PASSED TO ROUTINE DASHDC IN THE SOFTWARE DASHED-LINE PACKAGE. +C +C +C +C +NOAO - Blockdata conbd called as run time initialization subroutine + call conbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CONREC','VERSION 01') +C +C NONSMOOTHING VERSION +C +C +C +C CALL RESET FOR COMPATIBILITY WITH ALL DASH ROUTINES(EXCEPT DASHLINE) +C + CALL RESET +C +C GET NUMBER OF BITS IN INTEGER ARITHMETIC +C + IARTH = I1MACH(8) + IXBITS = 0 + DO 101 I=1,IARTH + IF (M .LE. (2**I-1)) GO TO 102 + IXBITS = I+1 + 101 CONTINUE + 102 IYBITS = 0 + DO 103 I=1,IARTH + IF (N .LE. (2**I-1)) GO TO 104 + IYBITS = I+1 + 103 CONTINUE + 104 IF ((IXBITS*IYBITS).GT.0 .AND. (IXBITS+IYBITS).LE.24) GO TO 105 +C +C REPORT ERROR NUMBER ONE +C + IWORK = 'CONREC - DIMENSION ERROR - M*N .GT. (2**IARTH) M = + + N = ' +C +NOAO +C +C WRITE (IWORK(56:62),'(I6)') M + call encode (6, '(i6)', iwork(56:62), m) +C WRITE (IWORK(73:79),'(I6)') N + call encode (6, '(i6)', iwork(73:79), n) +C -NOAO +C + CALL SETER( IWORK, 1, 1 ) + RETURN + 105 CONTINUE +C +C INQUIRE CURRENT TEXT AND LINE COLOR INDEX +C + CALL GQTXCI ( IERR, ITXCI ) + CALL GQPLCI ( IERR, IPLCI ) +C +C SET LINE AND TEXT ASF TO INDIVIDUAL +C + CALL GQASF ( IERR, LASF ) + LSV3 = LASF(3) + LSV10 = LASF(10) + LASF(3) = 1 + LASF(10) = 1 + CALL GSASF ( LASF ) +C + GL = FLO + HA = HI + GP = FINC + MX = L + NX = M + NY = N + IDASH = NDOT + NEGPOS = ISIGN(1,IDASH) + IDASH = IABS(IDASH) + IF (IDASH.EQ.0 .OR. IDASH.EQ.1) IDASH = ISOLID +C +C SET CONTOUR LEVELS. +C + CALL CLGEN (Z,MX,NX,NY,GL,HA,GP,NLA,NLM,CL,NCL,ICNST) +C +C FIND MAJOR AND MINOR LINES +C + IF (ILAB .NE. 0) CALL REORD (CL,NCL,RWORK,NML,NULBLL+1) + IF (ILAB .EQ. 0) NML = 0 +C +C SAVE CURRENT NORMALIZATION TRANS NUMBER NTORIG AND LOG SCALING FLAG +C + CALL GQCNTN ( IERR, NTORIG ) + CALL GETUSV ('LS',IOLLS) +C +C SET UP SCALING +C + CALL GETUSV ( 'YF' , IYVAL ) + SCLY = 1.0 / ISHIFT ( 1, 15 - IYVAL ) +C + IF (NSET) 106,107,111 + 106 CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS AND LOG SCALING +C + CALL SET(X1, X2, Y1, Y2, 1.0, FLOAT(NX), 1.0, FLOAT(NY), 1) + GO TO 111 + 107 CONTINUE + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = NX + Y3 = NY + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .LT. EXT) GO TO 110 + IF (NX-NY) 108,110,109 + 108 X2 = SIDE*X3/Y3+XLT + GO TO 110 + 109 Y2 = SIDE*Y3/X3+YBT +C +C SAVE NORMALIZATION TRANS 1 +C + 110 CALL GQNT ( 1, IERR, WNDW, VWPRT ) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) +C +C DRAW PERIMETER +C + CALL PERIM (NX-1,1,NY-1,1) + 111 IF (ICNST .NE. 0) GO TO 124 +C +C SET UP LABEL SCALING +C + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA),ABS(GP)))-5000.)- + 1 5000) + IF (IOFFDT .EQ. 0) ASH = 1. + HOLD(1) = GL + HOLD(2) = HA + HOLD(3) = GP + HOLD(4) = Z(3,3) + HOLD(5) = ASH + NCHAR = 0 + IF (IOFFM .NE. 0) GO TO 115 +C +NOAO - This label generation has been reworked to eliminate the large +C spaces in between fields of the label. +C IWORK = 'CONTOUR FROM TO CONTOUR INTERVAL +C 1 OF PT(3,3)= LABELS SCALED BY' + string(1)(1:13) = 'CONTOUR FROM ' + string(2)(1:4) = ' TO ' + string(3)(1:21) = '; CONTOUR INTERVAL = ' + string(4)(1:11) = '; PT(3,3)= ' + string(5)(1:19) = '; LABELS SCALED BY ' +C + DO 114 I=1,5 +C (NOAO) WRITE ( ENCSCR, '(G13.5)' ) HOLD(I) + call encd (hold(i), ash, encscr, nc, ioffd) + do 1113 k = 1, lngths(i) + nchar = nchar + 1 + 1113 iwork(nchar:nchar) = string(i)(k:k) +C +C (NOAO) NCHAR = NCHAR+LNGTHS(I) +C (NOAO) DO 113 J=1,13 + do 113 j = 1, nc + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 113 CONTINUE + 114 CONTINUE +C +C +NOAO IF (ASH .EQ. 1.) NCHAR = NCHAR-13-LNGTHS(5) + if (ash .eq. 1.) nchar = nchar - nc - lngths(5) +C -NOAO +C +C SET TEXT INTENSITY TO LOW, AND WRITE TITLE USING NORMALIZATION +C TRANS NUMBER 0 +C + CALL GSTXCI (IRECTX) + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO - following text output centered on current viewport +C CALL WTSTR ( 0.5, 0.015625, IWORK(1:NCHAR), 0, 0, 0 ) + CALL WTSTR ( ((x1+x2)/2.0), y1 - 0.03, IWORK(1:NCHAR), 0, 0, 0 ) +C -NOAO + CALL SETUSV('LS',LSO) + CALL GSELNT (1) +C +C +C +C * * * * * * * * * * +C * * * * * * * * * * +C +C +C PROCESS EACH LEVEL +C + 115 FPART = .5 +C + DO 123 I=1,NCL + CONTR = CL(I) + NDASH = IDASH + IF (NEGPOS.LT.0 .AND. CONTR.GE.0.) NDASH = ISOLID +C +C CHANGE 10 BIT PATTERN TO 10 CHARACTER PATTERN. +C + DO 116 J=1,10 + IBIT = IAND(ISHIFT(NDASH,(J-10)),1) + RCHAR = IGAP + IF (IBIT .NE. 0) RCHAR = ISOL + IWORK(J:J) = RCHAR + 116 CONTINUE + IF (I .GT. NML) GO TO 121 +C +C SET UP MAJOR LINE (LABELED) +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI ( IRECMJ ) +C +C NREP REPITITIONS OF PATTERN PER LABEL. +C + NCHAR = 10 + IF (NREP .LT. 2) GO TO 119 + DO 118 J=1,10 + NCHAR = J + RCHAR = IWORK(J:J) + DO 117 K=2,NREP + NCHAR = NCHAR+10 + IWORK(NCHAR:NCHAR) = RCHAR + 117 CONTINUE + 118 CONTINUE + 119 CONTINUE +C +C PUT IN LABEL. +C + CALL ENCD (CONTR,ASH,ENCSCR,NCUSED,IOFFDT) + DO 120 J=1,NCUSED + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 120 CONTINUE + GO TO 122 +C +C SET UP MINOR LINE (UNLABELED). +C + 121 CONTINUE +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI ( IRECMN ) + NCHAR = 10 + 122 CALL DASHDC ( IWORK(1:NCHAR),NCRT, ISIZEL ) +C +C +C DRAW ALL LINES AT THIS LEVEL. +C + CALL STLINE (Z,MX,NX,NY,CONTR) +C +C + 123 CONTINUE +C +C FIND RELATIVE MINIMUMS AND MAXIMUMS IF WANTED, AND MARK VALUES IF +C WANTED. +C + IF (NHI .EQ. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEM,ASH,IOFFDT) + IF (NHI .GT. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEP,-ASH,IOFFDT) + FPART = 1. + GO TO 127 + 124 CONTINUE + IWORK = 'CONSTANT FIELD' +C +NOAO +C WRITE( ENCSCR, '(G22.14)' ) GL + i = gl + call encode (22, '(g22.14)', encscr, i) +C -NOAO + DO 126 I=1,22 + IWORK(I+14:I+14) = ENCSCR(I:I) + 126 CONTINUE +C +C WRITE TITLE USING NORMALIZATION TRNS 0 +C + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO +C CALL WTSTR ( 0.09765, 0.48825, IWORK(1:36), 3, 0, -1 ) + CALL WTSTR ( x1+0.03, (y1+y2)/2.0, IWORK(1:36), 3, 0, -1 ) +C -NOAO +C +C RESTORE NORMALIZATION TRANS 1, LINE AND TEXT INTENSITY TO ORIGINAL +C + 127 IF (NSET.LE.0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + END IF + CALL GSPLCI ( IPLCI ) + CALL GSTXCI ( ITXCI ) +C +C SELECT ORIGINAL NORMALIZATION TRANS NUMBER NTORIG, AND RESTORE ASF +C + CALL GSELNT ( NTORIG ) + LASF(3) = LSV3 + LASF(10) = LSV10 + CALL GSASF ( LASF ) +C + RETURN +C +C + END + SUBROUTINE CLGEN (Z,MX,NX,NNY,CCLO,CHI,CINC,NLA,NLM,CL,NCL,ICNST) + SAVE + DIMENSION CL(NLM) ,Z(MX,NNY) + COMMON /CONRE1/ IOFFP ,SPVAL +C +C CLGEN PUTS THE VALUES OF THE CONTOUR LEVELS IN CL. +C VARIABLE NAMES MATCH THOSE IN CONREC, WITH THE FOLLOWING ADDITIONS. +C NCL -NUMBER OF CONTOUR LEVELS PUT IN CL. +C ICNST -FLAG TO TELL CONREC IF A CONSTANT FIELD WAS DETECTED. +C .ICNST=0 MEANS NON-CONSTANT FIELD. +C .ICNST NON-ZERO MEANS CONSTANT FIELD. +C +C TO PRODUCE NON-UNIFORM CONTOUR LEVEL SPACING, REPLACE THE CODE IN THIS +C SUBROUTINE WITH CODE TO PRODUCE WHATEVER SPACING IS DESIRED. +C + ICNST = 0 + NY = NNY + CLO = CCLO + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 101,102,111 + 101 GLO = HA + HA = CLO + GO TO 111 + 102 IF (GLO .NE. 0.) GO TO 120 + GLO = Z(1,1) + HA = Z(1,1) + IF (IOFFP .EQ. 0) GO TO 107 + DO 106 J=1,NY + DO 105 I=1,NX + IF (Z(I,J) .EQ. SPVAL) GO TO 105 + GLO = Z(I,J) + HA = Z(I,J) + DO 104 JJ=J,NY + DO 103 II=1,NX + IF (Z(II,JJ) .EQ. SPVAL) GO TO 103 + GLO = AMIN1(Z(II,JJ),GLO) + HA = AMAX1(Z(II,JJ),HA) + 103 CONTINUE + 104 CONTINUE + GO TO 110 + 105 CONTINUE + 106 CONTINUE + GO TO 110 + 107 DO 109 J=1,NY + DO 108 I=1,NX + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 108 CONTINUE + 109 CONTINUE + 110 IF (GLO .GE. HA) GO TO 119 + 111 IF (FANC) 112,113,114 + 112 CRAT = AMAX1(1.,-FANC) + 113 FANC = (HA-GLO)/CRAT + P = 10.**(IFIX(ALOG10(FANC)+5000.)-5000) + FANC = AINT(FANC/P)*P + 114 IF (CHI-CLO) 116,115,116 + 115 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC*(1.+SIGN(1.E-6,HA)) + 116 DO 117 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 118 + KK = K + CL(K) = CC + 117 CONTINUE + 118 NCL = KK + CCLO = CL(1) + CHI = CL(NCL) + CINC = FANC + RETURN + 119 ICNST = 1 + NCL = 1 + CCLO = GLO + RETURN + 120 CL(1) = GLO + NCL = 1 + RETURN + END + SUBROUTINE DRLINE (Z,L,MM,NN) + SAVE + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + LOGICAL IPEN ,IPENO + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C + FX(X,Y) = X + FY(X,Y) = Y + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY + C(P1,P2) = (P1-CV)/(P1-P2) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 101 + ASSIGN 110 TO JUMP1 + ASSIGN 115 TO JUMP2 + GO TO 102 + 101 ASSIGN 112 TO JUMP1 + ASSIGN 117 TO JUMP2 + 102 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 103 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 103 IF (IDX .EQ. 0) GO TO 104 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 105 + 104 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 105 CALL FRSTD (FX(X,Y),FY(X,Y)) + 106 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 107 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 120 + 107 IF (CV-Z(IX2,IY2)) 108,108,109 + 108 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 106 + 109 IF (IS/2*2 .EQ. IS) GO TO 106 + GO TO JUMP1,(110,112) + 110 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 111 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 120 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 120 + 111 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 112 IF (IDX .EQ. 0) GO TO 113 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 114 + 113 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 114 GO TO JUMP2,(115,117) + 115 IF (.NOT.IPEN) GO TO 118 + IF (IPENO) GO TO 116 +C +C END OF LINE SEGMENT +C + CALL LASTD + CALL FRSTD (FX(XOLD,YOLD),FY(XOLD,YOLD)) +C +C CONTINUE LINE SEGMENT +C + 116 CONTINUE + 117 CALL VECTD (FX(X,Y),FY(X,Y)) + 118 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 119 + NP = NP+1 + IF (NP .GT. NR) GO TO 120 + IR(NP) = IXYPAK(IX,IY) + 119 IF (ISS .EQ. 0) GO TO 106 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 106 +C +C END OF LINE +C + 120 CALL LASTD + RETURN + END + SUBROUTINE MINMAX (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - MN IN THE X DIRECTION AND + OR - NM IN THE Y DIRECTION. +C +C ORIGINATOR DAVID KENNISON +C + SAVE + CHARACTER*6 IA + DIMENSION Z(L,NN) +C +C +C + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE5/ SCLY +C + FX(X,Y) = X + FY(X,Y) = Y +C + M = MM + N = NN +C +C SET UP SCALING FOR LABELS +C + SIZEM = (ISSIZM + 1)*256*SCLY + ISIZEM = ISSIZM +C + ASH = ABS(AASH) + IOFFDT = JOFFDT +C + IF (AASH .LT. 0.0) GO TO 128 +C + MN = MIN0(15,MAX0(2,IFIX(FLOAT(M)/8.))) + NM = MIN0(15,MAX0(2,IFIX(FLOAT(N)/8.))) + NM1 = N-1 + MM1 = M-1 +C +C LINE LOOP FOLLOWS - THE COMPLETE TWO-DIMENSIONAL TEST FOR A MINIMUM OR +C MAXIMUM OF THE FIELD IS ONLY PERFORMED FOR POINTS WHICH ARE MINIMA OR +C MAXIMA ALONG SOME LINE - FINDING THESE CANDIDATES IS MADE EFFICIENT BY +C USING A COUNT OF CONSECUTIVE INCREASES OR DECREASES OF THE FUNCTION +C ALONG THE LINE +C + DO 127 JP=2,NM1 +C + IM = MN-1 + IP = -1 + GO TO 126 +C +C CONTROL RETURNS TO STATEMENT 10 AS LONG AS THE FUNCTION IS INCREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MAXIMUM +C + 101 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 104 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 102,103,104 + 102 IM = IM+1 + GO TO 101 + 103 IM = 0 + GO TO 101 +C +C FUNCTION DECREASED - TEST FOR MAXIMUM ON LINE +C + 104 IF (IM .GE. MN) GO TO 106 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 106 + DO 105 II=IS,IT + IF (AA .LE. Z(II,JP)) GO TO 112 + 105 CONTINUE + 106 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 109 + DO 108 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 107 + IP = II-1 + GO TO 125 + 107 IF (AA .LE. Z(II,JP)) GO TO 112 + 108 CONTINUE +C +C WE HAVE MAXIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MAXIMUM OF FIELD +C + 109 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 111 JK=JS,JT + IF (JK .EQ. JP) GO TO 111 + DO 110 IK=IS,IT + IF (Z(IK,JK).GE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 112 + 110 CONTINUE + 111 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'H',ISIZEM,0,0 ) + CALL FL2INT ( FX(X,Y),FY(X,Y),IFX,IFY ) +C +C SCALE TO USER SET RESOLUTION +C + IFY = IFY*SCLY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 112 IM = 1 + IF (IP-MM1) 113,127,127 +C +C CONTROL RETURNS TO STATEMENT 20 AS LONG AS THE FUNCTION IS DECREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MINIMUM +C + 113 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 116 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 116,115,114 + 114 IM = IM+1 + GO TO 113 + 115 IM = 0 + GO TO 113 +C +C FUNCTION INCREASED - TEST FOR MINIMUM ON LINE +C + 116 IF (IM .GE. MN) GO TO 118 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 118 + DO 117 II=IS,IT + IF (AA .GE. Z(II,JP)) GO TO 124 + 117 CONTINUE + 118 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 121 + DO 120 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 119 + IP = II-1 + GO TO 125 + 119 IF (AA .GE. Z(II,JP)) GO TO 124 + 120 CONTINUE +C +C WE HAVE MINIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MINIMUM OF FIELD +C + 121 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 123 JK=JS,JT + IF (JK .EQ. JP) GO TO 123 + DO 122 IK=IS,IT + IF (Z(IK,JK).LE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 124 + 122 CONTINUE + 123 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'L',ISIZEM,0,0 ) + CALL FL2INT( FX(X,Y),FY(X,Y),IFX,IFY ) + IFY = SCLY*IFY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 124 IM = 1 + IF (IP-MM1) 101,127,127 +C +C SKIP SPECIAL VALUES ON LINE +C + 125 IM = 0 + 126 IP = IP+1 + IF (IP .GE. MM1) GO TO 127 + IF (IOFFP.NE.0 .AND. Z(IP+1,JP).EQ.SPVAL) GO TO 125 + IM = IM+1 + IF (IM .LE. MN) GO TO 126 + IM = 1 + AN = Z(IP+1,JP) + IF (Z(IP,JP)-AN) 101,103,113 +C + 127 CONTINUE +C + RETURN +C +C ****************************** ENTRY PNTVAL ************************** +C ENTRY PNTVAL (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C + 128 CONTINUE + II = (M-1+24)/24 + JJ = (N-1+48)/48 + NIQ = 1 + NJQ = 1 + DO 130 J=NJQ,N,JJ + Y = J + DO 129 I=NIQ,M,II + X = I + ZZ = Z(I,J) + IF (IOFFP.NE.0 .AND. ZZ.EQ.SPVAL) GO TO 129 + CALL ENCD (ZZ,ASH,IA,NC,IOFFDT) + CALL WTSTR (FX(X,Y),FY(X,Y),IA(1:NC),ISIZEM,0,0 ) + 129 CONTINUE + 130 CONTINUE + RETURN + END + SUBROUTINE REORD (CL,NCL,C1,MARK,NMG) + SAVE + DIMENSION CL(NCL) ,C1(NCL) +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MARK. C1 IS USED AS A WORK SPACE. NMG IS THE +C NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS BETWEEN +C MAJOR LEVELS). +C + NL = NCL + IF (NL.LE.4 .OR. NMG.LE.1) GO TO 113 + NML = NMG-1 + IF (NL .LE. 10) NML = 1 +C +C CHECK FOR ZERO OR OTHER NICE NUMBER FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 101 I=1,NL + ISAVE = I + IF (CL(I) .EQ. 0.) GO TO 104 + 101 CONTINUE + L = NL/2 + L = ALOG10(ABS(CL(L)))+1. + Q = 10.**L + DO 103 J=1,3 + Q = Q/10. + DO 102 I=1,NL + ISAVE = I + IF (AMOD(ABS(CL(I)+1.E-9*CL(I))/Q,FLOAT(NMLP1)) .LE. .0001) + 1 GO TO 104 + 102 CONTINUE + 103 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN C1 +C + 104 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART .EQ. 0) ISTART = NMLP1 + NMAJL = 0 + DO 105 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + C1(NMAJL) = CL(I) + 105 CONTINUE + MARK = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN C1 +C + IF (ISTART .EQ. 1) GO TO 107 + DO 106 I=2,ISTART + ISUB = L+I-1 + C1(ISUB) = CL(I-1) + 106 CONTINUE + 107 L = NMAJL+ISTART-1 + DO 109 I=2,NMAJL + DO 108 J=1,NML + L = L+1 + ISUB = ISTART+(I-2)*NMLP1+J + C1(L) = CL(ISUB) + 108 CONTINUE + 109 CONTINUE + NLML = NL-L + IF (L .EQ. NL) GO TO 111 + DO 110 I=1,NLML + L = L+1 + C1(L) = CL(L) + 110 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 111 DO 112 I=1,NL + CL(I) = C1(I) + 112 CONTINUE + RETURN + 113 MARK = NL + RETURN + END + SUBROUTINE STLINE (Z,LL,MM,NN,CONV) + SAVE + DIMENSION Z(LL,NN) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE3/ IXBITS ,IYBITS +C +C +C +C +C +C + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY +C + L = LL + M = MM + N = NN + CV = CONV + NP = 0 + ISS = 0 + DO 102 IP1=2,M + I = IP1-1 + IF (Z(I,1).GE.CV .OR. Z(IP1,1).LT.CV) GO TO 101 + IX = IP1 + IY = 1 + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 101 IF (Z(IP1,N).GE.CV .OR. Z(I,N).LT.CV) GO TO 102 + IX = I + IY = N + IDX = 1 + IDY = 0 + IS = 5 + CALL DRLINE (Z,L,M,N) + 102 CONTINUE + DO 104 JP1=2,N + J = JP1-1 + IF (Z(M,J).GE.CV .OR. Z(M,JP1).LT.CV) GO TO 103 + IX = M + IY = JP1 + IDX = 0 + IDY = -1 + IS = 7 + CALL DRLINE (Z,L,M,N) + 103 IF (Z(1,JP1).GE.CV .OR. Z(1,J).LT.CV) GO TO 104 + IX = 1 + IY = J + IDX = 0 + IDY = 1 + IS = 3 + CALL DRLINE (Z,L,M,N) + 104 CONTINUE + ISS = 1 + DO 108 JP1=3,N + J = JP1-1 + DO 107 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 107 + IXY = IXYPAK(IP1,J) + IF (NP .EQ. 0) GO TO 106 + DO 105 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 107 + 105 CONTINUE + 106 NP = NP+1 + IF (NP .GT. NR) THEN +C +C THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE +C STLINE HAS AN OVERFLOW +C THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR +C UNIT +C +C +NOAO - Message is written only to stderr, not to the plotting frame. +C Error is written with uliber, not FTN write statement. +C + call uliber (1, 'STLINE (CONREC) - WORK ARRAY OVERFLOW', 80) + call uliber (1,'STLINE - ***WARNING -- PICTURE INCOMPLETE***',80) +C IUNIT = I1MACH(4) +C WRITE(IUNIT,1000) +C1000 FORMAT( +C 1' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') +C CALL GETSET(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) +C Y = (YB - YA) / 2. +C X = (XB - XA) / 2. +C CALL PWRIT(X,Y, +C 1'**WARNING--PICTURE INCOMPLETE**', +C 2 31,3,0,0) +C Y = Y * .7 +C CALL PWRIT(X,Y, +C 1'WORK ARRAY OVERFLOW IN STLINE', +C 2 29,3,0,0) +C -NOAO + RETURN + ENDIF + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 107 CONTINUE + 108 CONTINUE + RETURN + END + SUBROUTINE CALCNT (Z,M,N,A1,A2,A3,I1,I2,I3) +C +C THIS ENTRY POINT IS FOR USERS WHO ARE TOO LAZY TO SWITCH OLD DECKS +C TO THE NEW CALLING SEQUENCE. +C + DIMENSION Z(M,N) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CALCNT','VERSION 01') +C + CALL CONREC (Z,M,M,N,A1,A2,A3,I1,I2,-IABS(I3)) + RETURN + END + SUBROUTINE EZCNTR (Z,M,N) +C +C CONTOURING VIA SHORTEST POSSIBLE ARGUMENT LIST +C ASSUMPTIONS -- +C ALL OF THE ARRAY IS TO BE CONTOURED, +C CONTOUR LEVELS ARE PICKED INTERNALLY, +C CONTOURING ROUTINE PICKS SCALE FACTORS, +C HIGHS AND LOWS ARE MARKED, +C NEGATIVE LINES ARE DRAWN WITH A DASHED LINE PATTERN, +C EZCNTR CALLS FRAME AFTER DRAWING THE CONTOUR MAP. +C IF THESE ASSUMPTIONS ARE NOT MET, USE CONREC. +C +C ARGUMENTS +C Z ARRAY TO BE CONTOURED +C M FIRST DIMENSION OF Z +C N SECOND DIMENSION OF Z +C + SAVE + DIMENSION Z(M,N) + DATA NSET,NHI,NDASH/0,0,682/ +C +C 682=1252B +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','EZCNTR','VERSION 01') +C + CALL CONREC (Z,M,M,N,0.,0.,0.,NSET,NHI,-NDASH) +C +NOAO - EZCNTR no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C +C JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO +C WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN +C BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. +C------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/dashbd.f b/sys/gio/ncarutil/dashbd.f new file mode 100644 index 00000000..cf499bc2 --- /dev/null +++ b/sys/gio/ncarutil/dashbd.f @@ -0,0 +1,143 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data changed to run time initialization. Logical param +c "first" added, so initialization doesn't occur more than once. +c BLOCKDATA DASHBD + subroutine dashbd +C +C DASHBD IS USED TO INITIALIZE VARIABLES IN NAMED COMMON. +C + logical first +c + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C + COMMON /FDFLAG/ IFLAG +C + COMMON /DDFLAG/ IFCFLG +C + COMMON /DCFLAG/ IFSTFL +C + COMMON /DFFLAG/ IFSTF2 +C + COMMON /CFFLAG/ IVCTFG +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C + COMMON /SMFLAG/ IOFFS +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C + SAVE + data first /.true./ + if (.not. first) return + first = .false. + +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C +c DATA IFSTFL /1/ + IFSTFL = 1 +C +C IVCTFG INDICATES IF VECTD IS BEING CALLED OR LASTD (IN CFVLD) +C +c DATA IVCTFG /1/ + IVCTFG = 1 +C +C ISL IS A FLAG FOR AN ALL SOLID PATTERN (+1) OR AN ALL GAP PATTERN (-1) +C +c DATA ISL /1/ + ISL = 1 +C +C IGP IS AN INTERNAL PARAMETER. IT IS DESCRIBED IN THE DOCUMENTATION +C TO THE DASHED LINE PACKAGE. +C +c DATA IGP /9/ + IGP = 9 +C +C MNCSTR IS THE MAXIMUM NUMBER OF CHARACTERS ALLOWED IN A HOLLERITH +C STRING PASSED TO DASHDC. +C +c DATA MNCSTR /15/ + MNCSTR = 15 +C +C IOFFS IS AN INTERNAL PARAMETER. +C IOFFS IS USED IN FDVDLD AND DRAWPV. +C +c DATA IOFFS /0/ + IOFFS = 0 +C +C INTERNAL PARAMETERS +C +c DATA IPAU/3/ + IPAU = 3 +c DATA FPART/1./ + FPART = 1. +c DATA TENSN/2.5/ + TENSN = 2.5 +c DATA NP/150/ + NP = 150 +c DATA SMALL/128./ + SMALL = 128. +c DATA L1/70/ + L1 = 70 +c DATA ADDLR/2./ + ADDLR = 2. +c DATA ADDTB/2./ + ADDTB = 2. +c DATA MLLINE/384/ + MLLINE = 384 +c DATA ICLOSE/6/ + ICLOSE = 6 +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED (IN SUBROUTINE FDVDLD), WHENEVER DASHDB OR DASHDC +C HAS BEEN CALLED. +C +c DATA IFSTF2 /1/ + IFSTF2 = 1 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C +c DATA IFLAG /1/ + IFLAG = 1 +C +C IFCFLG IS THE FIRST CALL FLAG FOR SUBROUTINES DASHDB AND DASHDC. +C 1 = FIRST CALL TO DASHDB OR DASHDC. +C 2 = DASHDB OR DASHDC HAS BEEN CALLED BEFORE. +C +c DATA IFCFLG /1/ + IFCFLG = 1 +C +C IXSTOR AND IYSTOR CONTAIN THE CURRENT PEN POSITION. THEY ARE +C INITIALIZED TO AN IMPOSSIBLE VALUE. +C +c DATA IXSTOR,IYSTOR /-9999,-9999/ + IXSTOR = -9999 + IYSTOR = -9999 +C +C SLP1 AND SLPN ARE INITIALIZED TO AVOID THAT THEY ARE PASSED AS ACTUAL +C PARAMETERS FROM FDVDLD TO KURV1S WITHOUT BEING DEFINED. +C +c DATA SLP1,SLPN /-9999.,-9999./ + SLP1 = -9999. + SLPN = -9999. +c -noao +C + END diff --git a/sys/gio/ncarutil/dashsmth.f b/sys/gio/ncarutil/dashsmth.f new file mode 100644 index 00000000..2fe25185 --- /dev/null +++ b/sys/gio/ncarutil/dashsmth.f @@ -0,0 +1,1224 @@ + SUBROUTINE FDVDLD (IENTRY,IIX,IIY) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SOFTWARE DASHED LINE PACKAGE WITH CHARACTER CAPABILITY AND SMOOTHING +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE DASHSMTH IS A SOFTWARE DASHED LINE PACKAGE WITH +C SMOOTHING CAPABILITIES. DASHSMTH IS DASHCHAR +C WITH SMOOTHING FEATURES ADDED. +C +C USAGE FIRST, EITHER +C CALL DASHDB (IPAT) +C WHERE IPAT IS A 16-BIT DASH PATTERN AS +C DESCRIBED IN THE SUBROUTINE DASHDB (SEE +C DASHLINE DOCUMENTATION), OR +C CALL DASHDC (IPAT,JCRT,JSIZE) +C AS DESCRIBED BELOW. +C +C THEN, CALL ANY OF THE FOLLOWING: +C CALL CURVED (X,Y,N) +C CALL FRSTD (X,Y) +C CALL VECTD (X,Y) +C CALL LASTD +C +C LASTD IS CALLED ONLY AFTER THE LAST +C POINT OF A LINE HAS BEEN PROCESSED IN VECTD. +C +C THE FOLLOWING MAY ALSO BE CALLED, BUT NO +C SMOOTHING WILL RESULT: +C CALL LINED (XA,YA,XB,YB) +C +C +C ARGUMENTS IPAT +C ON INPUT A CHARACTER STRING OF ARBITRARY LENGTH +C TO DASHDC (60 CHARACTERS SEEMS TO BE A PRACTICAL +C LIMIT) WHICH SPECIFIES THE DASH PATTERN +C TO BE USED. A DOLLAR SIGN IN IPAT +C INDICATES SOLID; AN APOSTROPHE INDICATES +C A GAP; BLANKS ARE IGNORED. ANY CHARACTER +C IN IPAT WHICH IS NOT A DOLLAR SIGN, +C APOSTROPHE, OR BLANK IS CONSIDERED TO BE +C PART OF A LINE LABEL. EACH LINE LABEL +C CAN BE AT MOST 15 CHARACTERS IN LENGTH. +C SUFFICIENT WHITE SPACE IS RESERVED IN THE +C DASHED LINE FOR WRITING LINE LABELS. +C +C JCRT +C THE LENGTH IN PLOTTER ADDRESS UNITS PER +C $ OR APOSTROPHE. +C +C JSIZE +C IS THE SIZE OF THE PLOTTED CHARACTERS: +C . IF BETWEEN 0 AND 3 , IT IS 1., 1.5, 2. +C AND 3. TIMES AN 8 PLOTTER ADDRESS UNIT +C WIDTH. +C . IF GREATER THAN 3, IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C +C ARGUMENTS TO CURVED(X,Y,N) +C OTHER LINE-DRAWING X AND Y ARE ARRAYS OF WORLD COORDINATE VALUES +C ROUTINES OF LENGTH N OR GREATER. LINE SEGMENTS OBEYING +C THE SPECIFIED DASH PATTERN ARE DRAWN TO +C CONNECT THE N POINTS. +C +C FRSTD(X,Y) +C THE CURRENT PEN POSITION IS SET TO +C THE WORLD COORDINATE VALUE (X,Y) +C +C VECTD(X,Y) +C A LINE SEGMENT IS DRAWN BETWEEN THE +C WORLD COORDINATE VALUE (X,Y) AND THE +C MOST RECENT PEN POSITION. (X,Y) THEN +C BECOMES THE MOST RECENT PEN POSITION. +C +C LINED(XA,XB,YA,YB) +C A LINE IS DRAWN BETWEEN WORLD COORDINATE +C VALUES (XA,YA) AND (XB,YB). +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED FOR ALL ROUTINES. +C +C NOTE WHEN USING FRSTD AND VECTD, LASTD MUST BE +C CALLED (NO ARGUMENTS NEEDED). LASTD SETS UP +C THE CALLS TO THE SMOOTHING ROUTINES KURV1S AND +C KURV2S. +C +C WHEN SWITCHING FROM THE REGULAR PLOTTING +C ROUTINES TO A DASHED LINE PACKAGE THE FIRST +C CALL SHOULD NOT BE TO VECTD. +C +C ENTRY POINTS DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED, +C RESET, LASTD, KURV1S, KURV2S, CFVLD, FDVDLD, +C DRAWPV, DASHBD +C +C COMMON BLOCKS INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1, +C DSAVE2, DSAVE3, DSAVE5, CFFLAG, SMFLAG, DFFLAG, +C FDFLAG +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SOLID OR DASHED LINES, POSSIBLY WITH +C CHARACTERS AT INTERVALS IN THE LINE. +C THE LINES MAY ALSO BE SMOOTHED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN OCTOBER 1973. +C MADE PORTABLE IN SEPTEMBER 1977 FOR USE +C WITH ALL MACHINES WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BIT RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JUNE, 1984. +C +C ALGORITHM POINTS FOR EACH LINE +C SEGMENT ARE PROCESSED AND PASSED TO THE +C ROUTINES, KURV1S AND KURV2S, WHICH COMPUTE +C SPLINES UNDER TENSION PASSING THROUGH THESE +C POINTS. NEW POINTS ARE GENERATED BETWEEN THE +C GIVEN POINTS, RESULTING IN SMOOTH LINES. +C +C ACCURACY PLUS OR MINUS .5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C TIMING ABOUT THREE TIMES AS LONG AS DASHCHAR. +C +C +C +C +C +C +C +C +C*********************************************************************** +C +C FDVDLD RECEIVES IN ITS ARGUMENTS THE POINTS TO BE PROCESSED FOR A +C LINE SEGMENT. IT PASSES THESE POINTS TO THE ROUTINES KURV1S AND KURV2S +C WHICH COMPUTE SPLINES UNDER TENSION PASSING THROUGH THESE POINTS. +C FDVDLD THEN CALLS CFVLD TO CONNECT THE POINTS GENERATED IN KURV2S. +C + DIMENSION XP(70), YP(70), TEMP(70) +C +C THE VARIABLES IN DSAVE5 HAVE TO BE SAVED FOR THE NEXT CALL TO FDVDLD. +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C +C IOFFS IS AN INTERNAL PARAMETER. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN FDVDLD AND DRAWPV. +C + COMMON /SMFLAG/ IOFFS +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED. +C + COMMON /DFFLAG/ IFSTF2 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C + COMMON /FDFLAG/ IFLAG +C +C NOTE THAT THIS IFSTF2 FLAG CANNOT BE IDENTICAL TO THE IFSTFL FLAG +C IN THE ROUTINE CFVLD, BECAUSE A CALL TO THE FRSTD ENTRY OF FDVDLD DOES +C NOT ELIMINATE THE NECESSITY OF A CALL TO THE FRSTD ENTRY OF CFVLD, +C AND REVERSE. +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE +C +C +C OTHER CONSTANTS. +C + DATA PI /3.14159265358/ + DATA IDUMMY /0/ +C +C + GO TO (10,15,35),IENTRY +C +C ************************************* +C +C ENTRY FRSTD (XX,YY) +C + 10 DEG = 180./PI +C + MX = IIX + MY = IIY + IFSTF2 = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 + IF (IOFFS .GE. 1) CALL CFVLD (1,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 15 CONTINUE +C +C TEST FOR PREVIOUS FRSTD CALL +C + IF (IFSTF2 .EQ. 0) GO TO 20 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER(' FDVDLD- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 10 + 20 MX = IIX + MY = IIY +C +C VECTD SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + IF (IOFFS .GE. 1) CALL CFVLD (2,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C IF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 40 + RETURN +C +C ************************************* +C +C ENTRY LASTD +C + 35 CONTINUE + IF (IFSTF2 .NE. 0) RETURN + IFSTF2 = 1 +C +C LASTD CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C + IF (IOFFS .GE. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + IF (IOFFS .GE. 1) RETURN +C +C IFLAG = 0 OK TO CALL LASTD DIRECTLY +C IFLAG = 1 LASTD WAS JUST CALLED FROM BY VECTD +C IGNORE CALL TO LASTD +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 40 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 60 + IF (N-2) 150,140,50 + 50 IF (N .GE. 4) GO TO 60 +C + IF (IPRD .NE. 0) GO TO 60 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 100 + 60 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 80 + IF (NSEG .GE. 1) GO TO 70 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 100 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 70 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 100 + 80 IF (NSEG .GE. 1) GO TO 90 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 100 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 90 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 100 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 110 + NPRIME = FLOAT(NP)-(S*FLOAT(NP)*.5)/32767. + IF (S .GE. 32767.) NPRIME = .5*FLOAT(NP) + NPL = AMAX1(FLOAT(NPRIME)*S/32767.,2.5) + 110 DT = 1./FLOAT(NPL) + IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + IF (NSEG .LE. 0) GO TO 112 + CALL DRAWPV (IX,IY,0) + GO TO 114 + 112 CONTINUE + CALL CFVLD (1,IX,IY) + 114 CONTINUE + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + DO 120 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + IX = IFIX(XS) + IY = IFIX (YS) + CALL CFVLD (2,IX,IY) + 120 CONTINUE + IF (IPRD .NE. 0) GO TO 130 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + IX = IFIX (XSV1) + IY = IFIX (YSV1) + CALL CFVLD (2,IX,IY) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 130 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + GO TO 150 +C +C FOR THE CASE WHEN THERE ARE ONLY 2 DISTINCT POINTS ON A LINE. +C + 140 IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + CALL CFVLD (1,IX,IY) + IX = IFIX (XSAVE(N)) + IY = IFIX (YSAVE(N)) + CALL CFVLD (2,IX,IY) + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) +C + 150 CONTINUE + RETURN + END + SUBROUTINE RESET +C +C THIS USER ENTRY POINT IS HERE ONLY FOR COMPATIBILITY WITH USE IN +C THE CONREC FAMILY WHICH CALL RESET WHEN USED WITH DASHSUPR. +C + RETURN + END + SUBROUTINE DASHDC (IPAT,JCRT,JSIZE) +C +C +C +C +C +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C USER ENTRY POINT. +C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*(*) IPAT + CHARACTER*1 IBLK, IGAP, ISOL, ICR + CHARACTER*16 IPC(100) +C +C DASHD1 AND DASHD2 ARE USED +C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC. +C IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE2 +C FOR THE NEXT CALL +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C SAVE ALL VARIABLES + SAVE +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C +C NPD IS THE NUMBER OF WORDS IN IP +C + DATA NPD/100/ +C +C INITIALIZE CHARACTER FLAGS +C + DATA IBLK,IGAP,ISOL/' ','''','$'/ +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDC', 'VERSION 1') +C +C NC IS THE NUMBER OF CHARACTERS IN IPAT +C + NC = LEN(IPAT) + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDC -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B). +C + MASK=IOR(ISHIFT(32767,1),1) +C +C + IFCFLG = 2 +C +C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING. +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C +C RETRIEVE THE RESOLUTION AS SET BY THE USER. +C + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) +C +C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION. +C + IADJUS = ISHIFT(1,15-LXSAVE) + ICRT = JCRT*IADJUS + ISIZE = JSIZE + CHARW = FLOAT(ISIZE*IADJUS) + IF (ISIZE .GT. 3) GO TO 30 + CHARW = 256. + FLOAT(ISIZE)*128. + IF (ISIZE .EQ. 3) CHARW = 768. +C + 30 CONTINUE + IF (ICRT .LT. 1) GO TO 230 + MODE = 2 +C +C START MAIN LOOP +C +C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM +C THE CHARACTER STRING IN IPAT. EACH ITERATION OF THE LOOP PROCESSES +C ONE CHAR OF IPAT. A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY, +C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY. +C +C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP +C TO SOLID, SOLID TO CHARACTER, ETC.) THE IP AND IPFLAG ARRAYS DESCRIBE +C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L. THE +C RELATIONSHIP BETWEEN IP AND IPFLAG IS: +C +C IPFLAG(N) IP(N) +C --------- ----- +C 1 LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO +C BE DRAWN. +C 0 NUMBER OF CHARACTERS TO BE PLOTTED. +C -1 LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP. +C +C THE 160 LOOP HANDLES 5 CASES: +C +C 1.) CONTINUE TYPE 2 ENTRY (60-80) +C 2.) START TYPE 2 ENTRY (80-90) +C 3.) END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160) +C 4.) START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO +C GAP OR FROM GAP TO SOLID (140-160) +C 5.) CONTINUE TYPE 1 ENTRY (150-160) +C + DO 160 J=1,NC +C +C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED. +C + ICR = IPAT(J:J) +C +C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS: +C +C LAST ICR WAS $ (SOLID), MODE IS 8 +C LAST ICR WAS ' (GAP), MODE IS 2 +C LAST ICR WAS HOLLERITH CHAR, MODE IS 5 +C +C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS: +C +C ICR NMODE +C --- ----- +C $ 1 +C CHAR 0 +C ' -1 +C + NMODE = 0 + IF (ICR .EQ. IBLK) GO TO 160 + IF (ICR .EQ. IGAP) NMODE = -1 + IF (ICR .EQ. ISOL) NMODE = 1 + IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8 +C +C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED. +C COMPUTE MODE FOR NEXT ITERATION. +C + NGO = NMODE+MODE + MODE = NMODE*3+5 + GO TO (150,80,140,90,60,90,140,80,150),NGO +C +C CHAR TO CHAR +C +C CASE 1) - CONTINUE TYPE 2 ENTRY. +C + 60 IF (NCHRTS .EQ. MNCSTR) GO TO 160 + NCHRTS = NCHRTS + 1 + IP(L) = NCHRTS + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C BLANK OR SOLID TO CHAR +C +C CASE 2) - START STRING ENTRY. LGBSTR POINTS TO THE GAP WHICH +C WILL CONTAIN THE STRING. +C + 80 LGBSTR = MIN0(L+1,NPD) + L = MIN0(LGBSTR+1,NPD) + IPFLAG(L) = 0 + NCHRTS = 1 + IP(L) = 1 + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C CHAR TO SOLID OR GAP +C +C CASE 3) - END STRING ENTRY. ICR IS A $ OR '. +C + 90 CONTINUE + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS) + .5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C BLANK TO SOLID OR SOLID TO BLANK +C +C CASE 4) - START TYPE 1 ENTRY. +C + 140 L = MIN0(L+1,NPD) + IP(L) = 0 +C +C ADD TO A BLANK OR SOLID LINE +C +C CASE 5) - CONTINUE TYPE 1 ENTRY. ICR IS A $ OR '. +C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L). +C NMODE INDICATES IF IT IS A GAP OR A SOLID. +C + 150 IP(L) = IP(L) + ICRT + IPFLAG(L) = NMODE + 160 CONTINUE +C +C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING +C ENTRY. +C + IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220 + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS)+.5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG. +C + 220 IF (L .GT. 1) RETURN + IBIG = ISHIFT(1,MAX0(LXSAVE,LYSAVE)) + IF (IP(L) .GE. IBIG) GO TO 230 + IF (IPFLAG(L)) 240,240,230 + 230 ISL = 1 + RETURN + 240 ISL = -1 + RETURN + END + SUBROUTINE DASHDB (IPAT) +C +C ARGUMENTS IPAT +C ON INPUT IPAT IS A 16-BIT DASH PATTERN. BY DEFAULT +C EACH BIT IN THE PATTERN REPRESENTS 3 PLOTTER +C ADDRESS UNITS (1=SOLID, 0=BLANK) +C +C +C +C USER ENTRY POINT. +C DASHDB GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENT. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + DIMENSION IPAT(1) + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C DASHD1 IS FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB. IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB HAS BEEN CALLED. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. IT IS +C INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB ARE SAVED IN DSAVE2 FOR THE NEXT CALL TO +C DASHDB. +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C + SAVE +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDB', 'VERSION 1') + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDB -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN +C + MASK=IOR(ISHIFT(32767,1),1) +C + IFCFLG = 2 +C +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C + ICRT = IPAU*ISHIFT(1,15-10) + IF (IPAT(1) .NE. 0) GO TO 260 + ISL = -1 + RETURN + 260 IF (IPAT(1) .NE. MASK) GO TO 270 + ISL = 1 + RETURN + 270 NMODE1 = IAND(ISHIFT(IPAT(1),-15),1) + DO 290 I = 1,16 + IF (NMODE1 .NE. IAND(ISHIFT(IPAT(1),I-16),1)) GO TO 280 + NMODE1 = 1 - NMODE1 + L = L + 1 + IP(L) = 0 + IPFLAG(L) = 1 - 2*NMODE1 + 280 IP(L) = IP(L) + ICRT + 290 CONTINUE + RETURN + END + SUBROUTINE DRAWPV (IX,IY,IND) +C +C DRAWPV INTERCEPTS THE CALL TO PLOTIT TO CHECK IF THE PEN HAS TO BE +C MOVED OR IF IT IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C IF IND=2 NEVER MOVE PEN, JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C +C IN IXSTOR AND IYSTOR THE CURRENT POSITION OF THE PEN IS SAVED. +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE + IIND = IND + 1 + GOTO (100,90,105), IIND +C + 90 CONTINUE +C +C DRAW LINE AND SAVE POSITION OF PEN. +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,1) + GOTO 110 +C + 100 CONTINUE +C +C CHECK IF PEN IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C + DIFF = FLOAT(IABS(IXSTOR-IX)+IABS(IYSTOR-IY)) + IF (DIFF .LE. FLOAT(ICLOSE)) GO TO 110 +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,0) + GOTO 110 +C + 105 CONTINUE +C +C DO NOT MOVE PEN. JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C + IXSTOR = IX + IYSTOR = IY +C + 110 CONTINUE +C + RETURN + END +C + SUBROUTINE CFVLD (IENTRY,IIX,IIY) +C +C CFVLD CONNECTS POINTS WHOSE COORDINATES ARE SUPPLIED IN THE ARGUMENTS, +C ACCORDING TO THE DASH PATTERN WHICH IS PASSED FROM ROUTINE DASHDB +C OR DASHDC IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*16 IPC(100) +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C THE VARIABLES IN DASHD1 AND DASHD2 ARE USED FOR COMMUNICATION WITH +C DASHDC AND DASHDB. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C THE VARIABLES IN DSAVE1 HAVE TO BE SAVED FOR THE NEXT CALL TO CFVLD. +C + COMMON /DSAVE1/ X,Y,X2,Y2,X3,Y3,M,BTI,IB,IX,IY +C +C THE FLAGS IFSTFL AND IVCTFG ARE INITIALIZED IN THE BLOCK DATA DASHBD. +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED. +C IVCTFG IS A FLAG TO INDICATE IF CFVLD IS BEING CALLED FROM VECTD OR +C LASTD. +C + COMMON /DCFLAG/ IFSTFL + COMMON /CFFLAG/ IVCTFG + SAVE +C +C +C CMN IS USED TO DETERMINE WHEN TO STOP DRAWING A LINE SEGMENT +C + DATA CMN/1.5/ +C +C IMPOS IS USED AS AN IMPOSSIBLE PEN POSITION. +C + DATA IMPOS /-9999/ +C +C +C ISL= -1 ALL BLANK ) FLAG TO AVOID MOST CALCULATIONS +C 0 DASHED ) IF PATTERN IS ALL SOLID OR +C 1 ALL SOLID ) ALL BLANK +C +C X,IX,Y,IY CURRENT POSITION +C X1,Y1 START OF A USER LINE SEGMENT +C X2,Y2 END OF A USER LINE SEGMENT +C X3,Y3 START OF A GAP PATTERN SEGMENT +C +C SYMBOLS,IF PRESENT ARE CENTERED IN AN IMMEDIATLY PRECEEDING +C GAP SEGMENT, OR DONE AT THE CURRENT POSITION OTHERWISE +C +C SEGMENT TYPES ARE RECOGNIZED AS FOLLOWS +C SOLID - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS 1. +C GAP - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS -1. +C SYMBOL - WORD IN IP-ARRAY CONTAINS CHARACTER REPRESENTATIONS. +C CORRESPONDING ELEMENT IN IPFLAG IS 0. +C SYMBOL COUNT FOR CHAR STRING IN CHAR NUMBER MNCSTR+1. +C THE IP ARRAY AND THE IPFLAG ARRAY ARE COMPOSED OF L ELEMENTS. +C +C BTI - BITS THIS INCREMENT +C BPBX,BPBY BITS PER BIT X(Y) +C +C +C BRANCH DEPENDING ON FUNCTION TO BE PERFORMED. +C + GO TO (330,305,350),IENTRY +C +C INITIALIZE VARIABLES (ENTRY FRSTD ONLY) +C + 30 CONTINUE + X = IX + Y = IY + X2 = X + X3 = X + Y2 = Y + Y3 = Y + M = 1 + IB = IPFLAG(1) + IF (IPFLAG(1) .NE. 0) GO TO 40 + IB = 0 + BTI = 0 + 40 CONTINUE + BTI = FLOAT(IP(1))*FPART + GO TO 300 +C +C MAIN LOOP START +C + 50 CONTINUE + X1 = X2 + Y1 = Y2 + MX = IIX + MY = IIY + X2 = MX + Y2 = MY + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .LT. CMN) GO TO 190 + 60 BPBX = DX/D + BPBY = DY/D + CALL DRAWPV (IX,IY,0) + 70 BTI = BTI-D + IF (BTI) 100,100,80 +C +C LINE SEGMENT WILL FIT IN CURRENT PATTERN ELEMENT +C + 80 X = X2 + Y = Y2 + IX = X2 + IY = Y2 + IF (IB) 200,160,90 + 90 CALL DRAWPV (IX,IY,1) + GO TO 200 +C +C LINE SEGMENT WONT FIT IN CURRENT PATTERN ELEMENT +C DO IT TO END OF ELEMENT, SAVE HOW MUCH OF SEGMENT LEFT TO DO (D) +C + 100 BTI = BTI+D + D = D-BTI + X = X+BPBX*BTI + Y = Y+BPBY*BTI + IX = X+.5 + IY = Y+.5 + IF (IB) 110,160,120 + 110 CALL DRAWPV (IX,IY,0) + GO TO 130 + 120 CALL DRAWPV (IX,IY,1) +C +C GET THE NEXT PATTERN ELEMENT +C + 130 M = MOD(M,L)+1 + IB = IPFLAG(M) + IF (IB) 140,160,150 + 140 X3 = X + Y3 = Y + BTI = FLOAT(IP(M)) + GO TO 70 + 150 X3 = -1. + BTI = FLOAT(IP(M)) + GO TO 70 +C +C CHARACTER GENERATION +C + 160 S = 0. + IF (IGP .NE. 9) GO TO 162 +C + DX = X-X3 + DY = Y-Y3 + GO TO 164 +C + 162 CONTINUE + DX = X - X1 + DY = Y - Y1 + 164 CONTINUE +C + IF (DY) 170,180,170 + 170 S = ATAN2(DY,DX) + IF (ABS(S-.00005) .GT. 1.5708) S = S-SIGN(3.14159,S) + 180 IF (IGP .NE. 9) GO TO 182 +C + MX = X3 + DX*.5 + MY = Y3 + DY*.5 + LIGP = 0 + GO TO 184 +C + 182 CONTINUE + MX = X + MY = Y + LIGP = 1 +C + 184 CONTINUE + IS = IFIX(S*180./3.14 + .5) + IF (IS .LT. 0) IS = 360+IS + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) + MX = ISHIFT (MX,LXSAVE-15) + MY = ISHIFT(MY,LYSAVE-15) + CALL WTSTR(CPUX(MX),CPUY(MY),IPC(M)(1:IP(M)),ISIZE,IS,LIGP) + CALL DRAWPV (IMPOS,IMPOS,2) + CALL DRAWPV (IX,IY,0) + GO TO 130 + 190 X2 = X1 + Y2 = Y1 + 200 CONTINUE +C +C EXIT IF CALL WAS TO VECTD. +C + IF (IVCTFG .NE. 2) GO TO 210 + IVCTFG = 1 + GO TO 300 +C +C EXIT IF NOT PLOTTING A GAP +C + 210 IF (IB .GE. 0) GO TO 300 +C +C MUST BE IN A GAP AT END OF LASTD. EXIT IF NOT A LABEL GAP. +C + MO = M + M = MOD(M,L) + 1 + IF (IPFLAG(M) .NE. 0) GO TO 300 +C +C CHECK PREVIOUS PLOTTED ELEMENT. WAS IT A GAP OR A LINE. +C + MPREV = M - 2 + IF (MPREV .LE. 0) MPREV = MPREV + L + IB = IPFLAG(MPREV) + IF (IB .GE. 0) GO TO 250 +C +C PREVIOUS ELEMENT WAS A GAP - LOOK FOR NEXT LINE. +C EXIT IF NO LINES IN PATTERN. +C + 230 CONTINUE + 240 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 300 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 245 + BTI = FLOAT(IP(M)) + 245 CONTINUE +C +C IF IP(M) NOT A LINE, CONTINUE LOOKING. +C + IF (IB) 240,230,280 +C +C PREVIOUS ELEMENT WAS A LINE - LOOK FOR NEXT GAP. +C IF NO NON-LABEL GAPS IN PATTERN, GO TO 290. +C + 250 CONTINUE + 260 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 290 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 265 + BTI = FLOAT(IP(M)) + 265 CONTINUE +C +C IF IP(M) NOT A GAP, CONTINUE LOOKING. +C + IF (IB) 270,250,260 +C +C FOUND A GAP. IF ITS A LABEL GAP, GO LOOK FOR NEXT GAP. +C + 270 MT = M + M = MOD(M,L)+1 + IF (IPFLAG(M) .EQ. 0) GO TO 250 + M = MT +C +C M POINTS TO NEXT ELEMENT TO PLOT. SET UP AND GO PLOT. +C + 280 X1 = X3 + Y1 = Y3 + X = X3 + Y = Y3 + IX = X+0.5 + IY = Y+0.5 + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .GE. CMN) GO TO 60 + GO TO 300 +C +C NO NON-LABEL GAPS IN THE PATTERN - FILL IN WITH SOLID LINE. +C + 290 IX = X3+0.5 + IY = Y3+0.5 + CALL DRAWPV (IX,IY,0) + IX = X2 + IY = Y2 + CALL DRAWPV (IX,IY,1) + 300 RETURN +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 305 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD. +C + IF (IFSTFL .EQ. 2) GO TO 310 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER ('CFVLD -- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 330 + 310 K = 1 + IVCTFG = 2 + IF (ISL) 300,50,320 + 320 IX = IIX + IY = IIY + CALL DRAWPV (IX,IY,1) + GO TO 300 +C +C ************************************* +C +C ENTRY FRSTD (FLDX,FLDY) +C + 330 IX = IIX + IY = IIY + IFSTFL = 2 +C AVOID UNEXPECTED PEN POSITION IF CALLS TO SYSTEM PLOT PACKAGE +C ROUTINES WERE MADE. + CALL DRAWPV (IMPOS,IMPOS,2) + IF (ISL) 300,30,340 + 340 CALL DRAWPV (IX,IY,0) + GO TO 300 +C +C ************************************* +C +C ENTRY LASTD +C + 350 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD +C + IF (IFSTFL .NE. 2) GO TO 300 + IFSTFL = 1 + K = 1 + IF (ISL .NE. 0) GO TO 300 + GO TO 210 + END + SUBROUTINE FRSTD (X,Y) +C USER ENTRY PPINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (1,IIX,IIY) + RETURN + END + SUBROUTINE VECTD (X,Y) +C USER ENTRY POINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (2,IIX,IIY) + RETURN + END + SUBROUTINE LASTD +C USER ENTRY POINT. SEE DOCUMENTATION FOR PURPOSE. + DATA IDUMMY /0/ + CALL FDVDLD (3,IDUMMY,IDUMMY) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE CURVED (X,Y,N) +C USER ENTRY POINT. +C + DIMENSION X(N),Y(N) +C + CALL FRSTD (X(1),Y(1)) + DO 10 I=2,N + CALL VECTD (X(I),Y(I)) + 10 CONTINUE +C + CALL LASTD +C + RETURN + END + SUBROUTINE LINED (XA,YA,XB,YB) +C USER ENTRY POINT. +C + DATA IDUMMY /0/ + CALL FL2INT (XA,YA,IXA,IYA) + CALL FL2INT (XB,YB,IXB,IYB) +C + CALL CFVLD (1,IXA,IYA) + CALL CFVLD (2,IXB,IYB) + CALL CFVLD (3,IDUMMY,IDUMMY) +C + RETURN +C +C------REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN77 AND GKS +C +C DECEMBER 1979 ADDED REVISION HISTORY AND STATISTICS +C CALL +C +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/ezmap.f b/sys/gio/ncarutil/ezmap.f new file mode 100644 index 00000000..8d87a4d7 --- /dev/null +++ b/sys/gio/ncarutil/ezmap.f @@ -0,0 +1,4598 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - I N T R O D U C T I O N +C*********************************************************************** +C +C THIS FILE CONTAINS IMPLEMENTATION INSTRUCTIONS, A WRITE-UP, AND THE +C CODE FOR THE PACKAGE EZMAP. BANNERS LIKE THE ONE ABOVE DELIMIT THE +C MAJOR SECTIONS OF THE FILE. THE CODE ITSELF IS SEPARATED INTO THREE +C SECTIONS: USER-LEVEL ROUTINES, INTERNAL ROUTINES, AND THE BLOCK DATA +C ROUTINE WHICH DETERMINES THE DEFAULT VALUES OF INTERNAL PARAMETERS. +C WITHIN EACH SECTION, ROUTINES APPEAR IN ALPHABETICAL ORDER. +C +C*********************************************************************** +C P A C K A G E E Z M A P - I M P L E M E N T A T I O N +C*********************************************************************** +C +C THE EZMAP PACKAGE IS WRITTEN IN FORTRAN-77 AND SHOULD BE RELATIVELY +C EASY TO IMPLEMENT. THE OUTLINE DATA REQUIRED MAY BE GENERATED BY +C RUNNING THE PROGRAM +C +C PROGRAM CONVRT +C DIMENSION FLIM(4),PNTS(200) +C 1 READ (1,3,END=2) NPTS,IGID,(FLIM(I),I=1,4) +C IF (NPTS.GT.1) READ (1,4,END=2) (PNTS(I),I=1,NPTS) +C WRITE (2) NPTS,IGID,(FLIM(I),I=1,4),(PNTS(I),I=1,NPTS) +C GO TO 1 +C 2 STOP +C 3 FORMAT (2I8,4F8.3) +C 4 FORMAT (10F8.3) +C END +C +C WITH THE FILE EZMAPDAT ASSIGNED TO UNIT 1. THE OUTPUT FILE, ON UNIT +C 2, CONTAINS THE BINARY OUTLINE DATA TO BE USED BY EZMAP. THE EZMAP +C ROUTINE MAPIO (WHICH SEE) MUST THEN BE MODIFIED TO ACCESS THIS FILE. +C +C THE ROUTINE MAPCHI CONTAINS THE STATEMENTS +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) +C +C (TO BE EXECUTED FOR A POSITIVE VALUE OF IPRT) AND THE STATEMENT +C +C CALL SETUSV ('IN',INTO) +C +C (TO BE EXECUTED FOR A NEGATIVE VALUE OF IPRT). THESE STATEMENTS +C SET/RESET THE INTENSITY FOR VARIOUS PORTIONS OF THE MAP. IF COLOR +C IS AVAILABLE ON THE DEVICE(S) BEING DRIVEN, THESE STATEMENTS SHOULD +C BE OMITTED AND THE IMPLEMENTOR SHOULD PROVIDE A DEFAULT VERSION OF +C MAPUSR WHICH SETS/RESETS THE INTENSITY AND COLOR AS DESIRED. THIS +C DEFAULT VERSION OF MAPUSR SHOULD DECLARE THE LABELLED COMMON BLOCK +C MAPNTS AND MAKE USE OF THE CURRENT VALUES IN THE ARRAY INTS TO SET +C THE INTENSITY; IT SHOULD ALSO BE PUBLISHED TO AID USERS IN SETTING +C UP THEIR OWN VERSIONS. +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - U S E R ' S G U I D E +C*********************************************************************** +C +C LATEST REVISION AUGUST, 1985 +C +C PURPOSE TO PLOT MAPS OF THE EARTH ACCORDING TO ANY +C ONE OF TEN DIFFERENT PROJECTIONS, SHOWING +C CONTINENTAL, INTERNATIONAL, AND/OR U.S. STATE +C OUTLINES, PARALLELS, AND MERIDIANS. THE +C ORIGIN AND ORIENTATION OF THE PROJECTION ARE +C SELECTED BY THE USER. POINTS ON THE EARTH +C DEFINED BY LATITUDE AND LONGITUDE ARE MAPPED +C TO POINTS IN THE PLANE OF PROJECTION - THE +C U/V PLANE. THE U AND V AXES ARE PARALLEL TO +C THE X AND Y AXES OF THE PLOTTER, RESPECTIVELY. +C A RECTANGULAR FRAME WHOSE SIDES ARE PARALLEL +C TO THE U AND V AXES IS CHOSEN AND MATERIAL +C WITHIN THAT FRAME (OR AN INSCRIBED ELLIPTICAL +C FRAME) IS PLOTTED. +C +C USAGE THE ROUTINE MAPDRW DRAWS A COMPLETE MAP, AS +C DIRECTED BY THE CURRENT VALUES OF PARAMETERS +C IN THE EZMAP PACKAGE. TO CHANGE THE VALUES +C OF THOSE PARAMETERS, AND THUS THE APPEARANCE +C OF THE MAP, ONE MAY FIRST CALL ONE OF THE +C ROUTINES MAPROJ (TO CHANGE THE PROJECTION TO +C BE USED), MAPSET (TO CHANGE WHAT PORTION OF +C THE U/V PLANE IS TO BE VIEWED), MAPPOS (TO +C CHANGE WHAT PORTION OF THE PLOTTER FRAME IS +C TO BE USED), OR ONE OF THE PARAMETER-SETTING +C ROUTINES MAPSTC, MAPSTI, MAPSTL, AND MAPSTR +C (TO CHANGE VARIOUS OTHER PARAMETERS, OF TYPES +C CHARACTER, INTEGER, LOGICAL, AND REAL). THE +C PARAMETER-RETRIEVAL ROUTINES MAPGTC, MAPGTI, +C MAPGTL, AND MAPGTR ALLOW THE USER TO RETRIEVE +C THE VALUES OF EZMAP PARAMETERS. +C +C THE ROUTINE MAPSAV ALLOWS ONE TO SAVE THE +C CURRENT STATE OF EZMAP, THE ROUTINE MAPRST TO +C RESTORE A SAVED STATE. +C +C USERS WITH SPECIAL NEEDS MAY WISH TO CALL THE +C LOWER-LEVEL ROUTINES MAPINT (TO INITIALIZE +C THE PACKAGE - IT MUST BE CALLED INITIALLY AND +C AGAIN WHENEVER CERTAIN PARAMETERS ARE CHANGED), +C MAPGRD (TO DRAW PARALLELS AND MERIDIANS), +C MAPLBL (TO LABEL THE INTERNATIONAL DATE LINE, +C THE EQUATOR, THE GREENWICH MERIDIAN, AND THE +C POLES, AND TO DRAW THE PERIMETER), AND MAPLOT +C (TO DRAW THE SELECTED GEOGRAPHIC OUTLINES). +C THESE ROUTINES ARE NORMALLY CALLED BY MAPDRW. +C +C INTENSITIES OF VARIOUS MAP PORTIONS MAY BE SET +C BY CALLS TO THE ROUTINE MAPSTI. THE ROUTINE +C MAPUSR IS CALLED BY EZMAP JUST BEFORE/AFTER +C DRAWING VARIOUS PORTIONS OF THE MAP; THE +C DEFAULT VERSION, WHICH DOES NOTHING, MAY BE +C REPLACED BY A USER VERSION WHICH SETS/RESTORES +C COLOR, SPOT SIZE, INTENSITY, DASH PATTERN, ETC. +C +C THE ROUTINE MAPEOS IS CALLED BY EZMAP ONCE FOR +C EACH OUTLINE SEGMENT. THE USER MAY SUPPLY A +C VERSION WHICH EXAMINES THE SEGMENT TO SEE IF +C IT OUGHT TO BE PLOTTED AND, IF NOT, TO DELETE +C IT. THIS MAY BE USED, FOR EXAMPLE, TO REDUCE +C THE CLUTTER IN NORTHERN CANADA. +C +C TO OVERLAY OBJECTS OF ONE'S OWN ON THE MAP +C DRAWN BY MAPDRW, ONE MAY USE ONE OR MORE OF +C THE ROUTINES MAPTRN (TO COMPUTE THE U/V +C COORDINATES OF A POINT, GIVEN ITS LATITUDE +C AND LONGITUDE), MAPIT (TO DO "PEN-UP/DOWN" +C MOVES), MAPFST (TO DO "PEN-UP" MOVES), AND +C MAPVEC (TO DO "PEN-DOWN" MOVES). +C +C THE ROUTINE SUPMAP, FROM WHICH EZMAP GREW, IS +C IMPLEMENTED WITHIN IT AND ALLOWS ONE TO DRAW +C A COMPLETE MAP WITH A SINGLE, RATHER LENGTHY, +C CALL. THE ROUTINE SUPCON, WHICH IS THE OLD +C ANALOGUE OF MAPTRN, IS ALSO IMPLEMENTED. +C +C THE OLD ROUTINE EZMAP, WHICH WAS IMPLEMENTED +C IN SUCH A WAY AS TO CAUSE PORTABILITY PROBLEMS, +C HAS BEEN REMOVED. STATISTICS INDICATED THAT +C IT WAS NOT BEING USED, ANYWAY. +C +C SEE THE WRITE-UPS OF INDIVIDUAL ROUTINES BELOW. +C +C I/O GRAPHICAL OUTPUT IS GENERATED. OUTLINE DATA +C IS READ FROM A "TAPE UNIT". +C +C ERROR CONDITIONS WHEN AN ERROR OCCURS DURING A CALL TO AN EZMAP +C ROUTINE, AN ERROR MESSAGE IS LOGGED, USING THE +C NCAR VERSION OF THE PORT ERROR ROUTINE SETERR +C (CALLED SETER); BY DEFAULT, THE PROGRAM IS THEN +C ABORTED. ERROR RECOVERY IS POSSIBLE, HOWEVER. +C INSERT THE CALL +C +C CALL ENTSR (IOLD,1) +C +C AT THE BEGINNING OF YOUR PROGRAM. THIS MAKES +C ERROR RECOVERY POSSIBLE. THEN, FOLLOWING EACH +C CALL TO AN EZMAP ROUTINE WHICH COULD CAUSE AN +C ERROR, INSERT CODE LIKE THE FOLLOWING: +C +C IF (NERRO(IERR).NE.0) THEN +C CALL EPRIN +C CALL ERROF +C END IF +C +C THE VALUE OF THE FUNCTION NERRO IS NON-ZERO IF +C SETER HAS BEEN CALLED. THE CALL TO EPRIN DUMPS +C OUT THE ERROR MESSAGE (WHICH HAS NOT YET BEEN +C PRINTED) AND THE CALL TO ERROF TURNS OFF THE +C ERROR CONDITION IN SETER. THIS DOES NOT CLEAR +C EZMAP'S ERROR FLAG, HOWEVER; IT REMAINS SET +C UNTIL AFTER THE NEXT SUCCESSFUL CALL TO MAPINT, +C PREVENTING OTHER EZMAP ROUTINES FROM TRYING TO +C EXECUTE (AND POSSIBLY BOMBING AS A RESULT). +C POSSIBLE ERROR FLAGS ARE AS FOLLOWS: +C +C 1 MAPGTC - UNKNOWN PARAMETER NAME XX +C 2 MAPGTI - UNKNOWN PARAMETER NAME XX +C 3 MAPGTL - UNKNOWN PARAMETER NAME XX +C 4 MAPGTR - UNKNOWN PARAMETER NAME XX +C 5 MAPINT - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 6 MAPINT - ANGULAR LIMITS TOO GREAT +C 7 MAPINT - MAP HAS ZERO AREA +C 8 MAPINT - MAP LIMITS INAPPROPIATE +C 9 MAPROJ - UNKNOWN PROJECTION NAME XX +C 10 MAPSET - UNKNOWN MAP AREA SPECIFIER XX +C 11 MAPSTC - UNKNOWN OUTLINE NAME XX +C 12 MAPSTC - UNKNOWN PARAMETER NAME XX +C 13 MAPSTI - UNKNOWN PARAMETER NAME XX +C 14 MAPSTL - UNKNOWN PARAMETER NAME XX +C 15 MAPSTR - UNKNOWN PARAMETER NAME XX +C 16 MAPTRN - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 17 MAPIO - OUTLINE DATASET IS UNREADABLE +C 18 MAPIO - EOF ENCOUNTERED IN OUTLINE +C DATASET +C 19 MAPPOS - ARGUMENTS ARE INCORRECT +C 20 MAPRST - ERROR ON READ +C 21 MAPRST - EOF ON READ +C 22 MAPSAV - ERROR ON WRITE +C +C PRECISION SINGLE. +C +C LANGUAGE FORTRAN. +C +C HISTORY IN ABOUT 1963, R. L. PARKER OF UCSD WROTE THE +C ORIGINAL CODE CALLED SUPERMAP, USING OUTLINE +C DATA GENERATED BY HERSHEY. THIS WAS ADAPTED +C FOR USE AT NCAR BY LEE, IN 1968. REVISIONS +C OCCURRED IN JANUARY OF 1969 AND MAY OF 1971. +C THE CODE WAS PUT IN STANDARD NSSL FORMAT IN +C OCTOBER OF 1973. FURTHER REVISIONS OCCURRED +C IN JULY, 1974, IN AUGUST, 1976, AND IN JULY, +C 1978. IN LATE 1984 AND EARLY 1985, THE CODE +C WAS HEAVILY REVISED TO ACHIEVE FORTRAN-77 AND +C GKS COMPATIBILITY, TO REMOVE ERRORS, AND TO +C EXPAND THE OUTLINE DATASETS. CICELY RIDLEY, +C JAY CHALMERS, AND DAVE KENNISON (THE CURRENT +C CURATOR) HAVE ALL HAD A HAND IN THE CREATION +C OF THIS PACKAGE. +C +C REFERENCES HERSHEY, A.V., "THE PLOTTING OF MAPS ON A +C CRT PRINTER." NWL REPORT NO. 1844, 1963. +C +C LEE, TSO-HWA, "STUDENTS' SUMMARY REPORTS, +C WORK-STUDY PROGRAM IN SCIENTIFIC COMPUTING". +C NCAR, 1968. +C +C PARKER, R.L., "2UCSD SUPERMAP: WORLD +C PLOTTING PACKAGE". +C +C STEERS, J.A., "AN INTRODUCTION TO THE STUDY +C OF MAP PROJECTIONS". UNIVERSITY OF LONDON +C PRESS, 1962. +C +C ACCURACY THE DEFINITION OF THE MAP PRODUCED IS LIMITED +C BY TWO FACTORS: THE RESOLUTION OF THE OUTLINE +C DATA AND THE RESOLUTION OF THE GRAPHICS +C DEVICE. +C +C DATA POINTS IN THE CONTINENTAL OUTLINES ARE +C ABOUT ONE DEGREE APART AND THE COORDINATES +C ARE ACCURATE TO .01 DEGREE. DATA POINTS IN +C U.S. STATE OUTLINES ARE ABOUT .05 DEGREES +C APART AND THE COORDINATES ARE ACCURATE TO +C .001 DEGREE. BOTH THE SPACING AND THE +C ACCURACY OT THE INTERNATIONAL BOUNDARIES +C FALLS SOMEWHERE BETWEEN THESE TWO EXTREMES. +C +C THE DICOMED HAS 15-BIT COORDINATE REGISTERS, +C BUT AN EFFECTIVE RESOLUTION OF AT MOST 1 IN +C 4096 IN BOTH X AND Y. +C +C TIMING THE MARCH, 1985, UPDATE HAS MADE EZMAP RUN +C SIGNIFICANTLY SLOWER. THIS IS MOSTLY BECAUSE +C THE DEFAULT RESOLUTION HAS BEEN INCREASED TO +C A VALUE SUITABLE FOR THE DICOMED, RATHER THAN +C THE DD80. USERS WHO ARE CONCERNED ABOUT THIS +C MAY INCREASE THE VALUES OF THE PARAMETERS 'MV' +C AND/OR 'DD' (SEE THE DESCRIPTION OF MAPSTX) +C TO DECREASE THE TIMING (AT THE EXPENSE OF PLOT +C QUALITY, OF COURSE). +C +C PORTABILITY THE CODE IS WRITTEN IN FORTRAN-77 AND SHOULD +C BE VERY PORTABLE. A BINARY DATASET CONTAINING +C OUTLINE DATA MUST BE GENERATED AND THE ROUTINE +C MAPIO MUST BE MODIFIED TO READ THAT DATASET. +C SEE THE IMPLEMENTATION INSTRUCTIONS AT THE +C BEGINNING OF THIS FILE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P D R W - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE COMPLETE MAP DESCRIBED BY THE +C CURRENT VALUES OF THE EZMAP PARAMETERS. +C +C MAPDRW CALLS MAPINT (IF REQUIRED), MAPGRD, +C MAPLBL, AND MAPLOT, IN THAT ORDER. THE USER +C MAY WISH TO CALL THESE ROUTINES DIRECTLY. +C +C USAGE CALL MAPDRW +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P E O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE MAPEOS IS CALLED BY EZMAP TO EXAMINE EACH +C SEGMENT IN THE OUTLINE DATASETS. THE DEFAULT +C VERSION DOES NOTHING. A USER-SUPPLIED VERSION +C MAY CAUSE SELECTED SEGMENTS TO BE DELETED (TO +C REDUCE THE CLUTTER IN NORTHERN CANADA, FOR +C EXAMPLE). +C +C USAGE (BY EZMAP) CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) +C +C ARGUMENTS NOUT IS THE NUMBER OF THE OUTLINE DATASET FROM +C WHICH THE SEGMENT COMES, AS FOLLOWS: +C +C NOUT DATASET TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 'CO' - CONTINENTAL OUTLINES ONLY. +C 2 'US' - U.S STATE OUTLINES ONLY. +C 3 'PS' - CONTINENTAL, U.S STATE, AND +C INTERNATIONAL OUTLINES. +C 4 'PO' - CONTINENTAL AND INTERNATIONAL +C OUTLINES. +C +C NSEG IS THE NUMBER OF THE SEGMENT WITHIN THE +C OUTLINE DATASET. +C +C IGID IDENTIFIES THE GROUP TO WHICH THE SEGMENT +C BELONGS, AS FOLLOWS: +C +C IGID GROUP TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 CONTINENTAL OUTLINES. +C 2 U.S. STATE BOUNDARIES. +C 3 INTERNATIONAL BOUNDARIES. +C +C NPTS IS THE NUMBER OF POINTS DEFINING THE +C OUTLINE SEGMENT. NPTS MAY BE ZEROED TO +C SUPPRESS PLOTTING OF THE SEGMENT. +C +C PNTS IS AN ARRAY OF COORDINATES. PNTS(1) +C AND PNTS(2) ARE THE LATITUDE AND LONGITUDE +C OF THE FIRST POINT, PNTS(3) AND PNTS(4) THE +C LATITUDE AND LONGITUDE OF THE SECOND POINT, ... +C PNTS(2*NPTS-1) AND PNTS(2*NPTS) THE LATITUDE +C AND LONGITUDE OF THE LAST POINT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P F S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPVEC. +C +C USAGE CALL MAPFST (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,0) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G R D - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A GRID MADE UP OF LINES OF LATITUDE AND +C LONGITUDE. IF EZMAP NEEDS INITIALIZATION OR IF +C THE ERROR FLAG 'ER' IS NON-ZERO, MAPGRD DOES +C NOTHING. +C +C USAGE CALL MAPGRD +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO GET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPGTC (WHCH,CVAL) +C CALL MAPGTI (WHCH,IVAL) +C CALL MAPGTL (WHCH,LVAL) +C CALL MAPGTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO GET. +C +C CVAL, IVAL, LVAL, OR RVAL IS A VARIABLE TO +C RECEIVE THE VALUE OF THE PARAMETER SPECIFIED +C BY WHCH - OF TYPE CHARACTER, INTEGER, LOGICAL, +C OR REAL, RESPECTIVELY. +C +C ALL OF THE PARAMETERS LISTED IN THE DISCUSSION +C OF MAPSTX MAY BE RETRIEVED. THE FOLLOWING MAY +C ALSO BE RETRIEVED: +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C AREA C THE VALUE OF THE MAP LIMITS +C SPECIFIER JLTS FROM THE LAST +C CALL TO MAPSET. THE DEFAULT +C VALUE IS 'MA'. +C +C ERROR I THE CURRENT VALUE OF THE ERROR +C FLAG. DEFAULT IS ZERO. +C +C INITIALIZE I,L INITIALIZATION FLAG. IF TRUE +C (NON-ZERO), EZMAP IS IN NEED +C OF INITIALIZATION (BY MEANS OF +C A CALL MAPINT). THE DEFAULT +C VALUE IS TRUE (NON-ZERO). +C +C PROJECTION C THE VALUE OF THE PROJECTION +C SPECIFIER JPRJ FROM THE LAST +C CALL TO MAPROJ. THE DEFAULT +C VALUE IS 'CE'. +C +C PN I,R THE VALUE OF PLON FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PT I,R THE VALUE OF PLAT FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PN I,R "N" IS AN INTEGER BETWEEN 1 +C AND 8. RETRIEVES VALUES FROM +C THE LAST CALL TO MAPSET. P1 +C THROUGH P4 GET YOU PLM1(1), +C PLM2(1), PLM3(1), AND PLM4(1), +C WHILE P5 THROUGH P8 GET YOU +C PLM1(2), PLM2(2), PLM3(2), AND +C PLM4(2). THE DEFAULT VALUES +C ARE ALL ZERO. +C +C ROTATION I,R THE VALUE OF ROTA FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C XLEFT R THE PARAMETERS XLOW, XROW, +C XRIGHT R YBOW, AND YTOW FROM THE LAST +C YBOTTOM R CALL TO MAPPOS. DEFAULTS +C YTOP R ARE .05, .95, .05, AND .95. +C +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I N T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO INITIALIZE THE PACKAGE AFTER THE VALUES OF +C SOME PARAMETERS HAVE BEEN CHANGED. THE FLAG +C 'IN', WHICH MAY BE RETRIEVED BY A CALL TO +C MAPGTI OR MAPGTL, INDICATES WHETHER OR NOT +C INITIALIZATION IS REQUIRED AT A GIVEN TIME. +C (SOME PARAMETERS MAY BE RESET AT ANY TIME AND +C DO NOT REQUIRE MAPINT TO BE CALLED AGAIN.) +C +C USAGE CALL MAPINT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL +C TO MAPDRW. MAPIT ATTEMPTS TO OMIT NON-VISIBLE +C PORTIONS AND TO HANDLE "CROSS-OVER" - A JUMP +C FROM ONE END OF THE MAP TO THE OTHER CAUSED +C BY THE PROJECTION'S HAVING SLIT THE GLOBE +C ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT +C OPEN WITH THE TWO SIDES OF THE SLIT AT OPPOSITE +C ENDS OF THE MAP. CROSS-OVER CAN OCCUR ON +C CYLINDRICAL AND CONICAL PROJECTIONS; MAPIT +C HANDLES IT VERY WELL ON THE FORMER AND NOT SO +C WELL ON THE LATTER. +C +C THE EZMAP PARAMETER 'DL' DETERMINES WHETHER +C MAPIT DRAWS SOLID LINES OR DOTTED LINES. THE +C PARAMETERS 'DD' AND 'MV' ALSO AFFECT MAPIT'S +C BEHAVIOR. SEE THE DESCRIPTION OF THE ROUTINE +C MAPSTX, BELOW. +C +C A SEQUENCE OF CALLS TO MAPIT SHOULD BE FOLLOWED +C BY A CALL TO MAPIQ (WHICH SEE, ABOVE) TO FLUSH +C ITS BUFFERS. +C +C POINTS IN TWO CONTIGUOUS PEN-DOWN CALLS TO +C MAPIT SHOULD NOT BE FAR APART ON THE GLOBE. +C +C USAGE CALL MAPIT (RLAT,RLON,IFST) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE +C OF A POINT TO WHICH THE "PEN" IS TO BE MOVED. +C BOTH ARE GIVEN IN DEGREES. RLAT MUST BE +C BETWEEN -90. AND +90., INCLUSIVE; RLON MUST BE +C BETWEEN -540. AND +540., INCLUSIVE. +C +C IFST IS 0 TO DO A "PEN-UP" MOVE, 1 TO DO A +C "PEN-DOWN" MOVE IF THE DISTANCE FROM THE LAST +C POINT TO THE NEW POINT IS GREATER THAN 'MV' +C PLOTTER UNITS, 2 OR GREATER TO DO THE MOVE +C REGARDLESS OF THE DISTANCE FROM THE LAST POINT +C TO THE NEW ONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I Q - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FLUSH MAPIT'S BUFFERS. THIS IS PARTICULARLY +C IMPORTANT BEFORE A STOP OR A CALL FRAME AND +C BEFORE CHANGING INTENSITY, DASH PATTERN, COLOR, +C ETC. +C +C USAGE CALL MAPIQ +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L B L - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO LABEL THE INTERNATIONAL DATE LINE (ID), THE +C EQUATOR (EQ), THE GREENWICH MERIDIAN (GM), AND +C THE POLES (NP AND SP), AND TO DRAW THE BORDER +C AROUND THE MAP. IF EZMAP NEEDS INITIALIZATION +C OR IF THE ERROR FLAG 'ER' IS SET, MAPLBL DOES +C NOTHING. +C +C USAGE CALL MAPLBL +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L O T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE CONTINENTAL AND/OR INTERNATIONAL +C AND/OR U.S. STATE OUTLINES SELECTED BY THE +C PARAMETER 'OU'. IF EZMAP CURRENTLY NEEDS +C INITIALIZATION OR IF THE ERROR FLAG 'ER' IS +C SET, MAPLOT DOES NOTHING. +C +C USAGE CALL MAPLOT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P P O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE POSITION OF THE MAP ON THE +C PLOTTER FRAME. +C +C USAGE CALL MAPPOS (XLOW,XROW,YBOW,YTOW) +C +C ARGUMENTS THE ARGUMENTS ARE FRACTIONS BETWEEN 0 AND 1 +C DETERMINING THE POSITION OF A WINDOW IN THE +C PLOTTER FRAME WITHIN WHICH THE MAP IS TO BE +C DRAWN. XLOW AND XROW POSITION THE LEFT AND +C RIGHT EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM LEFT TO RIGHT IN THE PLOTTER +C FRAME. YBOW AND YTOW POSITION THE BOTTOM AND +C TOP EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM BOTTOM TO TOP IN THE PLOTTER +C FRAME. THE MAP IS CENTERED IN THE SPECIFIED +C WINDOW AND MADE AS LARGE AS POSSIBLE WHILE +C MAINTAINING ITS PROPER SHAPE. +C +C THE DEFAULT VALUES OF THE INTERNAL PARAMETERS +C CHANGED BY THIS ROUTINE ARE .05, .95, .05, AND +C .95, RESPECTIVELY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R O J - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE PROJECTION TO BE USED. +C +C USAGE CALL MAPROJ (JPRJ,PLAT,PLON,ROTA) +C +C ARGUMENTS JPRJ IS A CHARACTER VARIABLE DEFINING THE +C DESIRED PROJECTION TYPE, AS FOLLOWS: +C +C THE CONIC PROJECTION: +C +C 'LC' - LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS. +C +C THE AZIMUTHAL PROJECTIONS: +C +C 'ST' - STEREOGRAPHIC. +C +C 'OR' - ORTHOGRAPHIC. CAUSES THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) TO BE ZEROED. +C +C 'LE' - LAMBERT EQUAL AREA. +C +C 'GN' - GNOMONIC. +C +C 'AE' - AZIMUTHAL EQUIDISTANT. +C +C 'SV' - SATELLITE-VIEW. IF THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) IS GREATER +C THAN 1 OR LESS THAN -1, IT IS LEFT +C ALONE; OTHERWISE, IT IS GIVEN THE +C VALUE 6.631. +C +C THE CYLINDRICAL PROJECTIONS: +C +C 'CE' - CYLINDRICAL EQUIDISTANT. +C +C 'ME' - MERCATOR. +C +C 'MO' - MOLLWEIDE. THE PROJECTION USED IS +C NOT ACTUALLY A TRUE MOLLWEIDE. +C +C PLAT, PLON, AND ROTA ARE REALS SPECIFYING THE +C VALUES OF ANGULAR QUANTITIES, IN DEGREES. HOW +C THEY ARE USED DEPENDS ON THE VALUE OF JPRJ, AS +C FOLLOWS: +C +C IF JPRJ IS NOT EQUAL TO 'LC': PLAT AND PLON +C DEFINE THE LATITUDE AND LONGITUDE OF THE POLE +C OF THE PROJECTION - THE POINT ON THE GLOBE +C WHICH IS TO BE PROJECTED TO THE ORIGIN OF THE +C U/V PLANE. PLAT MUST BE BETWEEN -90. AND +90., +C INCLUSIVE, POSITIVE IN THE NORTHERN HEMISPHERE, +C NEGATIVE IN THE SOUTHERN. PLON MUST BE BETWEEN +C -180. AND +180., INCLUSIVE, POSITIVE TO THE +C EAST, AND NEGATIVE TO THE WEST, OF GREENWICH. +C ROTA IS THE ANGLE BETWEEN THE V AXIS AND NORTH +C AT THE ORIGIN. IT IS TAKEN TO BE POSITIVE IF +C THE ANGULAR MOVEMENT FROM NORTH TO THE V AXIS +C IS COUNTER-CLOCKWISE, NEGATIVE OTHERWISE. IF +C THE ORIGIN IS AT THE NORTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON+180. +C IF THE ORIGIN IS AT THE SOUTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON. +C FOR THE CYLINDRICAL PROJECTIONS, THE AXIS OF +C THE PROJECTION IS PARALLEL TO THE V AXIS. +C +C IF JPRJ IS EQUAL TO 'LC' (LAMBERT CONFORMAL +C CONIC WITH TWO STANDARD PARALLELS): PLON +C DEFINES THE CENTRAL MERIDIAN OF THE PROJECTION, +C WHILE PLAT AND ROTA DEFINE THE TWO STANDARD +C PARALLELS. IF PLAT AND ROTA ARE EQUAL, A +C CONIC PROJECTION WITH ONE STANDARD PARALLEL +C IS USED. +C +C MORE DETAILED DESCRIPTIONS OF THE PROJECTIONS +C MAY BE FOUND IN THE GRAPHICS MANUAL, TOGETHER +C WITH HELPFUL DIAGRAMS, BUT A FEW WORDS MAY BE +C HELPFUL HERE: +C +C THE CONICAL PROJECTION MAPS THE SURFACE OF THE +C EARTH ONTO THE SURFACE OF A CONE INTERSECTING +C THE EARTH ALONG THE TWO STANDARD PARALLELS. +C THE CONE IS THEN SLIT ALONG A LINE OPPOSITE +C THE CENTRAL MERIDIAN AND OPENED UP (WITH SOME +C STRETCHING) ONTO A FLAT SURFACE. +C +C THE AZIMUTHAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH (OR OF ONE HEMISPHERE OF THE EARTH) +C ONTO A PLANE WHOSE ORIGIN IS TANGENT TO IT AT +C THE POINT (PLAT,PLON). THE SEVERAL AZIMUTHAL +C PROJECTIONS DIFFER ONLY IN THE FUNCTION USED +C TO MAP THE GREAT-CIRCLE DISTANCE OF A POINT +C FROM THE POLE (PLAT,PLON) TO A LINEAR DISTANCE +C OF THE PROJECTED POINT FROM THE ORIGIN (0,0). +C THE PROJECTED IMAGE MAY BE ROTATED USING THE +C PARAMETER ROTA. +C +C THE CYLINDRICAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH ONTO A CYLINDER WHICH IS TANGENT TO +C IT ALONG A GREAT CIRCLE PASSING THROUGH THE +C POINT (PLAT,PLON) AT AN ANGLE DETERMINED BY +C ROTA. THE CYLINDER IS THEN SLIT ALONG ITS +C LENGTH THROUGH THE POINT OPPOSITE (PLAT,PLON) +C AND OPENED UP ONTO THE PLANE. THE SEVERAL +C CYLINDRICAL PROJECTIONS DIFFER PRINCIPALLY IN +C THE FUNCTION USED TO MAP THE DISTANCE FROM THE +C GREAT CIRCLE OF TANGENCY TO A DISTANCE ALONG +C THE CYLINDER. IF PLAT IS ZERO AND ROTA IS +C EITHER 0. OR 180., THE CYLINDRICAL PROJECTIONS +C ARE PARTICULARLY SIMPLE TO DO AND A FASTER PATH +C THROUGH THE CODE IS USED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RECALLS SET. INTENDED TO BE USED WHEN DATA +C IS TO BE PLOTTED OVER A MAP GENERATED IN A +C DIFFERENT OVERLAY (E.G., USING A FLASH BUFFER), +C AND WHEN THE SYSTEM PLOT PACKAGE DOES NOT +C RESIDE IN AN OUTER OVERLAY. +C +C USAGE CALL MAPRS +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RESTORES A SAVED STATE OF EZMAP. THIS IS DONE +C BY READING SAVED PARAMETER VALUES FROM A USER +C UNIT AND THEN CALLING MAPINT. SEE MAPSAV. +C +C USAGE CALL MAPRST (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT FROM WHICH A +C SINGLE UNFORMATTED RECORD IS TO BE READ. IT +C IS THE USER'S RESPONSIBILITY TO POSITION THIS +C UNIT. MAPRST DOES NOT REWIND IT, EITHER BEFORE +C OR AFTER READING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S A V - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE SAVES THE CURRENT STATE OF EZMAP BY WRITING +C PARAMETER VALUES ONTO A USER UNIT. SEE MAPRST. +C +C USAGE CALL MAPSAV (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT TO WHICH A SINGLE +C UNFORMATTED RECORD IS TO BE WRITTEN. IT IS THE +C USER'S RESPONSIBILITY TO POSITION THIS UNIT. +C MAPSAV DOES NOT REWIND IT, EITHER BEFORE OR +C AFTER WRITING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S E T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE RECTANGULAR PORTION OF THE U/V +C PLANE TO BE DRAWN. +C +C USAGE CALL MAPSET (JLTS,PLM1,PLM2,PLM3,PLM4) +C +C ARGUMENTS JLTS CAN HAVE THE FOLLOWING CHARACTER VALUES. +C IT SPECIFIES ONE OF FIVE WAYS IN WHICH THE +C LIMITS OF THE MAP ARE DEFINED BY THE PARAMETERS +C PLM1, PLM2, PLM3, AND PLM4. +C +C JLTS='MA' (MAXIMUM). THE MAXIMUM USEFUL AREA +C PRODUCED BY THE PROJECTION IS PLOTTED. PLM1, +C PLM2, PLM3, AND PLM4 ARE NOT USED. +C +C JLTS='CO' (CORNERS). THE POINTS (PLM1,PLM2) +C AND (PLM3,PLM4) ARE TO BE AT OPPOSITE CORNERS +C OF THE MAP. PLM1 AND PLM3 ARE LATITUDES, IN +C DEGREES. PLM2 AND PLM4 ARE LONGITUDES, IN +C DEGREES. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE OF THE MAP AND THE SECOND POINT ON THE +C RIGHT EDGE; OTHERWISE, THE ORDER MAKES NO +C DIFFERENCE. +C +C JLTS='PO' (POINTS). PLM1, PLM2, PLM3, AND PLM4 +C ARE TWO-ELEMENT ARRAYS GIVING THE LATITUDES +C AND LONGITUDES, IN DEGREES, OF FOUR POINTS +C WHICH ARE TO BE ON THE EDGES OF THE RECTANGULAR +C MAP. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE AND THE SECOND POINT ON THE RIGHT EDGE; +C OTHERWISE, THE ORDER MAKES NO DIFFERENCE. +C NOTE THAT THE CALLING PROGRAM SHOULD INCLUDE +C THE FOLLOWING STATEMENT: +C +C DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C (IN FACT, STRICT ADHERENCE TO THE FORTRAN-77 +C STANDARD REQUIRES THIS, NO MATTER WHAT THE +C VALUE OF JLTS.) +C +C JLTS='AN' (ANGLES). PLM1, PLM2, PLM3, AND PLM4 +C ARE POSITIVE ANGLES, IN DEGREES, REPRESENTING +C ANGULAR DISTANCES FROM A POINT ON THE MAP TO +C THE LEFT, RIGHT, BOTTOM, AND TOP EDGES OF THE +C MAP. FOR MOST PROJECTIONS, THESE ANGLES ARE +C MEASURED WITH THE CENTER OF THE EARTH AT THE +C VERTEX AND REPRESENT ANGULAR DISTANCES FROM THE +C POINT WHICH PROJECTS TO THE ORIGIN OF THE U/V +C PLANE; ON A SATELLITE-VIEW PROJECTION, THEY ARE +C MEASURED WITH THE SATELLITE AT THE VERTEX AND +C REPRESENT ANGULAR DEVIATIONS FROM THE LINE OF +C SIGHT. ANGULAR LIMITS ARE PARTICULARLY USEFUL +C FOR POLAR PROJECTIONS AND THE SATELLITE-VIEW +C PROJECTION; THEY ARE NOT APPROPRIATE FOR THE +C LAMBERT CONFORMAL CONIC AND AN ERROR WILL +C RESULT IF ONE ATTEMPTS TO USE JLTS='AN' WITH +C JPRJ='LC'. +C +C JLTS='LI' (LIMITS). PLM1, PLM2, PLM3, AND PLM4 +C SPECIFY THE MINIMUM VALUE OF U, THE MAXIMUM +C VALUE OF U, THE MINIMUM VALUE OF V, AND THE +C MAXIMUM VALUE OF V, RESPECTIVELY. KNOWLEDGE +C OF THE PROJECTION EQUATIONS IS NECESSARY IN +C ORDER TO USE THIS OPTION CORRECTLY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPSTC (WHCH,CVAL) +C CALL MAPSTI (WHCH,IVAL) +C CALL MAPSTL (WHCH,LVAL) +C CALL MAPSTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO BE SET. +C +C CVAL, IVAL, LVAL, OR RVAL IS THE VALUE TO BE +C GIVEN TO THE PARAMETER SPECIFIED BY WHCH - OF +C TYPE CHARACTER, INTEGER, LOGICAL, OR REAL, +C RESPECTIVELY. +C +C SOME PARAMETERS MAY BE SET IN MORE THAN ONE +C WAY. FOR EXAMPLE, THE PARAMETER 'GR' (GRID), +C WHICH SPECIFIES THE GRID SPACING, MAY BE GIVEN +C THE VALUE 10.0 IN EITHER OF TWO WAYS: +C +C CALL MAPSTI ('GR',10) +C CALL MAPSTR ('GR',10.) +C +C THE FLAG WHICH CONTROLS DOTTING OF OUTLINES +C MAY BE TURNED ON USING EITHER OF THESE CALLS: +C +C CALL MAPSTI ('DO',1) +C CALL MAPSTL ('DO',.TRUE.) +C +C THE IMPORTANT POINT TO REMEMBER IS THAT THE +C LAST CHARACTER OF THE ROUTINE NAME IMPLIES +C THE TYPE OF THE ARGUMENT. +C +C ONLY THE FIRST TWO CHARACTERS OF WHCH ARE +C EXAMINED. FOR THE SAKE OF CODE READABILITY, +C A LONGER CHARACTER STRING MAY BE USED. +C +C BELOW IS A LIST OF ALL THE PARAMETERS WHICH +C MAY BE SET USING THESE ROUTINES. +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C DASHPATTERN I DASHED-LINE PATTERN FOR THE +C GRIDS. A 16-BIT QUANTITY. +C DEFAULT IS 21845 (OCTAL 52525 +C OR BINARY 0101010101010101). +C +C DD I,R DISTANCE BETWEEN DOTS ALONG A +C DOTTED LINE DRAWN BY MAPIT. +C THE DEFAULT VALUE IS 12 (OUT +C OF 4096; SEE 'RE', BELOW). +C +C DL I,L IF TRUE (NON-ZERO), USER CALLS +C TO MAPIT DRAW DOTTED LINES. +C DEFAULT IS FALSE (ZERO); LINES +C DRAWN BY MAPIT ARE SOLID OR +C DASHED, DEPENDING ON THE +C CURRENT STATE OF THE DASHCHAR +C PACKAGE. +C +C DOT I,L IF TRUE (NON-ZERO), OUTLINES +C ARE DOTTED. DEFAULT IS FALSE +C (ZERO); OUTLINES ARE SOLID. +C +C ELLIPTICAL I,L IF TRUE (NON-ZERO), ONLY THAT +C PART OF THE MAP WHICH FALLS +C INSIDE AN ELLIPSE INSCRIBED +C WITHIN THE NORMAL RECTANGULAR +C PERIMETER IS DRAWN. THIS IS +C PARTICULARLY APPROPRIATE FOR +C USE WITH AZIMUTHAL PROJECTIONS +C AND ANGULAR LIMITS SPECIFYING +C A SQUARE, IN WHICH CASE THE +C ELLIPSE BECOMES A CIRCLE, BUT +C IT WILL WORK FOR ANY MAP. THE +C DEFAULT VALUE IS ZERO. +C +C GD R THE DISTANCE BETWEEN POINTS +C USED TO DRAW THE GRID, IN +C DEGREES. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. +C +C GRID I,R THE DESIRED GRID SPACING. A +C ZERO SUPPRESSES THE GRID. THE +C DEFAULT IS 10 DEGREES. +C +C IN I "N" IS AN INTEGER BETWEEN 1 +C AND 7. EACH "IN" SPECIFIES +C THE INTENSITY OF SOME PORTION +C OF THE MAP. VALUES ARE IN THE +C RANGE 0-255. DEFAULTS ARE: +C +C N USE DEFAULT +C - ----------- ------- +C 1 PERIMETER 240 +C 2 GRID 150 +C 3 LABELS 210 +C 4 LIMBS 240 +C 5 CONTINENTS 240 +C 6 U.S. STATES 180 +C 7 COUNTRIES 210 +C +C LABEL I,L IF TRUE (NON-ZERO), LABEL THE +C MERIDIANS AND POLES. DEFAULT +C IS TRUE (NON-ZERO). +C +C LS I CONTROLS LABEL SIZE. A +C CHARACTER WIDTH, TO BE USED +C IN CALLING PWRIT. THE DEFAULT +C VALUE IS 1, WHICH GIVES A +C CHARACTER WIDTH OF 12 PLOTTER +C UNITS. +C +C MV I,R MINIMUM VECTOR LENGTH FOR +C OUTLINES. A POINT CLOSER TO +C THE PREVIOUS POINT THAN THIS +C IS OMITTED. DEFAULT VALUE IS +C 4 (OUT OF 4096; SEE 'RE', +C BELOW). +C +C OUTLINE C SAYS WHICH SET OF OUTLINE DATA +C TO USE. POSSIBLE VALUES ARE +C 'NO', FOR NO OUTLINES, 'CO', +C FOR THE CONTINENTAL OUTLINES +C (THE DEFAULT), 'US', FOR U.S. +C STATE OUTLINES, 'PS', FOR +C CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES PLUS +C U.S. STATE OUTLINES, AND 'PO', +C FOR CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES. +C DEFAULT IS 'CO'. +C +C PERIM I,L IF TRUE (NON-ZERO), DRAW THE +C PERIMETER. DEFAULT IS TRUE +C (NON-ZERO). +C +C RESOLUTION I,R THE WIDTH OF THE TARGET +C PLOTTER, IN PLOTTER UNITS. +C DEFAULT VALUE IS 4096. +C +C SATELLITE I,R IF LESS THAN -1 OR GREATER +C THAN 1, CHANGES ORTHOGRAPHIC +C PROJECTION TO SATELLITE-VIEW. +C ABSOLUTE VALUE IS THE DISTANCE +C OF SATELLITE FROM THE CENTER +C OF THE EARTH, IN MULTIPLES OF +C THE EARTH'S RADIUS. THE SIGN +C INDICATES WHETHER A NORMAL +C PROJECTION (POSITIVE) OR AN +C EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE EXTENDED +C PROJECTION IS USEFUL WHEN ONE +C IS OVERLAYING CONREC OUTPUT ON +C A MAP. THE DEFAULT VALUE OF +C 'SA' IS ZERO. SEE ALSO 'S1' +C AND 'S2', BELOW. +C +C S1 AND S2 I,R USED ONLY WHEN 'SA' IS OUTSIDE +C [-1,1]. BOTH ARE ANGLES, IN +C DEGREES. 'S1' MEASURES THE +C ANGLE BETWEEN THE CENTER OF +C THE EARTH AND THE AIM POINT +C OF THE SATELLITE'S CAMERA, AS +C SEEN FROM THE SATELLITE. IF +C 'S1' IS ZERO, THE PROJECTION +C SHOWS THE EARTH AS SEEN BY A +C SATELLITE LOOKING STRAIGHT +C DOWN; CALL THIS THE "BASIC +C VIEW". IF 'S1' IS NON-ZERO, +C 'S2' MEASURES THE ANGLE FROM +C THE POSITIVE U AXIS OF THE +C BASIC VIEW TO THE LINE OP, +C WHERE O IS THE ORIGIN OF THE +C BASIC VIEW AND P IS THE +C PROJECTION OF THE DESIRED LINE +C OF SIGHT ON THE BASIC VIEW, +C POSITIVE IF MEASURED COUNTER- +C CLOCKWISE. +C +C SR R A SEARCH RADIUS, IN DEGREES. +C USED BY MAPINT IN FINDING THE +C LATITUDE/LONGITUDE RANGE OF +C THE MAP. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. THIS +C PARAMETER SHOULD PROBABLY NOT +C BE CHANGED EXCEPT BY ADVICE +C OF A KNOWLEDGEABLE CONSULTANT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P T R N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C MAY BE CALLED AT ANY TIME AFTER EZMAP HAS BEEN +C INITIALIZED (BY CALLING MAPINT OR OTHERWISE). +C +C USAGE CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE, +C RESPECTIVELY, OF A POINT ON THE GLOBE. RLAT +C MUST BE BETWEEN -90. AND +90., INCLUSIVE; RLON +C MUST BE BETWEEN -540. AND +540., INCLUSIVE. +C +C (UVAL,VVAL) IS THE PROJECTION IN THE U/V PLANE +C OF (RLAT,RLON). THE UNITS OF UVAL AND VVAL +C DEPEND ON THE PROJECTION. +C +C IF THE POINT IS NOT PROJECTABLE, UVAL IS +C RETURNED EQUAL TO 1.E12. NOTE THAT, IF +C THE POINT IS PROJECTABLE, BUT OUTSIDE THE +C BOUNDARY OF THE MAP, AS DEFINED BY THE LAST +C CALL TO MAPSET, ITS U AND V COORDINATES ARE +C STILL RETURNED BY MAPTRN. THE USER MUST DO +C THE TEST REQUIRED TO DETERMINE IF THE POINT +C IS WITHIN LIMITS, IF THAT IS NECESSARY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P U S R - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE THE ROUTINE MAPUSR IS CALLED BY EZMAP JUST +C BEFORE AND JUST AFTER PORTIONS OF THE MAP +C ARE DRAWN. THE DEFAULT VERSION DOES NOTHING. +C (ACTUALLY, THAT'S NOT QUITE TRUE; FOR THE SAKE +C OF EFFICIENCY, THE NON-GKS VERSIONS RESETS THE +C DASH PATTERN FOR GRID LINES TO "SOLID" AND +C THEN DOES AN OPTN CALL TO MAKE THE TRANSLATOR +C GENERATE THE DESIRED PATTERN.) A USER-SUPPLIED +C VERSION MAY SET/RESET THE DOTTING PARAMETER +C 'DL', THE DASHCHAR DASH PATTERN, THE INTENSITY, +C THE COLOR, ETC., SO AS TO ACHIEVE A DESIRED +C EFFECT. +C +C USAGE (BY EZMAP) CALL MAPUSR (IPRT) +C +C ARGUMENTS IPRT, IF POSITIVE, SAYS THAT A PARTICULAR PART +C OF THE MAP IS ABOUT TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART +C ---- ----------------------- +C 1 PERIMETER. +C 2 GRID. +C 3 LABELS. +C 4 LIMB LINES. +C 5 CONTINENTAL OUTLINES. +C 6 U.S. STATE OUTLINES. +C 7 INTERNATIONAL OUTLINES. +C +C IF IPRT IS NEGATIVE, IT SAYS THAT DRAWING OF +C THE LAST PART IS COMPLETE. THE ABSOLUTE VALUE +C OF IPRT WILL BE ONE OF THE ABOVE VALUES. +C CHANGED QUANTITIES SHOULD BE RESTORED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P V E C - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPFST. +C +C USAGE CALL MAPVEC (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,1) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P C O N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C THIS ROUTINE IS PROVIDED FOR COMPATIBILITY +C WITH EARLIER VERSIONS OF THE PACKAGE. IF +C EFFICIENCY IS A CONSIDERATION, THE USER SHOULD +C BY-PASS THIS ROUTINE AND CALL MAPTRN DIRECTLY. +C +C USAGE CALL SUPCON (RLAT,RLON,UVAL,VVAL) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT, RLON, UVAL, AND VVAL ARE DEFINED AS FOR +C THE ROUTINE MAPTRN. SEE THE DESCRIPTION OF +C MAPTRN. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P M A P - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE AN IMPLEMENTATION OF THE ROUTINE FROM WHICH +C EZMAP GREW. A SINGLE CALL TO SUPMAP CREATES +C A MAP OF A DESIRED PORTION OF THE GLOBE, +C ACCORDING TO A DESIRED PROJECTION, WITH DESIRED +C OUTLINES DRAWN IN, AND WITH LINES OF LATITUDE +C AND LONGITUDE AT DESIRED INTERVALS. AN +C APPROPRIATE CALL TO THE ROUTINE SET IS +C PERFORMED, AND THE ROUTINE SUPCON (WHICH SEE) +C IS INITIALIZED SO THAT THE USER MAY MAP POINTS +C OF KNOWN LATITUDE AND LONGITUDE TO POINTS IN +C THE U/V PLANE AND USE THE U/V COORDINATES TO +C DRAW OBJECTS ON THE MAP PRODUCED BY SUPMAP. +C +C USAGE CALL SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2, +C PLM3,PLM4,JLTS,JGRD,IOUT,IDOT, +C IERR) +C +C ARGUMENTS IABS(JPRJ) DEFINES THE PROJECTION TYPE, AS +C FOLLOWS (VALUES LESS THAN 1 OR GREATER THAN +C 10 ARE TREATED AS 1 OR 10, RESPECTIVELY): +C +C 1 STEREOGRAPHIC. +C 2 ORTHOGRAPHIC. +C 3 LAMBERT CONFORMAL CONIC. +C 4 LAMBERT EQUAL AREA. +C 5 GNOMONIC. +C 6 AZIMUTHAL EQUIDISTANT. +C 7 SATELLITE VIEW. +C 8 CYLINDRICAL EQUIDISTANT. +C 9 MERCATOR. +C 10 MOLLWEIDE. +C +C USING THE VALUE 2 CAUSES THE PARAMETER 'SA' TO +C BE ZEROED. USING THE VALUE 7 CAUSES 'SA' TO +C BE EXAMINED. IF IT HAS A NON-ZERO VALUE, THE +C VALUE IS LEFT ALONE. IF IT HAS A ZERO VALUE, +C ITS VALUE IS RESET TO 6.631, WHICH IS ABOUT +C RIGHT FOR A SATELLITE IN A GEOSYNCHRONOUS +C EQUATORIAL ORBIT (FOR WHATEVER THAT'S WORTH). +C +C THE SIGN OF JPRJ, WHEN IOUT IS -1, 0, OR 1, +C INDICATES WHETHER THE CONTINENTAL OUTLINES ARE +C TO BE PLOTTED OR NOT. SEE IOUT, BELOW. +C +C PLAT, PLON, AND ROTA DEFINE THE ORIGIN OF THE +C PROJECTION AND ITS ROTATION ANGLE AND ARE USED +C IN THE SAME WAY AS THEY WOULD BE IN A CALL TO +C THE ROUTINE MAPROJ (WHICH SEE). +C +C JLTS, PLM1, PLM2, PLM3, AND PLM4 SPECIFY THE +C RECTANGULAR LIMITS OF THE MAP. THESE ARGUMENTS +C ARE USED IN THE SAME WAY AS THEY WOULD BE IN +C A CALL TO MAPSET (WHICH SEE), EXCEPT THAT JLTS +C IS AN INTEGER INSTEAD OF A CHARACTER STRING. +C IABS(JLTS) MAY TAKE ON THE VALUES 1 THROUGH 5, +C AS FOLLOWS: +C +C 1 LIKE JLTS='MA' IN A CALL TO MAPSET. +C 2 LIKE JLTS='CO' IN A CALL TO MAPSET. +C 3 LIKE JLTS='LI' IN A CALL TO MAPSET. +C 4 LIKE JLTS='AN' IN A CALL TO MAPSET. +C 5 LIKE JLTS='PO' IN A CALL TO MAPSET. +C +C AT ONE TIME, THE SIGN OF JLTS SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN AT THE +C BOTTOM OF THE PLOT PRODUCED. THIS LINE MAY NO +C LONGER BE WRITTEN AND THE SIGN OF JLTS IS +C THEREFORE IGNORED. +C +C MOD(IABS(JGRD),1000) IS THE VALUE, IN DEGREES, +C OF THE INTERVAL AT WHICH LINES OF LATITUDE AND +C LONGITUDE ARE TO BE PLOTTED. IF THE GIVEN +C INTERVAL IS ZERO, GRID LINES AND LABELS ARE +C NOT PLOTTED. IF JGRD IS LESS THAN ZERO, THE +C PERIMETER IS NOT PLOTTED. SET JGRD TO -1000 TO +C SUPPRESS BOTH GRID LINES AND PERIMETER AND TO +C +1000 TO SUPPRESS THE GRID LINES, BUT LEAVE THE +C PERIMETER. THE VALUE -0 MAY HAVE A MEANING ON +C ONES' COMPLEMENT MACHINES, BUT SHOULD BE +C AVOIDED; USE -1000 INSTEAD. +C +C IF IOUT HAS THE VALUE 0, U.S. STATE OUTLINES +C ARE OMITTED. IF IT HAS THE ABSOLUTE VALUE 1, +C THEY ARE PLOTTED. IN BOTH OF THESE CASES, THE +C SIGN OF JPRJ INDICATES WHETHER CONTINENTAL +C OUTLINES ARE TO BE PLOTTED (JPRJ POSITIVE) +C OR NOT (JPRJ NEGATIVE). ORIGINALLY, SUPMAP +C RECOGNIZED ONLY THESE VALUES OF IOUT; NOW, IF +C IOUT IS LESS THAN -1 OR GREATER THAN 1, THE +C SIGN OF JPRJ IS IGNORED, AND IOUT SELECTS AN +C OUTLINE GROUP, AS FOLLOWS: +C +C -2 OR LESS 'NO' (NO OUTLINES). +C 2 'CO' (CONTINENTAL OUTLINES). +C 3 'US' (U.S. STATE OUTLINES). +C 4 'PS' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES PLUS U.S. +C STATE OUTLINES). +C 5 OR GREATER 'PO' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES, BUT NO U.S. +C STATE OUTLINES). +C +C AT ONE TIME, THE SIGN OF IOUT SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN ON THE +C PRINT OUTPUT. THIS MAY NO LONGER BE DONE. +C +C IDOT=0 TO GET CONTINUOUS OUTLINES, 1 TO GET +C DOTTED OUTLINES. +C +C IERR IS AN OUTPUT PARAMETER. A NON-ZERO VALUE +C INDICATES THAT AN ERROR HAS OCCURRED. +C +C*********************************************************************** +C T H E C O D E - U S E R - L E V E L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPDRW +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPDRW','VERSION 1') +C +C INITIALIZE THE PACKAGE, DRAW AND LABEL THE GRID, AND DRAW OUTLINES. +C + IF (INTF) CALL MAPINT + CALL MAPGRD + CALL MAPLBL + CALL MAPLOT +C + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + DIMENSION PNTS(*) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPFST (XLAT,XLON) + CALL MAPIT (XLAT,XLON,0) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGRD +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE LOCAL LOGICAL FLAGS. +C + LOGICAL IMF,IPF +C +C DEFINE REQUIRED CONSTANTS. +C + DATA DTOR / .017453292519943 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGRD','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE GRID IS SUPPRESSED, DO NOTHING. +C + IF (GRID.LE.0.) RETURN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR THE GRID. +C + CALL MAPCHI (2,0,IDSH) +C +C SET THE FLAGS IMF AND IPF, WHICH ARE TRUE IF AND ONLY IF MERIDIANS AND +C PARALLELS, RESPECTIVELY, ARE STRAIGHT LINES AND IT IS "SAFE" TO DRAW +C THEM USING LONG LINE SEGMENTS. WHAT WE HAVE TO BE SURE OF IS THAT AT +C LEAST ONE OF THE TWO ENDPOINTS OF EACH MERIDIAN, OR ITS MIDPOINT, WILL +C BE VISIBLE. (IF TWO POINTS ARE INVISIBLE, MAPIT DRAWS NOTHING, EVEN +C THOUGH THE LINE JOINING THEM MAY BE VISIBLE ALONG PART OF ITS LENGTH.) +C + IF (IPRJ.GE.1.AND.IPRJ.LE.6) THEN + IF (ELPF) THEN + IMF=(UCEN/URNG)**2+(VCEN/VRNG)**2.LT.1. + ELSE + IMF=UMIN*UMAX.LT.0..AND.VMIN*VMAX.LT.0. + END IF + IF (IPRJ.NE.1) IMF=IMF.AND.ABS(PHIA).GE.89.9999 + ELSE IF (IPRJ.EQ.10) THEN + IMF=.TRUE. + ELSE IF (IPRJ.EQ.11.AND.(.75*(VMAX-VMIN)).LE.VEPS) THEN + IMF=.TRUE. + ELSE + IMF=.FALSE. + END IF +C + IPF=IPRJ.EQ.10.OR.IPRJ.EQ.11.OR.(IPRJ.EQ.12.AND.ILTS.EQ.1) +C +C TRANSFER THE LATITUDE/LONGITUDE LIMITS COMPUTED BY MAPINT TO LOCAL, +C MODIFIABLE VARIABLES. +C + SLAT=SLAM + BLAT=BLAM + SLON=SLOM + BLON=BLOM +C +C FOR CERTAIN AZIMUTHAL PROJECTIONS CENTERED AT A POLE, THE LATITUDE +C LIMIT FURTHEST FROM THE POLE NEEDS ADJUSTMENT TO MAKE IT PROJECTABLE +C AND VISIBLE. OTHERWISE, WE HAVE TROUBLE WITH PORTIONS OF MERIDIANS +C DISAPPEARING. +C + IF (IPRJ.EQ.3.OR.IPRJ.EQ.4.OR.IPRJ.EQ.6) THEN + IF (PHIA.GT.+89.9999) THEN + SLAT=SLAT+SRCH + IF (IPRJ.EQ.3) SLAT=SLAT+SRCH + END IF + IF (PHIA.LT.-89.9999) THEN + BLAT=BLAT-SRCH + IF (IPRJ.EQ.3) BLAT=BLAT-SRCH + END IF + END IF +C +C RLON IS THE SMALLEST LONGITUDE FOR WHICH A MERIDIAN IS TO BE DRAWN, +C XLON THE BIGGEST. AVOID DRAWING A GIVEN MERIDIAN TWICE. +C + RLON=GRID*FLOOR(SLON/GRID) + XLON=GRID*CLING(BLON/GRID) + IF (XLON-RLON.GT.359.9999) THEN + IF (IPRJ.EQ.1) THEN + RLON=GRID*CLING((PHIO-179.9999)/GRID) + XLON=GRID*FLOOR((PHIO+179.9999)/GRID) + ELSE IF (IPRJ.GE.2.AND.IPRJ.LE.9) THEN + XLON=XLON-GRID + IF (XLON-RLON.GT.359.9999) XLON=XLON-GRID + END IF + END IF +C +C OLAT IS THE LATITUDE AT WHICH MERIDIANS WHICH ARE NOT MULTIPLES OF 90 +C ARE TO STOP. (EXCEPT ON CERTAIN FAST-PATH CYLINDRICAL PROJECTIONS, +C ONLY THE MERIDIANS AT LONGITUDES WHICH ARE MULTIPLES OF 90 RUN ALL +C THE WAY TO THE POLES. THIS AVOIDS A LOT OF CLUTTER.) +C + IF (IPRJ.EQ.10.OR.IPRJ.EQ.11) THEN + OLAT=90. + ELSE + OLAT=GRID*FLOOR(89.9999/GRID) + END IF +C +C DRAW THE MERIDIANS. +C + RLON=RLON-GRID + 101 RLON=RLON+GRID + XLAT=OLAT + IF (AMOD(RLON,90.).EQ.0.) XLAT=90. + RLAT=AMAX1(SLAT,-XLAT) + XLAT=AMIN1(BLAT,XLAT) + IF (IMF) THEN + DLAT=.5*(XLAT-RLAT) + ELSE + DLAT=(XLAT-RLAT)/CLING((XLAT-RLAT)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 102 RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + IF (RLAT.LT.XLAT-.9999) GO TO 102 + IF (RLON.LT.XLON-.9999) GO TO 101 +C +C ROUND THE LATITUDE LIMITS TO APPROPRIATE MULTIPLES OF GRID. +C + SLAT=GRID*FLOOR(SLAT/GRID) + IF (SLAT.LE.-90.) SLAT=SLAT+GRID + BLAT=GRID*CLING(BLAT/GRID) + IF (BLAT.GE.90.) BLAT=BLAT-GRID +C +C IF A FAST-PATH CYLINDRICAL EQUIDISTANT PROJECTION IS IN USE AND EITHER +C OR BOTH OF THE POLES IS WITHIN THE (RECTANGULAR) PERIMETER, ARRANGE +C FOR THE PARALLELS AT -90 AND/OR +90 TO BE DRAWN. +C + IF (IPRJ.EQ.10) THEN + CALL MAPTRN (-90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + SLAT=SLAT-GRID + CALL MAPTRN (90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + BLAT=BLAT+GRID + END IF +C +C DRAW THE PARALLELS. +C + XLAT=SLAT-GRID + 103 XLAT=XLAT+GRID + RLAT=AMAX1(-90.,AMIN1(90.,XLAT)) + RLON=FLOOR(SLON) + XLON=AMIN1(CLING(BLON),RLON+360.) + IF (IPF) THEN + DLON=.5*(XLON-RLON) + ELSE + DLON=(XLON-RLON)/CLING((XLON-RLON)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 104 RLON=RLON+DLON + CALL MAPIT (RLAT,RLON,1) + IF (RLON.LT.XLON-.9999) GO TO 104 + IF (XLAT.LT.BLAT-.9999) GO TO 103 +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-2,0,0) +C +C DRAW THE LIMB LINES. +C + CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'AR') THEN + CVAL=LDCT(ILTS) + ELSE IF (WHCH(1:2).EQ.'OU') THEN + CVAL=DDCT(NOUT+1) + ELSE IF (WHCH(1:2).EQ.'PR') THEN + CVAL=PDCT(JPRJ) + IF (JPRJ.EQ.3.AND.ABS(SALT).GT.1.) CVAL=PDCT(10) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=1 + CALL MAPCEM (' MAPGTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + CVAL=' ' + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IVAL=IDSH + ELSE IF (WHCH(1:2).EQ.'DD') THEN + IVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IVAL=IDTL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IVAL=IDOT + ELSE IF (WHCH(1:2).EQ.'EL') THEN + IVAL=0 + IF (ELPF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'ER') THEN + IVAL=IIER + ELSE IF (WHCH(1:2).EQ.'GR') THEN + IVAL=GRID + ELSE IF (WHCH(1:2).EQ.'IN') THEN + IVAL=0 + IF (INTF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'I1') THEN + IVAL=INTS(1) + ELSE IF (WHCH(1:2).EQ.'I2') THEN + IVAL=INTS(2) + ELSE IF (WHCH(1:2).EQ.'I3') THEN + IVAL=INTS(3) + ELSE IF (WHCH(1:2).EQ.'I4') THEN + IVAL=INTS(4) + ELSE IF (WHCH(1:2).EQ.'I5') THEN + IVAL=INTS(5) + ELSE IF (WHCH(1:2).EQ.'I6') THEN + IVAL=INTS(6) + ELSE IF (WHCH(1:2).EQ.'I7') THEN + IVAL=INTS(7) + ELSE IF (WHCH(1:2).EQ.'LA') THEN + IVAL=0 + IF (LBLF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + IVAL=ILCW + ELSE IF (WHCH(1:2).EQ.'MV') THEN + IVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + IVAL=0 + IF (PRMF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'PN') THEN + IVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + IVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + IVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + IVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + IVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + IVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + IVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + IVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + IVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + IVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + IVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + IVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + IVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + IVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + IVAL=BETA + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=2 + CALL MAPCEM (' MAPGTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + IVAL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + LVAL=IDTL.NE.0 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + LVAL=IDOT.NE.0 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + LVAL=ELPF + ELSE IF (WHCH(1:2).EQ.'IN') THEN + LVAL=INTF + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LVAL=LBLF + ELSE IF (WHCH(1:2).EQ.'PE') THEN + LVAL=PRMF + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=3 + CALL MAPCEM (' MAPGTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + LVAL=.FALSE. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + RVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'GD') THEN + RVAL=GRDR + ELSE IF (WHCH(1:2).EQ.'GR') THEN + RVAL=GRID + ELSE IF (WHCH(1:2).EQ.'MV') THEN + RVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PN') THEN + RVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + RVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + RVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + RVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + RVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + RVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + RVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + RVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + RVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + RVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + RVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + RVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + RVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + RVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + RVAL=BETA + ELSE IF (WHCH(1:2).EQ.'SR') THEN + RVAL=SRCH + ELSE IF (WHCH(1:2).EQ.'XL') THEN + RVAL=XLOW + ELSE IF (WHCH(1:2).EQ.'XR') THEN + RVAL=XROW + ELSE IF (WHCH(1:2).EQ.'YB') THEN + RVAL=YBOW + ELSE IF (WHCH(1:2).EQ.'YT') THEN + RVAL=YTOW + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=4 + CALL MAPCEM (' MAPGTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RVAL=0. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPINT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C SET UP ALTERNATE NAMES FOR SOME OF THE VARIABLES IN COMMON. +C + EQUIVALENCE (PHIA,FLT1),(ROTA,FLT2) +C + EQUIVALENCE (PLA1,AUMN),(PLA2,AUMX), + + (PLA3,AVMN),(PLA4,AVMX) +C +C ENSURE THAT THE BLOCK DATA ROUTINE WILL LOAD, SO THAT VARIABLES WILL +C HAVE THE PROPER DEFAULT VALUES. +C + EXTERNAL MAPBD +C +C DEFINE THE NECESSARY CONSTANTS. +C + DATA RESL / 10. / + DATA DTOR / .017453292519943 / + DATA OV90 / .011111111111111 / + DATA PI / 3.14159265358979 / + DATA RTOD / 57.2957795130823 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPINT','VERSION 1') +C +C CHECK FOR AN ERROR IN THE PROJECTION SPECIFIER. +C + IF (JPRJ.LE.0.OR.JPRJ.GE.10) GO TO 901 +C +C IPRJ EQUALS JPRJ UNTIL WE FIND OUT IF FAST-PATH PROJECTIONS ARE TO BE +C USED. PHOC IS JUST A COPY OF PHIO. +C + IPRJ=JPRJ + PHOC=PHIO +C + IF (IPRJ.EQ.1) THEN +C +C COMPUTE CONSTANTS FOR THE LAMBERT CONFORMAL CONIC. +C + SINO=SIGN(1.,.5*(FLT1+FLT2)) + CHI1=(90.-SINO*FLT1)*DTOR + IF (FLT1.EQ.FLT2) THEN + COSO=COS(CHI1) + ELSE + CHI2=(90.-SINO*FLT2)*DTOR + COSO=ALOG(SIN(CHI1)/SIN(CHI2))/ALOG(TAN(.5*CHI1)/TAN(.5*CHI2)) + END IF +C + ELSE +C +C COMPUTE CONSTANTS REQUIRED FOR ALL THE OTHER PROJECTIONS. +C + TMP1=ROTA*DTOR + TMP2=PHIA*DTOR + SINR=SIN(TMP1) + COSR=COS(TMP1) + SINO=SIN(TMP2) + COSO=COS(TMP2) +C +C COMPUTE CONSTANTS REQUIRED ONLY BY THE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ.GE.7) THEN +C +C SEE IF FAST-PATH TRANSFORMATIONS CAN BE USED. (PLAT = 0 AND ROTA = 0 +C OR 180.) +C + IF (ABS(PHIA).GE..0001.OR.(ABS(ROTA).GE..0001.AND. + + ABS(ROTA).LE.179.9999)) THEN +C +C NO. COMPUTE CONSTANTS FOR THE ORDINARY CYLINDRICAL PROJECTIONS. +C + SINT=COSO*COSR + COST=SQRT(1.-(SINT)**2) + TMP1=SINR/COST + TMP2=SINO/COST + PHIO=PHIO-ATAN2(TMP1,-COSR*TMP2)*RTOD + PHOC=PHIO + SINR=TMP1*COSO + COSR=-TMP2 + SINO=SINT + COSO=COST +C + ELSE +C +C YES. THE FAST PATHS ARE IMPLEMENTED AS THREE ADDITIONAL PROJECTIONS. +C + IPRJ=IPRJ+3 +C + IF (ABS(ROTA).LT..0001) THEN + SINO=1. + ELSE + SINO=-1. + PHIO=PHIO+180. + PHOC=PHIO + END IF +C + COSO=0. + SINR=0. + COSR=1. +C + END IF +C + END IF +C + END IF +C +C NOW, SET UMIN, UMAX, VMIN, AND VMAX TO CORRESPOND TO THE MAXIMUM +C USEFUL AREA PRODUCED BY THE PROJECTION. +C + GO TO (101,102,101,102,102,103,104,103,105,104,103,105) , IPRJ +C +C LAMBERT CONFORMAL CONIC AND ORTHOGRAPHIC. +C + 101 IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + UMIN=-1. + UMAX=1. + VMIN=-1. + VMAX=1. + ELSE + TMP1=SALT*SALT*CALF*CALF-1. + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*SBET*SBET)-1.) + UMIN=SRSS*(-SALF*CBET-TMP2)/TMP1 + UMAX=SRSS*(-SALF*CBET+TMP2)/TMP1 + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*CBET*CBET)-1.) + VMIN=SRSS*(-SALF*SBET-TMP2)/TMP1 + VMAX=SRSS*(-SALF*SBET+TMP2)/TMP1 + END IF +C + GO TO 106 +C +C STEREOGRAPHIC, LAMBERT EQUAL AREA, AND GNOMONIC. +C + 102 UMIN=-2. + UMAX=2. + VMIN=-2. + VMAX=2. + GO TO 106 +C +C AZIMUTHAL EQUIDISTANT AND MERCATOR. +C + 103 UMIN=-PI + UMAX=PI + VMIN=-PI + VMAX=PI + GO TO 106 +C +C CYLINDRICAL EQUIDISTANT. +C + 104 UMIN=-180. + UMAX=180. + VMIN=-90. + VMAX=90. + GO TO 106 +C +C MOLLWEIDE. +C + 105 UMIN=-2. + UMAX=2. + VMIN=-1. + VMAX=1. +C +C COMPUTE THE QUANTITIES USED BY MAPIT IN CHECKING FOR CROSS-OVER. +C + 106 UEPS=.75*(UMAX-UMIN) + VEPS=.75*(VMAX-VMIN) +C +C AS ALWAYS, THE CONICAL PROJECTION IS THE ODDBALL. CROSS-OVER IS NOT +C DETECTED IN U AND V, BUT IN LONGITUDE, SO THE VALUE HAS TO BE SET +C DIFFERENTLY. +C + IF (IPRJ.EQ.1) UEPS=180. +C +C NOW, JUMP TO THE APPROPRIATE LIMIT-SETTING CODE. +C + GO TO (600,200,300,400,500) , ILTS +C +C ILTS=2 POINTS (PL1,PL2) AND (PL3,PL4) ARE ON OPPOSITE CORNERS +C ------ OF THE PLOT. +C + 200 E=0. + 201 CALL MAPTRN (PLA1,PLA2+E,TMP1,TMP3) + CALL MAPTRN (PLA3,PLA4-E,TMP2,TMP4) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 201 + END IF + UMIN=AMIN1(TMP1,TMP2) + UMAX=AMAX1(TMP1,TMP2) + VMIN=AMIN1(TMP3,TMP4) + VMAX=AMAX1(TMP3,TMP4) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=3 FOUR EDGE POINTS ARE GIVEN. +C ------ +C + 300 E=0. + 301 CALL MAPTRN (PLA1,PLB1+E,TMP1,TMP5) + CALL MAPTRN (PLA2,PLB2-E,TMP2,TMP6) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 301 + END IF + CALL MAPTRN (PLA3,PLB3,TMP3,TMP7) + CALL MAPTRN (PLA4,PLB4,TMP4,TMP8) + UMIN=AMIN1(TMP1,TMP2,TMP3,TMP4) + UMAX=AMAX1(TMP1,TMP2,TMP3,TMP4) + VMIN=AMIN1(TMP5,TMP6,TMP7,TMP8) + VMAX=AMAX1(TMP5,TMP6,TMP7,TMP8) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=4 ANGULAR DISTANCES ARE GIVEN. +C ------ +C + 400 CUMI=COS(AUMN*DTOR) + SUMI=SIN(AUMN*DTOR) + CUMA=COS(AUMX*DTOR) + SUMA=SIN(AUMX*DTOR) + CVMI=COS(AVMN*DTOR) + SVMI=SIN(AVMN*DTOR) + CVMA=COS(AVMX*DTOR) + SVMA=SIN(AVMX*DTOR) +C + GO TO (904,401,402,403,404,405,406,407,408,406,407,408) , IPRJ +C +C STEREOGRAPHIC. +C + 401 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-(1.-CUMI)/SUMI + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=(1.-CUMA)/SUMA + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-(1.-CVMI)/SVMI + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=(1.-CVMA)/SVMA + END IF + GO TO 600 +C +C ORTHOGRAPHIC. +C + 402 IF (ABS(SALT).LE.1.) THEN + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GT.90.) GO TO 902 + UMIN=-SUMI + UMAX=SUMA + VMIN=-SVMI + VMAX=SVMA + ELSE + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.90.) GO TO 902 + UTMP=SRSS*SALF/CALF + VTMP=0. + UCEN=UTMP*CBET-VTMP*SBET + VCEN=VTMP*CBET+UTMP*SBET + UMIN=UCEN-SRSS*CALF*SUMI/CUMI + UMAX=UCEN+SRSS*CALF*SUMA/CUMA + VMIN=VCEN-SRSS*CALF*SVMI/CVMI + VMAX=VCEN+SRSS*CALF*SVMA/CVMA + END IF + GO TO 600 +C +C LAMBERT EQUAL AREA. +C + 403 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-2./SQRT(1.+((1.+CUMI)/SUMI)**2) + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=2./SQRT(1.+((1.+CUMA)/SUMA)**2) + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-2./SQRT(1.+((1.+CVMI)/SVMI)**2) + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=2./SQRT(1.+((1.+CVMA)/SVMA)**2) + END IF + GO TO 600 +C +C GNOMONIC. +C + 404 IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-SUMI/CUMI + UMAX=SUMA/CUMA + VMIN=-SVMI/CVMI + VMAX=SVMA/CVMA + GO TO 600 +C +C AZIMUTHAL EQUIDISTANT. +C + 405 UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-AVMN*DTOR + VMAX=AVMX*DTOR + GO TO 600 +C +C CYLINDRICAL EQUIDISTANT. +C + 406 UMIN=-AUMN + UMAX=AUMX + VMIN=-AVMN + VMAX=AVMX + GO TO 600 +C +C MERCATOR. +C + 407 IF (AMAX1(AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-ALOG((1.+SVMI)/CVMI) + VMAX=ALOG((1.+SVMA)/CVMA) + GO TO 600 +C +C MOLLWEIDE. +C + 408 UMIN=-AUMN*OV90 + UMAX=AUMX*OV90 + VMIN=-SVMI + VMAX=SVMA + GO TO 600 +C +C ILTS=5 VALUES IN THE U/V PLANE ARE GIVEN. +C ------ +C + 500 UMIN=PLA1 + UMAX=PLA2 + VMIN=PLA3 + VMAX=PLA4 +C +C COMPUTE THE WIDTH AND HEIGHT OF THE PLOT. +C + 600 DU=UMAX-UMIN + DV=VMAX-VMIN +C +C ERROR IF MAP HAS ZERO AREA. +C + IF (DU.LE.0..OR.DV.LE.0.) GO TO 903 +C +C POSITION THE MAP ON THE PLOTTER FRAME. +C + IF (DU/DV.LT.(XROW-XLOW)/(YTOW-YBOW)) THEN + ULOW=.5*(XLOW+XROW)-.5*(DU/DV)*(YTOW-YBOW) + UROW=.5*(XLOW+XROW)+.5*(DU/DV)*(YTOW-YBOW) + VBOW=YBOW + VTOW=YTOW + ELSE + ULOW=XLOW + UROW=XROW + VBOW=.5*(YBOW+YTOW)-.5*(DV/DU)*(XROW-XLOW) + VTOW=.5*(YBOW+YTOW)+.5*(DV/DU)*(XROW-XLOW) + END IF +C +C ERROR IF MAP HAS ESSENTIALLY ZERO AREA. +C + IF (AMIN1(UROW-ULOW,VTOW-VBOW)*PLTR.LT.RESL) GO TO 903 +C +C DO THE REQUIRED SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C COMPUTE THE QUANTITIES USED BY MAPIT TO SEE IF POINTS ARE FAR ENOUGH +C APART TO DRAW THE LINE BETWEEN THEM AND THE QUANTITIES USED BY MAPVP +C TO DETERMINE THE NUMBER OF DOTS TO INTERPOLATE BETWEEN TWO POINTS. +C + DSCA=(UROW-ULOW)*PLTR/DU + DPSQ=DPLT*DPLT + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA +C +C SET PARAMETERS REQUIRED IF AN ELLIPTICAL PERIMETER IS BEING USED. THE +C ELLIPSE IS MADE TO BE JUST A LITTLE BIGGER THAN AN INSCRIBED ELLIPSE +C SO AS TO AVOID ROUND-OFF PROBLEMS WHEN DRAWING THE LIMB OF CERTAIN +C PROJECTIONS. +C + UCEN=.5*(UMIN+UMAX) + VCEN=.5*(VMIN+VMAX) + URNG=.50005*(UMAX-UMIN) + VRNG=.50005*(VMAX-VMIN) +C +C NOW, COMPUTE THE LATITUDE/LONGITUDE LIMITS WHICH WILL BE REQUIRED BY +C MAPGRD AND MAPLOT, IF ANY. +C + IF (GRID.GT.0..OR.NOUT.NE.0) THEN +C +C AT FIRST, ASSUME THE WHOLE GLOBE WILL BE PROJECTED. +C + SLAM=-90. + BLAM=+90. + SLOM=PHIO-180. + BLOM=PHIO+180. +C +C JUMP IF IT'S OBVIOUS THAT REALLY IS THE CASE. +C + IF (ILTS.EQ.1.AND.(JPRJ.EQ.4.OR.JPRJ.EQ.6.OR.JPRJ.EQ.7.OR. + + JPRJ.EQ.9)) GO TO 700 +C +C OTHERWISE, THE WHOLE GLOBE IS NOT BEING PROJECTED. THE FIRST THING +C TO DO IS TO FIND A POINT (CLAT,CLON) WHOSE PROJECTION IS KNOWN TO BE +C ON THE MAP. FIRST, TRY THE POLE OF THE PROJECTION. +C + CLAT=PHIA + CLON=PHIO + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 +C +C IF THAT DIDN'T WORK, TRY A POINT BASED ON THE LIMITS SPECIFIER. +C + IF (ILTS.EQ.2) THEN + CLAT=.5*(PLA1+PLA3) + CLON=.5*(PLA2+PLA4) + ELSE IF (ILTS.EQ.3) THEN + TMP1=AMIN1(PLA1,PLA2,PLA3,PLA4) + TMP2=AMAX1(PLA1,PLA2,PLA3,PLA4) + TMP3=AMIN1(PLB1,PLB2,PLB3,PLB4) + TMP4=AMAX1(PLB1,PLB2,PLB3,PLB4) + CLAT=.5*(TMP1+TMP2) + CLON=.5*(TMP3+TMP4) + ELSE + GO TO 700 + END IF + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 + GO TO 700 +C +C ONCE WE HAVE THE LATITUDES AND LONGITUDES OF A POINT ON THE MAP, WE +C FIND THE MINIMUM AND MAXIMUM LATITUDE AND THE MINIMUM AND MAXIMUM +C LONGITUDE BY RUNNING A SEARCH POINT ABOUT ON A FINE LAT/LON GRID. +C +C FIND THE MINIMUM LATITUDE. +C + 611 RLAT=CLAT + RLON=CLON + DLON=SRCH + 612 RLAT=RLAT-SRCH + IF (RLAT.LE.-90.) GO TO 621 + 613 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 612 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + SLAM=RLAT +C +C FIND THE MAXIMUM LATITUDE. +C + 621 RLAT=CLAT + RLON=CLON + DLON=SRCH + 622 RLAT=RLAT+SRCH + IF (RLAT.GT.90.) GO TO 631 + 623 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 622 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + BLAM=RLAT +C +C FIND THE MINIMUM LONGITUDE. +C + 631 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 632 RLON=RLON-SRCH + IF (RLON.LE.CLON-360.) GO TO 651 + 633 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 632 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + SLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) +C +C FIND THE MAXIMUM LONGITUDE. +C + 641 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 642 RLON=RLON+SRCH + IF (RLON.GE.CLON+360.) GO TO 651 + 643 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 642 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + BLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) + IF (BLOM.LE.SLOM) BLOM=BLOM+360. + GO TO 700 +C + 651 SLOM=PHIO-180. + BLOM=PHIO+180. +C + END IF +C +C ZERO THE ERROR FLAG AND TURN OFF THE INITIALIZATION-REQUIRED FLAG. +C + 700 IIER=0 + INTF=.FALSE. +C +C DONE. +C + RETURN +C +C ERROR RETURNS. +C + 901 IIER=5 + CALL SETER (' MAPINT - ATTEMPT TO USE NON-EXISTENT PROJECTION', + 1 IIER,1) + RETURN +C + 902 IIER=6 + CALL SETER (' MAPINT - ANGULAR LIMITS TOO GREAT',IIER,1) + RETURN +C + 903 IIER=7 + CALL SETER (' MAPINT - MAP HAS ZERO AREA',IIER,1) + RETURN +C + 904 IIER=8 + CALL SETER (' MAPINT - MAP LIMITS INAPPROPIATE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIT (RLAT,RLON,IFST) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C + DIMENSION CPRJ(3) +C + SAVE IVSO,POLD,QOLD,UOLD,VOLD +C + DATA CPRJ / 360.,6.28318530717959,4. / +C + DATA IVSO,POLD,QOLD,UOLD,VOLD / 0,0.,0.,0.,0. / +C +C PROJECT THE POINT (RLAT,RLON) TO (U,V). +C + CALL MAPTRN (RLAT,RLON,U,V) +C +C FOR THE SAKE OF EFFICIENCY, EXECUTE ONE OF TWO PARALLEL ALGORITHMS, +C DEPENDING ON WHETHER AN ELLIPTICAL OR A RECTANGULAR PERIMETER IS IN +C USE. (THAT WAY, WE TEST ELPF ONLY ONCE.) +C + IF (ELPF) THEN +C +C ELLIPTICAL - ASSUME THE NEW POINT IS VISIBLE UNTIL WE FIND OTHERWISE. +C + IVIS=1 +C +C SEE IF THE NEW POINT IS INVISIBLE. +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.) THEN +C +C THE NEW POINT IS INVISIBLE. RESET THE VISIBILITY FLAG. +C + IVIS=0 +C +C IF THE NEW POINT IS A "FIRST POINT" OR IF THE LAST POINT WAS NOT +C VISIBLE OR IF THE NEW POINT IS INVISIBLE BECAUSE ITS PROJECTION IS +C UNDEFINED, DRAW NOTHING. THE POSSIBLE EXISTENCE OF A VISIBLE SEGMENT +C ALONG THE LINE JOINING TWO INVISIBLE POINTS IS INTENTIONALLY IGNORED, +C FOR REASONS OF EFFICIENCY. FOR THIS REASON, OBJECTS SHOULD NOT BE +C DRAWN USING LONG LINE SEGMENTS. +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C +C OTHERWISE, THE NEW POINT IS NOT A "FIRST POINT", THE LAST POINT WAS +C VISIBLE, AND THE PROJECTION OF THE NEW POINT IS DEFINED, SO WE NEED +C TO CONTINUE THE LINE. FIRST, IF THERE'S A CROSS-OVER PROBLEM, MOVE +C THE NEW POINT TO ITS ALTERNATE POSITION. THIS MAY MAKE IT VISIBLE. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.) THEN + IVIS=1 + GO TO 107 + END IF +C + END IF +C +C IF IT'S STILL INVISIBLE, INTERPOLATE TO THE EDGE OF THE FRAME, EXTEND +C THE LINE TO THAT POINT, AND QUIT. +C + CALL MAPTRE (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C +C THE NEW POINT IS VISIBLE. IF IT'S THE FIRST POINT OF A LINE, GO START +C A NEW LINE. +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C +C THE NEW POINT IS VISIBLE, BUT IT'S NOT THE FIRST POINT OF A LINE. +C CHECK FOR CROSS-OVER PROBLEMS. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 101 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, AND +C THERE ARE NO CROSS-OVER PROBLEMS. IF THE OLD POINT WAS INVISIBLE, +C JUMP TO DRAW THE VISIBLE PORTION OF THE LINE FROM THE OLD POINT TO +C THE NEW ONE. +C + IF (IVSO.EQ.0) GO TO 102 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, THERE +C ARE NO CROSS-OVER PROBLEMS, AND THE LAST POINT WAS VISIBLE. JUMP TO +C JUST CONTINUE THE LINE. +C + GO TO 107 +C +C WE HAVE THE MOST DIFFICULT CASE. THE NEW POINT IS VISIBLE, IT'S NOT +C THE FIRST POINT OF A LINE, AND THERE IS A CROSS-OVER PROBLEM. NONE, +C ONE, OR TWO SEGMENTS MAY NEED TO BE DRAWN. +C + 101 IF (JPRJ.LT.7) GO TO 106 +C +C IF THE OLD POINT WAS VISIBLE, GENERATE THE ALTERNATE PROJECTION OF THE +C NEW POINT AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING THE +C OLD POINT TO THE ALTERNATE PROJECTION POINT. +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (((UTMP-UCEN)/URNG)**2+((VTMP-VCEN)/VRNG)**2.GT.1.) THEN + CALL MAPTRE (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) +C + END IF +C +C NOW GENERATE AN ALTERNATE PROJECTION OF THE OLD POINT CLOSE TO THE NEW +C ONE AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING IT TO THE +C NEW POINT. +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (((UOLD-UCEN)/URNG)**2+((VOLD-VCEN)/VRNG)**2.LE.1.) GO TO 105 +C +C MOVE (UOLD,VOLD) BY INTERPOLATING TO THE EDGE OF THE FRAME. +C + 102 CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) +C + ELSE +C +C RECTANGULAR - REPEAT THE ABOVE CODE, CHANGING THE TESTS FOR A POINT'S +C BEING INSIDE/OUTSIDE THE PERIMETER. COMMENTING WILL BE ABBREVIATED. +C + IVIS=1 +C + IF (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX) THEN +C + IVIS=0 +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (U.GE.UMIN.AND.U.LE.UMAX.AND. + + V.GE.VMIN.AND.V.LE.VMAX) THEN + IVIS=1 + GO TO 107 + END IF + END IF +C + CALL MAPTRP (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 103 +C + IF (IVSO.EQ.0) GO TO 104 +C + GO TO 107 +C + 103 IF (JPRJ.LT.7) GO TO 106 +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (UTMP.LT.UMIN.OR.UTMP.GT.UMAX.OR. + + VTMP.LT.VMIN.OR.VTMP.GT.VMAX) THEN + CALL MAPTRP (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) + END IF +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (UOLD.GE.UMIN.AND.UOLD.LE.UMAX.AND. + + VOLD.GE.VMIN.AND.VOLD.LE.VMAX) GO TO 105 +C + 104 CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) +C + END IF +C +C DRAW THE VISIBLE PORTION OF THE LINE JOINING THE OLD POINT TO THE NEW. +C + 105 IF (IDTL.EQ.0) THEN + CALL FRSTD (UOLD,VOLD) + DATL=0. + END IF +C + CALL MAPVP (UOLD,VOLD,U,V) +C + GO TO 108 +C +C START A NEW LINE. +C + 106 IF (IDTL.EQ.0) THEN + CALL FRSTD (U,V) + DATL=0. + END IF +C + GO TO 108 +C +C CONTINUE THE LINE. +C + 107 IF (IFST.LT.2.AND.((U-UOLD)**2+(V-VOLD)**2)*DSSQ.LE.DPSQ) RETURN + CALL MAPVP (UOLD,VOLD,U,V) +C +C SAVE INFORMATION ABOUT THE CURRENT POINT FOR THE NEXT CALL AND QUIT. +C + 108 IVSO=IVIS + POLD=P + QOLD=Q + UOLD=U + VOLD=V +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIQ +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C FLUSH THE POINTS BUFFER. +C + IF (NPTB.GT.0) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF +C +C FLUSH PLOTIT'S BUFFER, TOO. +C + CALL PLOTIT (0,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLBL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLBL','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF REQUESTED, LETTER KEY MERIDIANS AND POLES. +C + IF (LBLF) THEN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LABELLING. +C + CALL MAPCHI (3,1,0) +C +C FIRST, THE NORTH POLE. +C + CALL MAPTRN (90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'NP',ILCW,0,0) +C +C THEN, THE SOUTH POLE. +C + CALL MAPTRN (-90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'SP',ILCW,0,0) +C +C THE EQUATOR. +C + RLON=PHIO-10. + DO 101 I=1,36 + RLON=RLON+10. + CALL MAPTRN (0.,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 102 + 101 CONTINUE + GO TO 103 + 102 CALL WTSTR (U,V,'EQ',ILCW,0,0) +C +C THE GREENWICH MERIDIAN. +C + 103 RLAT=85. + DO 104 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 105 + 104 CONTINUE + GO TO 106 + 105 CALL WTSTR (U,V,'GM',ILCW,0,0) +C +C INTERNATIONAL DATE LINE. +C + 106 RLAT=85. + DO 107 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,180.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 108 + 107 CONTINUE + GO TO 109 + 108 CALL WTSTR (U,V,'ID',ILCW,0,0) +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 109 CALL MAPCHI (-3,0,0) +C + END IF +C +C DRAW PERIMETER, IF REQUESTED. +C + IF (PRMF) THEN +C +C RESET THE LINE INTENSITY, DOTTING, AND DASH PATTERN FOR THE PERIMETER. +C + CALL MAPCHI (1,0,IOR(ISHIFT(32767,1),1)) +C +C THE PERIMETER IS EITHER AN ELLIPSE OR A RECTANGLE, DEPENDING ON ELPF. +C + IF (ELPF) THEN + U=.9999*URNG + V=0. + DATL=0. + CALL FRSTD (UCEN+U,VCEN) + DO 110 I=1,360 + UOLD=U + VOLD=V + U=COS1*UOLD-SIN1*VOLD + V=SIN1*UOLD+COS1*VOLD + CALL MAPVP (UCEN+UOLD,VCEN+VOLD*VRNG/URNG, + + UCEN+U ,VCEN+V *VRNG/URNG) + 110 CONTINUE + ELSE + DATL=0. + UMINX=UMIN+.9999*(UMAX-UMIN) + UMAXX=UMAX-.9999*(UMAX-UMIN) + VMINX=VMIN+.9999*(VMAX-VMIN) + VMAXX=VMAX-.9999*(VMAX-VMIN) + CALL FRSTD (UMINX,VMINX) + CALL MAPVP (UMINX,VMINX,UMAXX,VMINX) + CALL MAPVP (UMAXX,VMINX,UMAXX,VMAXX) + CALL MAPVP (UMAXX,VMAXX,UMINX,VMAXX) + CALL MAPVP (UMINX,VMAXX,UMINX,VMINX) + END IF +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-1,0,0) +C + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLOT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. +C + DATA PI / 3.14159265358979 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLOT','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE SELECTED OUTLINE TYPE IS "NONE", DO NOTHING. +C + IF (NOUT.LE.0) RETURN +C +C SET THE FLAG IWGF TO SAY WHETHER OR NOT THE WHOLE GLOBE IS SHOWN BY +C THE CURRENT PROJECTION. IF SO (IWGF=1), THERE'S NO NEED TO WASTE THE +C TIME REQUIRED TO CHECK EACH OUTLINE POINT GROUP FOR INTERSECTION WITH +C THE WINDOW. +C + IWGF=0 + IF (BLAM-SLAM.GT.179.9999.AND.BLOM-SLOM.GT.359.9999) IWGF=1 +C +C IGIS KEEPS TRACK OF CHANGES IN THE GROUP IDENTIFIER, SO THAT THE +C INTENSITY CAN BE CHANGED WHEN NECESSARY. +C + IGIS=0 +C +C POSITION TO THE USER-SELECTED PORTION OF THE OUTLINE DATASET. +C + CALL MAPIO (1) + NSEG=0 +C +C READ THE NEXT RECORD (GROUP OF POINTS). +C + 101 CALL MAPIO (2) + NSEG=NSEG+1 +C +C CHECK FOR THE END OF THE DESIRED DATA. +C + IF (NPTS.EQ.0) GO TO 103 +C +C IF LESS THAN THE WHOLE GLOBE IS SHOWN BY THE PROJECTION, DO A QUICK +C CHECK FOR INTERSECTION OF THE BOX SURROUNDING THE POINT GROUP WITH +C THE AREA SHOWN. +C + IF (IWGF.EQ.0) THEN + IF (SLAG.GT.BLAM.OR.BLAG.LT.SLAM) GO TO 101 + IF ((SLOG .GT.BLOM.OR.BLOG .LT.SLOM).AND. + + (SLOG-360..GT.BLOM.OR.BLOG-360..LT.SLOM).AND. + + (SLOG+360..GT.BLOM.OR.BLOG+360..LT.SLOM)) GO TO 101 + END IF +C +C SEE IF THE USER WANTS TO OMIT THIS POINT GROUP. +C + CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + IF (NPTS.LE.1) GO TO 101 +C +C IF WE'VE SWITCHED TO A NEW GROUP, SET THE INTENSITY, DOTTING, AND +C DASH PATTERN FOR THE GROUP. +C + IF (IGID.NE.IGIS) THEN + IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) + CALL MAPCHI (4+IGID,IDOT,IOR(ISHIFT(32767,1),1)) + IGIS=IGID + END IF +C +C PLOT THE GROUP. +C + CALL MAPIT (PNTS(1),PNTS(2),0) +C + DO 102 K=2,NPTS-1 + CALL MAPIT (PNTS(2*K-1),PNTS(2*K),1) + 102 CONTINUE +C + CALL MAPIT (PNTS(2*NPTS-1),PNTS(2*NPTS),2) +C +C GO GET ANOTHER GROUP. +C + GO TO 101 +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN, IF NECESSARY. +C + 103 IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) +C +C IF THE LIMB LINES HAVE NOT ALREADY BEEN DRAWN, DO IT NOW. +C + IF (GRID.LE.0.) CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPPOS (ARG1,ARG2,ARG3,ARG4) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPPOS','VERSION 1') +C +C CHECK THE ARGUMENTS FOR ERRORS. +C + IF (ARG1.LT.0..OR.ARG1.GE.ARG2.OR.ARG2.GT.1.) GO TO 901 + IF (ARG3.LT.0..OR.ARG3.GE.ARG4.OR.ARG4.GT.1.) GO TO 901 +C +C TRANSFER IN THE VALUES. +C + XLOW=ARG1 + XROW=ARG2 + YBOW=ARG3 + YTOW=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=19 + CALL SETER (' MAPPOS - ARGUMENTS ARE INCORRECT',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPROJ (ARG1,ARG2,ARG3,ARG4) +C + CHARACTER*(*) ARG1 +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPROJ','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE PROJECTION. +C + I=IDICTL(ARG1,PDCT,10) + IF (I.EQ.0) GO TO 901 +C + JPRJ=I +C + IF (JPRJ.EQ.3) THEN + CALL MAPSTR ('SA',0.) + ELSE IF (JPRJ.EQ.10) THEN + JPRJ=3 + IF (ABS(SALT).LE.1.) CALL MAPSTR ('SA',6.631) + END IF +C + PHIA=ARG2 + PHIO=ARG3 + ROTA=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=9 + CALL MAPCEM (' MAPROJ - UNKNOWN PROJECTION NAME ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRS +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRS','VERSION 1') +C +C RESTORE THE SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRST (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRST','VERSION 1') +C +C READ A RECORD OF SAVED PARAMETERS. +C + READ (IFNO,ERR=901,END=902) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C RE-INITIALIZE EZMAP. +C + CALL MAPINT +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=20 + CALL SETER ('MAPRST - ERROR ON READ',IIER,1) + RETURN +C + 902 IIER=21 + CALL SETER ('MAPRST - EOF ON READ',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSAV (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSAV','VERSION 1') +C +C WRITE A RECORD CONTAINING ALL THE USER-SETTABLE PARAMETERS. +C + WRITE (IFNO,ERR=901) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=22 + CALL SETER ('MAPSAV - ERROR ON WRITE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSET (ARG1,ARG2,ARG3,ARG4,ARG5) +C + CHARACTER*(*) ARG1 + DIMENSION ARG2(2),ARG3(2),ARG4(2),ARG5(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSET','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE MAP LIMITS. +C + I=IDICTL(ARG1,LDCT,5) + IF (I.EQ.0) GO TO 901 + ILTS=I +C + PLA1=ARG2(1) + PLA2=ARG3(1) + PLA3=ARG4(1) + PLA4=ARG5(1) +C + IF (I.EQ.3) THEN + PLB1=ARG2(2) + PLB2=ARG3(2) + PLB3=ARG4(2) + PLB4=ARG5(2) + END IF +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=10 + CALL MAPCEM (' MAPSET - UNKNOWN MAP AREA SPECIFIER ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'OU') THEN + I=IDICTL(CVAL,DDCT,5) + IF (I.EQ.0) GO TO 901 + NOUT=I-1 + ELSE + GO TO 902 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=11 + CALL MAPCEM (' MAPSTC - UNKNOWN OUTLINE NAME ',CVAL,IIER,1) + RETURN +C + 902 IIER=12 + CALL MAPCEM (' MAPSTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IDSH=IVAL + ELSE IF (WHCH(1:2).EQ.'DD') THEN + DDTS=IVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IDTL=IVAL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=IVAL + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=IVAL + ELSE IF (WHCH(1:2).EQ.'I1') THEN + INTS(1)=IVAL + ELSE IF (WHCH(1:2).EQ.'I2') THEN + INTS(2)=IVAL + ELSE IF (WHCH(1:2).EQ.'I3') THEN + INTS(3)=IVAL + ELSE IF (WHCH(1:2).EQ.'I4') THEN + INTS(4)=IVAL + ELSE IF (WHCH(1:2).EQ.'I5') THEN + INTS(5)=IVAL + ELSE IF (WHCH(1:2).EQ.'I6') THEN + INTS(6)=IVAL + ELSE IF (WHCH(1:2).EQ.'I7') THEN + INTS(7)=IVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + ILCW=IVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=IVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=IVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=IVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=IVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=IVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=13 + CALL MAPCEM (' MAPSTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + IDTL=0 + IF (LVAL) IDTL=1 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=0 + IF (LVAL) IDOT=1 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=LVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=LVAL + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=LVAL + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=14 + CALL MAPCEM (' MAPSTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + DDTS=RVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'GD') THEN + GRDR=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=RVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=RVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=RVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=RVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=RVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=RVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE IF (WHCH(1:2).EQ.'SR') THEN + SRCH=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=15 + CALL MAPCEM (' MAPSTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRN (RLAT,RLON,U,V) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. DTOR IS PI OVER 180, DTRH IS HALF OF DTOR +C OR PI OVER 360, AND TOPI IS 2 OVER PI. +C + DATA DTOR / .017453292519943 / + DATA DTRH / .008726646259971 / + DATA RTOD / 57.2957795130823 / + DATA TOPI / .636619772367581 / +C +C SET UP U AND V FOR THE FAST PATHS. U IS A LONGITUDE, IN DEGREES, +C BETWEEN -180. AND +180., INCLUSIVE, AND V IS A LATITUDE, IN DEGREES. +C + TMP1=RLON-PHOC + U=TMP1-SIGN(180.,TMP1+180.)+SIGN(180.,180.-TMP1) + V=RLAT +C +C TAKE FAST PATHS FOR SIMPLE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ-10) 101,116,112 +C +C NO FAST PATH. SORT OUT THE LAMBERT CONFORMAL CONIC FROM THE REST. +C + 101 IF (IPRJ-1) 901,102,103 +C +C LAMBERT CONFORMAL CONIC. +C + 102 P=U + CHI=90.-SINO*RLAT + IF (CHI.GE.179.9999) GO TO 118 + R=TAN(DTRH*CHI)**COSO + U=U*COSO*DTOR + V=-R*SINO*COS(U) + U=R*SIN(U) + GO TO 117 +C +C NOT LAMBERT CONFORMAL CONIC. CALCULATE CONSTANTS COMMON TO MOST OF +C THE OTHER PROJECTIONS. +C + 103 TMP1=U*DTOR + TMP2=V*DTOR + SINPH=SIN(TMP1) + SINLA=SIN(TMP2) + COSPH=COS(TMP1) + COSLA=COS(TMP2) + TCOS=COSLA*COSPH + COSA=AMAX1(-1.,AMIN1(+1.,SINLA*SINO+TCOS*COSO)) + SINA=SQRT(1.-COSA*COSA) + IF (SINA.LT..0001) THEN + SINA=0. + IF (IPRJ.GE.7.OR.COSA.LT.0.) GO TO 118 + U=0. + V=0. + GO TO 116 + END IF + SINB=COSLA*SINPH/SINA + COSB=(SINLA*COSO-TCOS*SINO)/SINA +C +C JUMP TO CODE APPROPRIATE FOR THE CHOSEN PROJECTION. +C + GO TO (104,105,106,107,108,109,110,111) , IPRJ-1 +C +C STEREOGRAPHIC. +C + 104 IF (ABS(SINA).LT..0001) THEN + R=SINA/2. + ELSE + R=(1.-COSA)/SINA + END IF + GO TO 115 +C +C ORTHOGRAPHIC OR SATELLITE-VIEW, DEPENDING ON THE VALUE OF SALT. +C + 105 IF (ABS(SALT).LE.1.) THEN + IF (COSA.GT.0.) THEN + R=SINA + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SINA + END IF + GO TO 115 + ELSE + IF (COSA.GT.1./ABS(SALT)) THEN + R=SRSS*SINA/(ABS(SALT)-COSA) + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SRSS*SINA/(ABS(SALT)-COSA) + END IF + IF (ALFA.EQ.0.) GO TO 115 + UTM1=R*(SINB*COSR+COSB*SINR) + VTM1=R*(COSB*COSR-SINB*SINR) + UTM2=UTM1*CBET+VTM1*SBET + VTM2=VTM1*CBET-UTM1*SBET + UTM3=SRSS*UTM2/(UTM2*SALF+SRSS*CALF) + VTM3=SRSS*VTM2*CALF/(UTM2*SALF+SRSS*CALF) + U=UTM3*CBET-VTM3*SBET + V=VTM3*CBET+UTM3*SBET + GO TO 116 + END IF +C +C LAMBERT EQUAL AREA. +C + 106 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=(1.+COSA)/SINA + R=2./SQRT(1.+R*R) + GO TO 115 +C +C GNOMONIC. +C + 107 IF (COSA.LE..0001) GO TO 118 + R=SINA/COSA + GO TO 115 +C +C AZIMUTHAL EQUIDISTANT. +C + 108 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=ACOS(COSA) + GO TO 115 +C +C CYLINDRICAL EQUIDISTANT, ARBITRARY POLE AND ORIENTATION. +C + 109 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*RTOD + V=90.-ACOS(COSA)*RTOD + GO TO 116 +C +C MERCATOR, ARBITRARY POLE AND ORIENTATION. +C + 110 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR) + V=ALOG((1.+COSA)/SINA) + GO TO 116 +C +C MOLLWEIDE, ARBITRARY POLE AND ORIENTATION. +C + 111 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*TOPI + P=U + V=COSA + U=U*SINA + GO TO 117 +C +C FAST-PATH CYLINDRICAL PROJECTIONS (WITH PLAT=ROTA=0). +C + 112 IF (IPRJ-12) 113,114,901 +C +C FAST-PATH MERCATOR. +C + 113 IF (ABS(RLAT).GT.89.9999) GO TO 118 + U=U*DTOR + V=ALOG(TAN((RLAT+90.)*DTRH)) + GO TO 116 +C +C FAST-PATH MOLLWEIDE. +C + 114 U=U/90. + V=SIN(RLAT*DTOR) + P=U + U=U*SQRT(1.-V*V) + GO TO 117 +C +C COMMON TERMINAL CODE FOR CERTAIN PROJECTIONS. +C + 115 U=R*(SINB*COSR+COSB*SINR) + V=R*(COSB*COSR-SINB*SINR) +C + 116 P=U +C + 117 Q=V +C +C NORMAL EXIT. +C + RETURN +C +C PROJECTION OF POINT IS INVISIBLE OR UNDEFINED. +C + 118 U=1.E12 + P=U + RETURN +C +C ERROR EXIT. +C + 901 IF (IIER.NE.0) GO TO 118 + IIER=16 + CALL SETER (' MAPTRN - ATTEMPT TO USE NON-EXISTENT PROJECTION', + + IIER,1) + GO TO 118 +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPUSR (IPRT) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVEC (XLAT,XLON) + CALL MAPIT (XLAT,XLON,1) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPCON (RLAT,RLON,UVAL,VVAL) + CALL MAPTRN (RLAT,RLON,UVAL,VVAL) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2,PLM3,PLM4,JLTS, + + JGRD,IOUT,IDOT,IERR) +C + DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C + DIMENSION LPRJ(10),LLTS(5) +C + DATA LPRJ / 2,3,1,4,5,6,10,7,8,9 / + DATA LLTS / 1,2,5,4,3 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','SUPMAP','VERSION 1') +C +C SET EZMAP'S GRID-SPACING PARAMETER. +C + CALL MAPSTI ('GR',MOD(IABS(JGRD),1000)) +C +C SET EZMAP'S OUTLINE-SELECTION PARAMETER. +C + IF (IABS(IOUT).EQ.0.OR.IABS(IOUT).EQ.1) THEN + I=1+2*IABS(IOUT)+(1+ISIGN(1,JPRJ))/2 + ELSE + I=MAX0(1,MIN0(5,IOUT)) + END IF +C + CALL MAPSTC ('OU',DDCT(I)) +C +C SET EZMAP'S PERIMETER-DRAWING FLAG. +C + CALL MAPSTL ('PE',JGRD.GE.0) +C +C SET EZMAP'S GRID-LINE-LABELLING FLAG. +C + CALL MAPSTL ('LA',MOD(IABS(JGRD),1000).NE.0) +C +C SET EZMAP'S DOTTED-OUTLINE FLAG. +C + CALL MAPSTI ('DO',MAX0(0,MIN0(1,IDOT))) +C +C SET EZMAP'S PROJECTION-SELECTION PARAMETERS. +C + I=MAX0(1,MIN0(10,IABS(JPRJ))) + CALL MAPROJ (PDCT(LPRJ(I)),PLAT,PLON,ROTA) +C +C SET EZMAP'S RECTANGULAR-LIMITS-SELECTION PARAMETERS. +C + I=LLTS(MAX0(1,MIN0(5,IABS(JLTS)))) + CALL MAPSET (LDCT(I),PLM1,PLM2,PLM3,PLM4) +C +C DRAW THE MAP. +C + CALL MAPDRW +C +C RETURN THE ERROR FLAG TO THE USER. +C + IERR=IIER +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E C O D E - I N T E R N A L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPCEM (IEM1,IEM2,IIER,IFLG) +C + CHARACTER*(*) IEM1,IEM2 +C +C MAPCEM IS CALLED TO DO A CALL TO SETER WHEN THE ERROR MESSAGE TO BE +C PRINTED IS IN TWO PARTS WHICH NEED TO BE CONCATENATED. FORTRAN-77 +C RULES MAKE IT NECESSARY TO CONCATENATE THE TWO PARTS OF THE MESSAGE +C INTO A LOCAL CHARACTER VARIABLE. +C + CHARACTER*100 IEMC +C + IEMC=IEM1//IEM2 + CALL SETER (IEMC,IIER,IFLG) +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPCHI (IPRT,IDTG,IDPT) +C +C MAPCHI IS CALLED BY VARIOUS EZMAP ROUTINES TO RESET THE INTENSITY, +C DOTTING, AND DASH PATTERN BEFORE AND AFTER DRAWING PARTS OF A MAP. +C +C THE ARGUMENT IPRT, IF POSITIVE, SAYS WHICH PART OF THE MAP IS ABOUT +C TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART OF MAP. +C ---- ------------ +C 1 PERIMETER. +C 2 GRID. +C 3 LABELLING. +C 4 LIMB LINES. +C 5 OUTLINE POINT GROUP, CONTINENTAL. +C 6 OUTLINE POINT GROUP, U.S. +C 7 OUTLINE POINT GROUP, COUNTRY. +C +C A CALL WITH IPRT EQUAL TO THE NEGATIVE OF ONE OF THESE VALUES ASKS +C THAT THE INTENSITY SAVED BY THE LAST CALL, WITH IPRT POSITIVE, BE +C RESTORED. +C +C WHEN IPRT IS POSITIVE, IDTG IS ZERO IF SOLID LINES ARE TO BE USED, 1 +C IF DOTTED LINES ARE TO BE USED. IF IPRT IS NEGATIVE, IDTG IS IGNORED. +C +C WHEN IPRT IS POSITIVE AND IDTG IS ZERO, IDPT IS THE DASH PATTERN TO BE +C USED. IF IPRT IS NEGATIVE OR IDTG IS NON-ZERO, IDPT IS IGNORED. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPNTS/ INTS(7) +C +C DECLARE ONE OF THE DASH-PACKAGE COMMON BLOCKS, TOO. +C + COMMON /SMFLAG/ ISMO +C +C THE VARIABLES INTO, IDTS, AND ISMS NEED TO BE SAVED BETWEEN CALLS. +C + SAVE INTO,IDTS,ISMS +C +C FLUSH ALL BUFFERS BEFORE CHANGING ANYTHING. +C + CALL MAPIQ +C +C SET/RESET INTENSITY, DOTTING, AND DASH PATTERN. THE USER HAS THE +C LAST WORD. +C + IF (IPRT.GT.0) THEN + ISMS=ISMO + ISMO=1 + IDTS=IDTL + IDTL=IDTG + IF (IDTL.EQ.0) CALL DASHDB (IDPT) +C +C THE FOLLOWING LINES HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) + CALL MAPUSR (IPRT) + ELSE + CALL MAPUSR (IPRT) +C +C THE FOLLOWING LINE HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL SETUSV ('IN',INTO) + IF (IDTL.EQ.0) CALL DASHDB (IOR(ISHIFT(32767,1),1)) + IDTL=IDTS + ISMO=ISMS + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + INTEGER FUNCTION IDICTL (ISTR,IDCT,NDCT) +C + CHARACTER*(*) ISTR + CHARACTER*2 IDCT(NDCT) +C +C THE VALUE OF THIS FUNCTION IS THE INDEX IN THE NDCT-ELEMENT DICTIONARY +C IDCT OF THE STRING ISTR. ONLY THE FIRST TWO CHARACTERS OF ISTR AND +C IDCT(I) ARE COMPARED. IF ISTR IS NOT FOUND IN THE DICTIONARY, THE +C FUNCTION VALUE IS ZERO. +C + DO 101 I=1,NDCT + IF (ISTR(1:2).EQ.IDCT(I)) THEN + IDICTL=I + RETURN + END IF + 101 CONTINUE +C +C NOT FOUND. RETURN A ZERO. +C + IDICTL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIO (IACT) +C +C THIS ROUTINE PERFORMS ALL POSITIONING AND INPUT OF THE OUTLINE DATASET +C FOR MAPLOT. THE ARGUMENT IACT SPECIFIES WHAT IS TO BE DONE: 1 ASKS +C THAT THE DATASET BE POSITIONED AT THE BEGINNING OF THE DESIRED "FILE", +C 2 THAT THE NEXT RECORD BE READ. +C +C FIVE LINES OF THE CODE BELOW HAVE BEEN INSERTED TO MAKE THIS ROUTINE +C RUN EFFICIENTLY ON NCAR'S CRAYS; THESE LINES SHOULD BE REMOVED BY +C ANYONE IMPLEMENTING EZMAP ON ANOTHER SYSTEM (EXCEPT PERHAPS ANOTHER +C CRAY). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCMB/ IERR +C + IF (IACT.EQ.1) THEN +C +C POSITION TO THE DESIRED "FILE" WITHIN THE DATASET. +C +C THE FOLLOWING FIVE LINES ARE FOR NCAR'S CRAYS. +C +C ITPN=6LEZMPDT +C IF (IFDNT(ITPN).EQ.0) THEN +C CALL SDACCESS (IERR,ITPN) +C IF (IERR.NE.0) GO TO 901 +C END IF +C + REWIND ITPN +C + IF (NOUT.NE.1) THEN + ITMP=NOUT + 101 READ (ITPN,END=902) NPTS,IGID,BLAG,SLAG,BLOG,SLOG, + + (PNTS(I),I=1,NPTS) + IF (NPTS.GT.1) GO TO 101 + ITMP=ITMP-1 + IF (ITMP.GT.1) GO TO 101 + END IF +C + ELSE +C +C READ THE NEXT RECORD. +C + READ (ITPN) NPTS,IGID,BLAG,SLAG,BLOG,SLOG,(PNTS(I),I=1,NPTS) + NPTS=NPTS/2 +C + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=17 + CALL SETER (' MAPIO - OUTLINE DATASET IS UNREADABLE',IIER,1) + NOUT=0 + RETURN +C + 902 IIER=18 + CALL SETER (' MAPIO - EOF ENCOUNTERED IN OUTLINE DATASET',IIER,1) + NOUT=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLMB +C +C THE ROUTINE MAPLMB IS CALLED BY MAPGRD AND/OR MAPLOT TO DRAW THE LIMB +C LINES. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / + DATA PI / 3.14159265358979 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LIMB LINES. +C + CALL MAPCHI (4,0,IOR(ISHIFT(32767,1),1)) +C +C DRAW LIMB LINES, THE NATURE OF WHICH DEPENDS ON THE PROJECTION. +C + GO TO (101,110,104,105,110,106,110,110,107,110,110,107) , IPRJ +C +C LAMBERT CONFORMAL CONIC WITH TWO STANDARD PARALLELS. +C + 101 DLAT=GRDR + RLON=PHIO+179.9999 + K=CLING(180./DLAT) + DO 103 I=1,2 + RLAT=-90. + CALL MAPIT (RLAT,RLON,0) + DO 102 J=1,K-1 + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + 102 CONTINUE + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,2) + RLON=PHIO-179.9999 + 103 CONTINUE + GO TO 110 +C +C ORTHOGRAPHIC (OR SATELLITE-VIEW). +C + 104 IF (ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + URAD=1. + RVTU=1. + ELSE + DNOM=SALT*SALT*CALF*CALF-1. + URAD=SSMO*CALF/DNOM + RVTU=SQRT(DNOM)/SRSS + END IF + GO TO 108 +C +C LAMBERT EQUAL AREA. +C + 105 URAD=2. + RVTU=1. + GO TO 108 +C +C AZIMUTHAL EQUIDISTANT. +C + 106 URAD=PI + RVTU=1. + GO TO 108 +C +C MOLLWEIDE. +C + 107 URAD=2. + RVTU=0.5 +C + 108 UCIR=URAD + VCIR=0. + IVIS=-1 + DO 109 I=1,361 + IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + U=UCIR + V=RVTU*VCIR + ELSE + UTMP=UCIR-SRSS*SALF/DNOM + VTMP=RVTU*VCIR + U=UTMP*CBET-VTMP*SBET + V=VTMP*CBET+UTMP*SBET + END IF + IF (.NOT.ELPF.AND. + + (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRP (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE IF (ELPF.AND. + + (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRE (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE + IF (IVIS.LT.0) THEN + DATL=0. + CALL FRSTD (U,V) + IVIS=1 + ELSE + IF (IVIS.EQ.0) THEN + IF (.NOT.ELPF) CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) + IF ( ELPF) CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) + DATL=0. + CALL FRSTD (UOLD,VOLD) + IVIS=1 + END IF + CALL MAPVP (UOLD,VOLD,U,V) + END IF + END IF + UOLD=U + VOLD=V + UTMP=UCIR + VTMP=VCIR + UCIR=UTMP*COS1-VTMP*SIN1 + VCIR=UTMP*SIN1+VTMP*COS1 + 109 CONTINUE +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 110 CALL MAPCHI (-4,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRE (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF AN ELLIPTICAL FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRE CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C WHAT'S INVOLVED IS JUST A LOT OF ALGEBRA. +C + IF (ABS(UOUT-UINS).GT.ABS(VOUT-VINS)) THEN + P=(VOUT-VINS)/(UOUT-UINS) + Q=(UOUT*VINS-UINS*VOUT)/(UOUT-UINS) + A=VRNG*VRNG+P*P*URNG*URNG + B=2.*(P*Q*URNG*URNG-UCEN*VRNG*VRNG-P*URNG*URNG*VCEN) + C=UCEN*UCEN*VRNG*VRNG+Q*Q*URNG*URNG-2.*Q*URNG*URNG*VCEN+ + + URNG*URNG*VCEN*VCEN-URNG*URNG*VRNG*VRNG + UTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + UTM2=.5*(-B-UTM1)/A + IF ((UTM2-UOUT)*(UTM2-UINS).GT.0.) UTM2=.5*(-B+UTM1)/A + UINT=UTM2 + VINT=P*UINT+Q + ELSE + P=(UOUT-UINS)/(VOUT-VINS) + Q=(UINS*VOUT-UOUT*VINS)/(VOUT-VINS) + A=URNG*URNG+P*P*VRNG*VRNG + B=2.*(P*Q*VRNG*VRNG-URNG*URNG*VCEN-P*UCEN*VRNG*VRNG) + C=URNG*URNG*VCEN*VCEN+Q*Q*VRNG*VRNG-2.*Q*UCEN*VRNG*VRNG+ + + UCEN*UCEN*VRNG*VRNG-URNG*URNG*VRNG*VRNG + VTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + VTM2=.5*(-B-VTM1)/A + IF ((VTM2-VOUT)*(VTM2-VINS).GT.0.) VTM2=.5*(-B+VTM1)/A + VINT=VTM2 + UINT=P*VINT+Q + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRP (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF A RECTANGULAR FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRP CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C GIVEN ONE COORDINATE OF A POINT ON THE LINE JOINING (UINS,VINS) AND +C (UOUT,VOUT), THE OTHER CAN BE OBTAINED BY USING ONE OF THE FOLLOWING +C ARITHMETIC STATEMENT FUNCTIONS: +C + UFUN(V)=UINS+(V-VINS)*DU/DV + VFUN(U)=VINS+(U-UINS)*DV/DU +C +C I I +C 5 I 4 I 6 +C I I +C ----------------- +C FIRST, DETERMINE IN WHICH I I +C OF THE AREAS SHOWN THE 2 I 1 I 3 +C POINT (UOUT,VOUT) LIES. I I +C ----------------- +C I I +C 8 I 7 I 9 +C I I +C + IREA=1 + IF (UOUT-UMIN) 101,104,102 + 101 IREA=IREA+1 + GO TO 104 + 102 IF (UOUT-UMAX) 104,104,103 + 103 IREA=IREA+2 + 104 IF (VOUT-VMIN) 105,108,106 + 105 IREA=IREA+6 + GO TO 108 + 106 IF (VOUT-VMAX) 108,108,107 + 107 IREA=IREA+3 +C +C NEXT, COMPUTE THE QUANTITIES REQUIRED BY UFUN AND VFUN AND JUMP TO THE +C APPROPRIATE PIECE OF CODE FOR THE GIVEN AREA. +C + 108 DU=UOUT-UINS + DV=VOUT-VINS +C + GO TO (119,113,114,115,109,110,116,111,112) , IREA +C + 109 IF (UFUN(VMAX)-UMIN) 113,115,115 + 110 IF (UFUN(VMAX)-UMAX) 115,115,114 + 111 IF (UFUN(VMIN)-UMIN) 113,116,116 + 112 IF (UFUN(VMIN)-UMAX) 116,116,114 +C + 113 UINT=UMIN + GO TO 117 + 114 UINT=UMAX + GO TO 117 + 115 VINT=VMAX + GO TO 118 + 116 VINT=VMIN + GO TO 118 +C + 117 VINT=VFUN(UINT) + RETURN +C + 118 UINT=UFUN(VINT) + RETURN +C + 119 UINT=UOUT + VINT=VOUT + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVP (UOLD,VOLD,U,V) +C +C PLOT THE LINE SEGMENT FROM (UOLD,VOLD) TO (U,V), USING EITHER A SOLID +C LINE OR A DOTTED LINE (DEPENDING ON THE VALUE OF THE COMMON VARIABLE +C IDTL). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C SELECT VECTOR OR DOT MODE. +C + IF (IDTL.EQ.0) THEN +C +C USE A SINGLE VECTOR. +C + CALL VECTD (U,V) +C + ELSE +C +C USE DOTS. DELU AND DELV ARE THE U AND V COMPONENTS OF THE VECTOR +C JOINING (UOLD,VOLD) TO (U,V) AND VLEN IS THE LENGTH OF THE VECTOR. +C + DELU=U-UOLD + DELV=V-VOLD +C + VLEN=SQRT(DELU*DELU+DELV*DELV) +C +C NOW DISTRIBUTE DOTS ALONG THE VECTOR. THE FIRST ONE IS SPACED JUST +C FAR ENOUGH ALONG IT (DATL UNITS) TO BE DBTD UNITS AWAY FROM THE LAST +C DOT ON THE PREVIOUS VECTOR AND THE REST ARE DBTD UNITS APART. +C + 101 IF (DATL.LT.VLEN) THEN + IF (NPTB.GE.50) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF + NPTB=NPTB+1 + XPTB(NPTB)=UOLD+(DATL/VLEN)*DELU + YPTB(NPTB)=VOLD+(DATL/VLEN)*DELV + DATL=DATL+DBTD + GO TO 101 + END IF +C +C SET DATL FOR THE NEXT CALL. +C + DATL=DATL-VLEN +C + END IF +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E B L O C K D A T A " R O U T I N E " - D E F A U L T S +C*********************************************************************** +C + BLOCK DATA MAPBD +C +C THE COMMON BLOCK MAPCM1 CONTAINS TRANSFORMATION CONSTANTS. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC +C +C THE COMMON BLOCK MAPCM2 CONTAINS AREA-SPECIFICATION VARIABLES. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C THE COMMON BLOCK MAPCM3 CONTAINS PARAMETERS HAVING TO DO WITH READING +C THE DATA FOR OUTLINES. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) +C +C THE COMMON BLOCK MAPCM4 CONTAINS MOST OF THE INPUT PARAMETERS. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW +C + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE COMMON BLOCK MAPCM5 CONTAINS VARIOUS LISTS ("DICTIONARIES") OF +C TWO-CHARACTER CODES REQUIRED BY EZMAP FOR PARAMETER-SETTING. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) +C + CHARACTER*2 DDCT,LDCT,PDCT +C +C THE COMMON BLOCK MAPCM7 CONTAINS PARAMETERS DESCRIBING THE PORTION OF +C THE PLOTTER FRAME BEING USED. +C + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE COMMON BLOCK MAPCM8 CONTAINS PARAMETERS SET BY MAPTRN AND USED BY +C MAPIT IN HANDLING "CROSS-OVER" PROBLEMS. +C + COMMON /MAPCM8/ P,Q,R +C +C THE COMMON BLOCK MAPCMA CONTAINS VALUES WHICH ARE USED TO POSITION +C DOTS ALONG DOTTED OUTLINES AND TO AVOID DRAWING VECTORS WHICH ARE +C TOO SHORT. +C + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C +C THE COMMON BLOCK MAPCMB CONTAINS THE EZMAP ERROR FLAG. +C + COMMON /MAPCMB/ IIER +C +C THE COMMON BLOCK MAPCMP CONTAINS THE BUFFERS IN WHICH THE X AND Y +C COORDINATES OF POINTS ARE COLLECTED FOR AN EVENTUAL CALL TO POINTS. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C THE COMMON BLOCK MAPNTS CONTAINS QUANTITIES SPECIFYING THE INTENSITIES +C TO BE USED FOR VARIOUS PORTIONS OF THE PLOT. +C + COMMON /MAPNTS/ INTS(7) +C +C THE COMMON BLOCK MAPSAT CONTAINS PARAMETERS FOR THE SATELLITE-VIEW +C PROJECTION. +C + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C +C BELOW ARE DESCRIPTIONS OF THE VARIABLES IN EACH OF THE COMMON BLOCKS, +C TOGETHER WITH DATA STATEMENTS GIVING DEFAULT VALUES TO THOSE VARIABLES +C WHICH NEED DEFAULT VARIABLES. +C +C +C VARIABLES IN MAPCM1: +C +C IPRJ IS AN INTEGER BETWEEN 1 AND 12, SPECIFYING WHAT PROJECTION IS +C CURRENTLY IN USE. THE VALUES 10, 11, AND 12 SPECIFY FAST-PATH +C VERSIONS OF THE VALUES 7, 8, AND 9, RESPECTIVELY. SINO, COSO, SINR, +C COSR, AND PHOC ARE PROJECTION VARIABLES COMPUTED BY MAPINT FOR USE BY +C MAPTRN. PHOC, AS IT HAPPENS, IS JUST A COPY OF PHIO, FROM THE COMMON +C BLOCK MAPCM4. +C +C +C VARIABLES IN MAPCM2: +C +C UMIN, UMAX, VMIN, AND VMAX SPECIFY THE LIMITS OF THE RECTANGLE TO BE +C DRAWN, IN PROJECTION SPACE. UEPS AND VEPS ARE SET BY MAPINT FOR USE +C IN MAPIT IN TESTING FOR CROSS-OVER PROBLEMS. UCEN, VCEN, URNG, AND +C VRNG ARE COMPUTED BY MAPINT FOR USE WHEN THE MAP PERIMETER IS MADE +C ELLIPTICAL (BY SETTING THE FLAG ELPF). BLAM, SLAM, BLOM, AND SLOM +C ARE RESPECTIVELY THE BIGGEST LATITUDE, THE SMALLEST LATITUDE, THE +C BIGGEST LONGITUDE, AND THE SMALLEST LONGITUDE ON THE MAP. THEY ARE +C USED IN MAPGRD AND IN MAPLOT TO MAKE THE DRAWING OF GRIDS AND OUTLINES +C MORE EFFICIENT. UMIN AND UMAX ARE GIVEN DEFAULT VALUES TO PREVENT +C IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS SET PRIOR TO THE +C FIRST CALL TO MAPINT. +C + DATA UMIN,UMAX / 0.,1. / +C +C +C VARIABLES IN MAPCM3: +C +C ITPN IS THE UNIT NUMBER OF THE "TAPE" FROM WHICH OUTLINE DATA IS TO +C BE READ. NOUT IS THE NUMBER OF THE OUTLINE TO BE USED; THE VALUES 0 +C THROUGH 5 IMPLY 'NO', 'CO', 'US', 'PS', AND 'PO', RESPECTIVELY; THUS, +C IF NOUT IS ZERO, NO OUTLINES ARE TO BE USED, AND, IF IT IS NON-ZERO, +C IT IS THE NUMBER OF THE "FILE" TO BE READ FROM UNIT ITPN. NPTS, JUST +C AFTER A READ, IS THE NUMBER OF ELEMENTS READ INTO PNTS; IT IS THEN +C DIVIDED BY 2 TO BECOME THE NUMBER OF POINTS DEFINED BY THE GROUP JUST +C READ. IGID IS AN IDENTIFIER FOR THE GROUP, SO THAT, FOR EXAMPLE, ONE +C CAN DISTINGUISH A GROUP BELONGING TO A INTERNATIONAL BOUNDARY FROM +C ONE BELONGING TO A U.S. STATE BOUNDARY. BLAG, SLAG, BLOG, AND SLOG +C SPECIFY THE BIGGEST AND SMALLEST LATITUDE AND THE BIGGEST AND SMALLEST +C LONGITUDE OF THE POINTS IN THE GROUP, SO THAT, IN SOME CASES AT LEAST, +C ONE CAN DECIDE QUICKLY NOT TO BOTHER WITH THE GROUP. PNTS CONTAINS +C NPTS COORDINATE PAIRS, EACH CONSISTING OF A LATITUDE AND A LONGITUDE, +C IN DEGREES. +C + DATA ITPN,NOUT / 1,1 / +C +C +C VARIABLES IN MAPCM4: +C +C INTF IS A FLAG WHOSE VALUE AT ANY GIVEN TIME INDICATES WHETHER THE +C PACKAGE EZMAP IS IN NEED OF INITIALIZATION (.TRUE.) OR NOT (.FALSE). +C JPRJ IS AN INTEGER BETWEEN 1 AND 9 INDICATING THE TYPE OF PROJECTION +C CURRENTLY IN USE. PHIA, PHIO, AND ROTA ARE THE POLE LATITUDE AND +C LONGITUDE AND THE ROTATION ANGLE SPECIFIED BY THE LAST USER CALL TO +C MAPROJ. ILTS IS AN INTEGER BETWEEN 1 AND 5, SPECIFYING HOW THE LIMITS +C OF THE MAP ARE TO BE CHOSEN. PLA1-4 AND PLB1-4 ARE THE VALUES GIVEN +C BY THE USER FOR PLM1(1), PLM2(1), ..., PLM1(2), PLM2(2), ..., IN THE +C LAST CALL TO MAPSET. PLTR IS THE PLOTTER RESOLUTION - EFFECTIVELY, +C THE NUMBER OF ADDRESSABLE POINTS IN THE X DIRECTION. GRID IS THE +C DESIRED SPACING BETWEEN GRID LINES, IN DEGREES OF LATITUDE/LONGITUDE. +C IDSH IS THE DESIRED DASH PATTERN (16-BIT BINARY) FOR GRID LINES. IDOT +C IS A FLAG SELECTING SOLID OUTLINES (0) OR DOTTED OUTLINES (1). LBLF +C IS A LOGICAL FLAG INDICATING WHETHER THE INTERNATIONAL DATE LINE, THE +C EQUATOR, THE GREENWICH MERIDIAN, AND THE POLES ARE TO BE LABELLED OR +C NOT. PRMF IS A LOGICAL FLAG INDICATING WHETHER OR NOT A PERIMETER +C IS TO BE DRAWN. ELPF IS A LOGICAL FLAG INDICATING WHETHER THE MAP +C PERIMETER IS TO BE RECTANGULAR (.FALSE.) OR ELLIPTICAL (.TRUE.). +C XLOW, XROW, YBOW, AND YTOW ARE FRACTIONS BETWEEN 0. AND 1. SPECIFYING +C THE POSITION OF AREA OF THE PLOTTER FRAME IN WHICH THE MAP IS TO BE +C PUT; THE MAP IS CENTERED IN THIS AREA AND MADE AS LARGE AS POSSIBLE. +C IDTL IS A FLAG SPECIFYING THAT MAPIT SHOULD DRAW SOLID OUTLINES (0) +C OR DOTTEN OUTLINES (1). GRDR AND SRCH ARE MEASURED IN DEGREES AND +C LIE IN THE RANGE FROM .001 TO 10. GRDR SPECIFIES THE RESOLUTION WITH +C WHICH THE GRID IS TO BE DRAWN AND SRCH THE ACCURACY WITH WHICH THE +C LATITUDE/LONGITUDE LIMITS OF THE MAP ARE TO BE FOUND. ILCW IS THE +C CHARACTER WIDTH FOR CHARACTERS IN THE LABEL, AS REQUIRED FOR USE IN A +C CALL TO PWRIT. +C + DATA INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4,PLB1,PLB2 / + 1 .TRUE., 7, 0., 0., 0., 1, 0., 0., 0., 0., 0., 0. / +C + DATA PLB3,PLB4, PLTR,GRID, IDSH,IDOT, LBLF , PRMF , ELPF ,IDTL / + 1 0., 0.,4096., 10.,21845, 0,.TRUE.,.TRUE.,.FALSE., 0 / +C + DATA XLOW,XROW,YBOW,YTOW / .05,.95,.05,.95 / +C + DATA GRDR,SRCH / 1.,1. / +C + DATA ILCW / 1 / +C +C +C VARIABLES IN MAPCM5: +C +C DDCT IS THE DICTIONARY OF AVAILABLE DATASETS, LDCT THE DICTIONARY OF +C MAP LIMIT DEFINITION TYPES, AND PDCT THE DICTIONARY OF MAP PROJECTION +C NAMES. +C + DATA DDCT / 'NO','CO','US','PS','PO' / +C + DATA LDCT / 'MA','CO','PO','AN','LI' / +C + DATA PDCT / 'LC','ST','OR','LE','GN','AE','CE','ME','MO','SV' / +C +C +C VARIABLES IN MAPCM7: +C +C ULOW, UROW, VBOW, AND VTOW DEFINE THE FRACTION OF THE PLOTTER FRAME +C TO BE OCCUPIED BY THE MAP - THEY MAY BE THOUGHT OF AS THE FIRST FOUR +C ARGUMENTS OF THE SET CALL OR, IN THE GKS SCHEME, AS THE VIEWPORT. +C THEY ARE COMPUTED BY MAPINT. ULOW AND UROW ARE GIVEN DEFAULT VALUES +C TO PREVENT CODE IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS +C SET PRIOR TO THE FIRST CALL TO MAPINT. +C + DATA ULOW,UROW / 0.,1. / +C +C +C VARIABLES IN MAPCM8: +C +C P, Q, AND R ARE SET BY MAPTRN EACH TIME IT MAPS (RLAT,RLON) TO (U,V). +C Q IS ALWAYS EQUAL TO V, BUT P IS NOT ALWAYS EQUAL TO U. INSTEAD, IT +C IS A VALUE OF U FROM AN INTERMEDIATE STEP IN THE PROJECTION PROCESS. +C FOR THE LAMBERT CONFORMAL CONIC, P IS THE DISTANCE, IN LONGITUDE, FROM +C THE CENTRAL MERIDIAN. FOR THE CYLINDRICAL PROJECTIONS, P IS A VALUE +C OF U PRIOR TO MULTIPLICATION BY A FUNCTION OF V SHRINKING THE MAP +C TOWARD A VERTICAL BISECTOR. THEY ARE ALL USED BY MAPIT, WHILE DRAWING +C LINES FROM POINT TO POINT, TO DETECT "CROSS-OVER" (A JUMP FROM ONE +C SIDE OF THE MAP TO THE OTHER, CAUSED BY THE PROJECTION'S HAVING SLIT +C THE GLOBE ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT OPEN WITH THE +C TWO SIDES OF THE SLIT AT OPPOSITE ENDS OF THE MAP). +C +C +C VARIABLES IN MAPCMA: +C +C DPLT IS THE MIMIMUM VECTOR LENGTH; MAPIT REQUIRES TWO POINTS TO BE AT +C LEAST DPLT PLOTTER UNITS APART BEFORE IT WILL JOIN THEM WITH A VECTOR. +C DDTS IS THE DESIRED DISTANCE IN PLOTTER UNITS BETWEEN DOTS IN A DOTTED +C OUTLINE. THESE VALUES ARE RELATIVE TO THE "PLOTTER RESOLUTION" PLTR; +C DPLT/PLTR IS A FRACTION OF THE PLOTTER FRAME. DSCA IS THE RATIO OF +C THE LENGTH OF A VECTOR, MEASURED IN PLOTTER UNITS, TO THE LENGTH OF +C THE SAME VECTOR, MEASURED IN THE U/V PLANE. THUS, GIVEN A VECTOR OF +C LENGTH D IN THE U/V PLANE, D*DSCA IS ITS LENGTH IN PLOTTER UNITS. +C DPSQ AND DSSQ ARE THE SQUARES OF DPLT AND DSCA, RESPECTIVELY. DBTD +C IS THE DISTANCE, IN THE U/V PLANE, BETWEEN TWO DOTS DDTS PLOTTER +C UNITS APART. DPLT AND DDTS HAVE THE VALUES GIVEN BELOW AND ARE NOT +C RESET BY THE CODE; DSCA, DPSQ, DSSQ, AND DBTD ARE COMPUTED BY MAPINT. +C DSCA IS GIVEN A DEFAULT VALUE ONLY TO KEEP THE ROUTINES MAPSTI AND +C MAPSTR FROM BLOWING UP WHEN DDTS IS SET PRIOR TO ANY CALL TO MAPINT. +C DATL IS USED BY MAPIT AND MAPVP TO KEEP TRACK OF WHERE THE NEXT POINT +C ALONG A CURVE SHOULD GO. +C + DATA DPLT,DDTS,DSCA / 4.,12.,1. / +C +C +C VARIABLES IN MAPCMB: +C +C IIER IS AN ERROR FLAG, SET WHENEVER AN ERROR OCCURS DURING A CALL TO +C ONE OF THE EZMAP ROUTINES. ITS VALUE MAY BE RETRIEVED BY A CALL TO +C MAPGTI. +C + DATA IIER / 0 / +C +C +C VARIABLES IN MAPCMP: +C +C NPTB IS THE NUMBER OF POINTS WHOSE COORDINATES HAVE BEEN COLLECTED IN +C THE ARRAYS XPTB AND YPTB FOR EVENTUAL OUTPUT BY A CALL TO POINTS. +C + DATA NPTB / 0 / +C +C VARIABLES IN MAPNTS: +C +C THE ARRAY INTS SPECIFIES INTENSITIES TO BE USED FOR THE PERIMETER, FOR +C THE GRID, FOR LABELLING, FOR LIMBS, FOR THE CONTINENTAL OUTLINES, FOR +C THE U.S. STATE OUTLINES, AND FOR INTERNATIONAL POLITICAL OUTLINES. +C SEE THE ROUTINE MAPCHI. EACH ELEMENT IS AN INTEGER IN THE RANGE 0 TO +C 255, INCLUSIVE. +C + DATA INTS / 240,150,210,240,240,180,210 / +C +C +C VARIABLES IN MAPSAT: +C +C THE ABSOLUTE VALUE OF SALT, IF GREATER THAN 1, SERVES AS A FLAG THAT +C A SATELLITE-VIEW PROJECTION IS TO BE USED IN PLACE OF AN ORTHOGRAPHIC +C PROJECTION; ITS VALUE IS THE DISTANCE OF THE SATELLITE FROM THE CENTER +C OF THE EARTH, IN UNITS OF EARTH RADII. IN THIS CASE, SSMO IS THE +C SQUARE OF SALT MINUS 1 AND SRSS IS THE SQUARE ROOT OF SSMO. IF ALFA +C IS ZERO, THE PROJECTION SHOWS THE VIEW SEEN BY A SATELLITE LOOKING +C STRAIGHT AT THE CENTER OF THE EARTH; CALL THIS THE BASIC SATELLITE +C VIEW. IF ALFA IS NON-ZERO, IT AND BETA ARE ANGLES, IN DEGREES, +C DETERMINING WHERE THE LINE OF SIGHT OF THE PROJECTION IS. IF E IS +C AT THE CENTER OF THE EARTH, S IS AT THE SATELLITE, AND P IS A POINT +C ALONG THE LINE OF SIGHT, THEN ALFA MEASURES THE ANGLE ESP. IF O IS +C THE POINT AT THE ORIGIN OF THE BASIC SATELLITE VIEW AND P IS THE +C PROJECTION OF THE LINE OF SIGHT, THEN BETA MEASURES THE ANGULAR +C DISTANCE FROM THE POSITIVE U AXIS TO THE LINE OP, POSITIVE IF +C MEASURED COUNTER-CLOCKWISE. SALF, CALF, SBET, AND CBET ARE SINES +C AND COSINES OF ALFA AND BETA. THE SIGN OF SALT INDICATES WHETHER A +C NORMAL PROJECTION (POSITIVE) OR AN EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE LATTER MAKES IT EASIER TO OVERLAY CONREC OUTPUT +C ON ONE OF THESE PROJECTIONS, BY PROJECTING POINTS OUT OF SIGHT AROUND +C THE LIMB TO POINT JUST OUTSIDE THE LIMB ON THE PROJECTED VIEW. +C + DATA SALT,ALFA,BETA,SALF,CALF,SBET,CBET / 0.,0.,0.,0.,1.,0.,1. / +C +C REVISION HISTORY: +C +C FEBRUARY, 1982 ADDED MODIFICATIONS SO THAT POINTS GENERATED BY THE +C DRAWING OF DOTTED CONTINENTAL OUTLINES ARE BUFFERED +C AND THEN PUT OUT WITH A CALL TO POINTS, INSTEAD OF +C BEING PUT OUT ONE AT A TIME WITH A CALL TO POINT AS +C BEFORE. THE LATTER RESULTED IN HUGE OVERHEAD IN THE +C PLOT FILE. ROUTINES MAPLOT AND MAPVP WERE MODIFIED, +C AND A NEW COMMON BLOCK MAPCMP WAS ADDED. +C +C AUGUST, 1984 CONVERTED TO FORTRAN-77 AND GKS. DELETED THE EZMAP +C ENTRY POINT. +C +C MARCH, 1985 COMPLETELY OVERHAULED THE CODE TO SIMPLIFY IT AND TO +C REMOVE KNOWN ERRORS. UPDATED THE OUTLINE DATASET +C TO REMOVE ERRORS AND TO INCLUDE INTERNATIONAL +C BOUNDARIES. IMPLEMENTED MANY CONTROLS AIMED AT +C OBVIATING THE NEED FOR SOURCE MODIFICATION BY USERS. +C +C MAY, 1985 ADDED CODE TO PREVENT PROBLEMS WHEN A SMOOTHING +C VERSION OF THE DASH PACKAGE IS LOADED. ADDED CODE +C IN MAPIT TO GET AROUND A CFT COMPILER PROBLEM. +C ADDED CODE TO DO EXTENDED ORTHOGRAPHIC AND SATELLITE- +C VIEW PROJECTIONS. +C +C JULY, 1985 FIXED A MISSING DECLARATION IN THE SUBROUTINE MAPSET +C AND LIMITED "CALL PLOTIT (0,0,0)" TO THE GKS VERSION. +C +C AUGUST, 1985 FIXED A PROBLEM IN MAPGRD WHICH CAUSED MERIDIANS ON +C MERCATOR MAPS WITH VERTICAL LIMITS TOO CLOSE TO THE +C POLES TO BE DRAWN IMPROPERLY. (THE TEST FOR CROSS- +C OVER, IN MAPIT, WAS BEING PASSED BECAUSE THE POINTS +C USED TO DRAW THE MERIDIANS WERE TOO FAR APART.) ALSO +C FIXED AN ERROR IN THE GKS CODE IN MAPCHI AND BEEFED +C UP THE IMPLEMENTORS' INSTRUCTIONS TO SAY WHAT TO DO +C WITH THAT ROUTINE WHEN COLOR IS AVAILABLE. +C +C NOVEMBER, 1985 ADDED CODE TO PREVENT GKS CLIPPING FROM DESTROYING +C PART OF THE PERIMETER. +C + END diff --git a/sys/gio/ncarutil/gridal.f b/sys/gio/ncarutil/gridal.f new file mode 100644 index 00000000..8ad31020 --- /dev/null +++ b/sys/gio/ncarutil/gridal.f @@ -0,0 +1,1583 @@ + SUBROUTINE GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,IGPH,X,Y) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C LATEST REVISION JULY, 1985 +C +C PURPOSE THIS IS A PACKAGE OF ROUTINES FOR DRAWING +C GRAPH PAPER, AXES, AND OTHER BACKGROUNDS. +C +C USAGE EACH USER ENTRY POINT IN THIS PACKAGE (GRID, +C GRIDL, PERIM, PERIML, HALFAX, LABMOD, +C TICK4, AND GRIDAL) WILL BE DESCRIBED +C SEPARATELY BELOW. FIRST, HOWEVER, WE +C WILL DISCUSS HOW MAJOR AND MINOR DIVISIONS +C IN THE GRAPH PAPER ARE HANDLED BY ALL +C ENTRIES WHICH USE THEM. +C +C GRIDAL, GRID, GRIDL, PERIM, PERIML, AND +C HALFAX HAVE ARGUMENTS MAJRX,MINRX,MAJRY, +C MINRY WHICH CONTROL THE NUMBER OF MAJOR AND +C MINOR DIVISIONS IN THE GRAPH PAPER OR +C PERIMETERS. THE NUMBER OF DIVISIONS REFERS +C TO THE HOLES BETWEEN LINES RATHER THAN THE +C LINES THEMSELVES. THIS MEANS THAT THERE +C IS ALWAYS ONE MORE MAJOR DIVISION LINE THAN +C THE NUMBER OF MAJOR DIVISIONS. SIMILARLY, +C THERE IS ONE LESS MINOR DIVISION LINE THAN +C MINOR DIVISIONS (PER MAJOR DIVISION.) +C +C MAJRX,MAJRY,MINRX,MINRY HAVE DIFFERENT +C MEANINGS DEPENDING UPON WHETHER LOG +C SCALING IS IN EFFECT (SET VIA SETUSV OR +C SET IN THE SPPS PACKAGE.) +C +C FOR LINEAR SCALING, +C MAJRX AND MAJRY SPECIFY THE NUMBER OF MAJOR +C DIVISIONS ALONG THE X-AXIS OR Y-AXIS +C RESPECTIVELY, AND MINRX AND MINRY SPECIFY +C THE NUMBER OF MINOR DIVISIONS PER MAJOR +C DIVISION. +C +C FOR LOG SCALING ALONG THE X-AXIS +C EACH MAJOR DIVISION OCCURS AT A FACTOR OF +C 10**MAJRX TIMES THE PREVIOUS DIVISION. +C FOR EXAMPLE, IF THE MINIMUM X-AXIS VALUE IS +C 3., AND THE MAXIMUM X-AXIS VALUE IS 3000., +C AND MAJRX IS 1, THEN MAJOR DIVISIONS WILL +C OCCUR AT 3., 30., 300., AND 3000. SIMILARLY +C FOR MAJRY. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.LE.10, THEN THERE ARE +C NINE MINOR DIVISIONS BETWEEN EACH MAJOR +C DIVISION. FOR EXAMPLE, BETWEEN 3. AND 30. +C THERE WOULD BE A MINOR DIVISION AT 6., 9., +C 12.,...,27. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.GT.10, THEN THERE WILL +C BE NO MINOR SUBDIVISIONS. MINRY IS TREATED +C IN THE SAME MANNER AS MINRX. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO +C BE USED FOR NORMAL INTENSITY, LOW INTENSITY, +C OR TEXT COLOR, THEN THE VALUES IN COMMON +C BLOCK GRIINT SHOULD BE CHANGED AS FOLLOWS: +C +C IGRIMJ COLOR INDEX FOR NORMAL (MAJOR) +C INTENSITY LINES. +C IGRIMN COLOR INDEX FOR LOW INTENSITY +C LINES. +C IGRITX COLOR INDEX FOR TEXT (LABELS.) +C +C WE NOW DESCRIBE EACH ENTRY IN THIS PACKAGE. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRID +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRID (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE DRAWS GRAPH LINES IN THE PORTION +C OF THE PLOTTER SPECIFIED BY THE CURRENT VIEWPORT +C SETTING WITH THE NUMBER OF MAJOR AND MINOR +C DIVISIONS AS SPECIFIED BY THE ARGUMENTS. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDAL +C----------------------------------------------------------------------- +C +C PURPOSE A GENERAL ENTRY POINT FOR ALL BACKGROUND ROUTINES +C WITH THE OPTION OF LINE LABELLING ON EACH AXIS. +C +C USAGE CALL GRIDAL (MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB, +C IGPH,X,Y) +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR AXIS DIVISIONS AS DESCRIBED IN THE +C USAGE SECTION OF THE PACKAGE DOCUMENTATION ABOVE. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C +C IGPH +C FLAG FOR BACKGROUND TYPE: +C +C IGPH X-AXIS BACKGROUND Y-AXIS BACKGROUND +C ---- ----------------- ----------------- +C 0 GRID GRID +C 1 GRID PERIM +C 2 GRID HALFAX +C 4 PERIM GRID +C 5 PERIM PERIM +C 6 PERIM HALFAX +C 8 HALFAX GRID +C 9 HALFAX PERIM +C 10 HALFAX HALFAX +C +C X,Y +C WORLD COORDINATES OF THE INTERSECTION OF THE AXES +C IF IGPH=10 . +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDL +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRIDL (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES EXACTLY AS GRID, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE HALFAX +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW ORTHOGONAL AXES. +C +C USAGE CALL HALFAX (MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C +C DESCRIPTION THIS SUBROUTINE DRAWS ORTHOGONAL AXES INTERSECTING +C AT COORDINATE (X,Y) WITH OPTIONAL LABELING OPTIONS AS +C SPECIFIED BY IXLAB AND IYLAB. +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR DIVISION SPECIFICATIONS AS PER THE +C DESCRIPTION IN THE PACKAGE USAGE SECTION ABOVE. +C +C X,Y +C WORLD COORDINATES SPECIFYING THE INTERSECTION POINT +C OF THE X AND Y AXES. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C----------------------------------------------------------------------- +C SUBROUTINE LABMOD +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW MORE COMPLETE CONTROL OVER THE APPEARANCE +C OF THE LABELS ON THE BACKGROUND PLOTS. +C +C USAGE CALL LABMOD (FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY, +C IXDEC,IYDEC,IXOR) +C +C DESCRIPTION THIS SUBROUTINE PRESETS PARAMETERS FOR THE OTHER +C BACKGROUND ROUTINES IN THIS PACKAGE. LABMOD ITSELF +C DOES NO PLOTTING AND IT MUST BE CALLED BEFORE THE +C THE BACKGROUND ROUTINES FOR WHICH IT IS PRESETTING +C PARAMETERS. +C +C ARGUMENTS FMTX,FMTY (TYPE CHARACTER) +C FORMAT SPECIFICATIONS FOR THE X-AXIS AND Y-AXIS +C NUMERICAL LABELS IN GRIDL, PERIML, GRIDAL, OR +C HALFAX. THE SPECIFICATION MUST START WITH A LEFT +C PARENTHESIS AND END WITH A RIGHT PARENTHESIS AND +C SHOULD NOT USE MORE THAN 8 CHARACTERS. ONLY +C FLOATING-POINT CONVERSIONS (F, E, AND G) SUCH AS +C FMTX='(F8.2)' AND FMTY='(E10.0)' FOR EXAMPLE. +C +C NUMX,NUMY (INTEGER) +C THE NUMBER OF CHARACTERS SPECIFIED BY FMTX AND +C FMTY. FOR THE ABOVE EXAMPLES, THESE WOULD BE +C NUMX=8 AND NUMY=10 (NOT 6 AND 7). +C +C ISIZX,ISIZY +C CHARACTER SIZE CODES FOR THE LABELS. THESE SIZE +C CODES ARE THE SAME AS THOSE FOR THE SPPS ENTRY +C PWRIT. +C +C IXDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C LEFTMOST PLOTTER COORDINATE (AS SPECIFIED BY THE +C CURRENT VIEWPORT) TO THE NEAREST X-ADDRESS OF THE +C LABEL SPECIFIED BY FMTY, NUMY, AND ISIZY. FOR +C EXAMPLE, IF THE MINIMUM X-COORDINATE OF THE CURRENT +C VIEWPORT IS .1, MINX IS 102 (.1*1024). IF IXDEC +C IS 60, THE LABEL WILL START AT 42 (102-60). THE +C FOLLOWING CONVENTIONS ARE USED: +C +C O IF IXDEC=0, IT IS AUTOMATICALLY RESET TO PROPERLY +C POSITION THE Y-AXIS LABELS TO THE LEFT OF THE +C LEFT Y-AXIS, IXDEC=20 . +C +C O IF IXDEC=1, Y-AXIS LABELS WILL GO TO THE RIGHT +C OF THE GRAPH, IXDEC=-20 . +C +C WHEN EITHER HALFAX OR GRIDAL IS CALLED TO DRAW AN +C AXIS, IXDEC IS THE DISTANCE FROM THE AXIS RATHER +C THAN FROM THE MINIMUM VIEWPORT COORDINATE. +C +C IYDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C MINIMUM Y-AXIS COORDINATE AS SPECIFIED BY THE +C CURRENT VIEWPORT TO THE NEAREST Y-ADDRESS OF THE +C LABEL SPECIFIED BY FMTX, NUMX, AND ISIZX. FOR +C EXAMPLE, IF THE MINIMUM Y-COORDINATE OF THE +C CURRENT VIEWPORT IS .2, MINY IS 205 (.2*1024). +C IF IYDEC=30, THE LABEL WILL END AT 205-30=175. +C THE FOLLOWING CONVENTIONS ARE USED: +C +C O IF IYDEC=0, IT IS AUTOMATICALLY RESET TO +C PROPERLY POSITION X-AXIS LABELS ALONG THE +C BOTTOM, IYDEC=20 . +C +C O IF IYDEC=1, X-AXIS LABELS WILL GO ALONG THE +C TOP OF THE GRAPH, IYDEC=-20 . +C +C IXOR (INTEGER) +C ORIENTATION OF THE X-AXIS LABELS. +C +C IXOR = 0 +X (HORIZONTAL) +C = 1 +Y (VERTICAL) +C +C IN NORMAL ORIENTATION, THE ACTUAL NUMBER OF +C NON-BLANK DIGITS IS CENTERED UNDER THE LINE +C OR TICK TO WHICH IT APPLIES. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIM +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS. +C +C USAGE CALL PERIM (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS GRID EXCEPT THAT +C INTERIOR LINES ARE REPLACED WITH TICK MARKS ALONG +C THE EDGES. TICK MARKS AT MAJOR DIVISIONS ARE +C SLIGHTLY LARGER THAN TICK MARKS AT MINOR DIVISIONS. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIML +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS AND LABELS. +C +C USAGE CALL PERIML (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS PERIM, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE TICK4 +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW PROGRAM CONTROL OF TICK MARK LENGTH. +C +C USAGE CALL TICK4 (LMAJX,LMINX,LMAJY,LMINY) +C +C DESCRIPTION THIS SUBROUTINE ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN PERIM, PERIML, GRIDAL, AND HALFAX. +C +C ARGUMENTS LMAJX,LMAJY +C LENGTH IN PLOTTER ADDRESS UNITS OF MAJOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 12 . +C +C MINRX,MINRY +C LENGTH IN PLOTTER ADDRESS UNITS OF MINOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 8 . +C +C----------------------------------------------------------------------- +C +C WE NOW RESUME THE PACKAGE DOCUMENTATION. +C +C ENTRY POINTS GRID,GRIDAL,GRIDL,HALFAX,LABMOD,PERIM,PERIML,TICK4, +C TICKS,CHSTR,EXPAND,GRIDT +C +C COMMON BLOCKS LAB,CLAB,TICK,GRIINT +C +C REQUIRED THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS BACKGROUNDS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY WRITTEN IN JUNE, 1984. BASED ON THE NCAR SYSTEM +C PLOT PACKAGE ENTRIES HAVING THE SAME NAMES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX +C +C INTERNAL VARIABLES: +C +C CHUPX,CHUPY CHARACTER UP VECTOR VALUES ON ENTRY +C +C CURMAJ IF LOGMIN=.TRUE., THEN THIS IS THE +C CURRENT MAJOR TICK/GRID POSITION +C +C ICNT NORMALIZATION TRANSFORMATION NUMBER IN +C EFFECT ON ENTRY TO GRIDAL +C +C LASF(13) ASPECT SOURCE FLAG TABLE AS USED BY GKS. +C +C LGRID .TRUE. IF GRIDS ARE TO BE DRAWN ON THE +C CURRENT AXIS (OPPOSED TO TICKS) +C +C LOGMIN .TRUE. IF LOG SCALING IS IN EFFECT AND +C MINOR TICK MARKS OR GRIDS ARE DESIRED +C +C LOGVAL LINEAR OR LOG SCALING +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C +C MINCNT NUMBER OF MINOR DIVISIONS PER MAJOR +C +C NERR COUNTS ERROR NUMBER +C +C NEXTMAJ IF LOGMIN=.TRUE., THEN THIS IS THE NEXT +C MAJOR TICK/GRID POSITION +C +C NWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C AFTER EXPANSION +C +C OCOLI COLOR INDEX ON ENTRY TO GRIDAL +C +C OLDALH,OLDALV TEXT ALIGNMENT VALUES ON ENTRY +C (HORIZONTAL AND VERTICAL) +C +C OLDCH CHARACTER HEIGHT ON ENTRY TO GRIDAL +C +C OPLASF STORES VALUE OF POLYLINE COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXASF STORES VALUE OF TEXT COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXCOL TEXT COLOR INDEX ON ENTRY TO GRIDAL +C +C OWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C ON ENTRY TO GRIDAL +C +C PY(2) 2 Y-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C PX(2) 2 X-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C START IF DRAWING TICKS/GRIDS ON X-AXIS: +C Y-COORD OF ORIGIN OF EACH LINE; +C IF DRAWING TICKS/GRIDS ON Y-AXIS: +C X-COORD OF ORIGIN OF EACH LINE +C +C TICBIG END OF MAJOR TICK LINE IN WORLD +C COORDINATES +C +C TICEND END OF MINOR TICK LINE IN WORLD +C COORDINATES +C +C TICMAJ LENGTH OF MAJOR TICKS IN WORLD +C COORDINATES +C +C TICMIN LENGTH OF MINOR TICKS IN WORLD +C COORDINATES +C +C VIEW(4) VIEWPORT LIMITS IN NDC PRIOR TO +C EXPANSION FOR LABELLING +C +C WIND(4) SAME AS IN OWIND(4) +C +C XCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C XDEC LENGTH IN WORLD COORDINATES FROM +C X-AXIS TO LABEL +C +C XI ALOG10(X), IF LOG SCALING +C +C XINT INTERVAL BETWEEN MINOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XINTM INTERVAL BETWEEN MAJOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XMIRRO LOGICAL FLAGS FOR MIRROR-IMAGE +C +C XNUM TOTAL NUMBER OF X-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C XPOS IF LINEAR SCALING, KEEPS TRACK OF X-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C XRANGE TOTAL RANGE IN X DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C XRNEW RANGE IN X DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C YCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C YDEC LENGTH IN WORLD COORDINATES FROM +C Y-AXIS TO LABEL +C +C YI ALOG10(Y), IF LOG SCALING +C +C YINTM INTERVAL BETWEEN MAJOR Y-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C YMIRRO PLOTTING. +C +C YNUM TOTAL NUMBER OF Y-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C YPOS IF LINEAR SCALING, KEEPS TRACK OF Y-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C YRANGE TOTAL RANGE IN Y DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C YRNEW RANGE IN Y DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C XLAB,YLAB IF LABELLING X-AXIS, Y-COORDINATE FOR +C FOR TEXT POSITION; +C IF LABELLING Y-AXIS, X-COORDINATE FOR +C TEXT POSITION. +C +C +C + CHARACTER*8 XFMT,YFMT + REAL WIND(4), VIEW(4), PX(2), PY(2), NWIND(4), OWIND(4) + REAL MAJX, MINX, MAJY, MINY + INTEGER TCOUNT, XTNUM, YTNUM, FIRST, LAST + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI, OLDALH ,OLDALV + LOGICAL LGRID,LOGMIN + LOGICAL XMIRRO,YMIRRO + REAL MAJDIV, NEXTMA + CHARACTER*15 LABEL +C + DATA TICMIN,TICMAJ,XCUR,YCUR,EXCUR,EYCUR/0.,0.,0.,0.,0.,0./ +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDAL','VERSION 01') + XRNEW = 0. + YRNEW = 0. +C +C INITIALIZE ERROR COUNT. +C + NERR = 0 +C +C CHECK FOR BAD VALUES OF IGPH. +C + IF (IGPH.LT.0.OR.IGPH.EQ.3.OR.IGPH.EQ.7.OR.IGPH.GT.10) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--INVALID IGPH VALUE',NERR,2) + ENDIF +C +C GET STANDARD ERROR MESSAGE UNIT +C + IERUNT = I1MACH(4) + XMIRRO = .FALSE. + YMIRRO = .FALSE. +C +C SET POLYLINE COLOR ASF TO INDIVIDAUL. +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE COLOR INDEX. +C + CALL GQPLCI(IERR,OCOLI) +C +C SET POLYLINE COLOR TO THE VALUE SPECIFIED IN COMMON. +C + CALL GSPLCI(IGRIMJ) +C +C INQUIRE CURRENT NORMALIZATION TRANSFORMATION NUMBER. +C + CALL GQCNTN(IERR,ICNT) +C +C INQUIRE CURRENT WINDOW AND VIEWPORT LIMITS. +C + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C STORE WINDOW VALUES +C + DO 10 I = 1,4 + OWIND(I) = WIND(I) + 10 CONTINUE +C +C LOG OR LINEAR SCALING? +C +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C + CALL GETUSV('LS',LOGVAL) +C +C ADJUST WINDOW TO ACCOUNT FOR LOG SCALING. +C + IF (LOGVAL .EQ. 2) THEN + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ELSE IF (LOGVAL .EQ. 3) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + ELSE IF (LOGVAL .EQ. 4) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ENDIF +C +C DETERMINE IF MIRROR-IMAGE MAPPING IS REQUIRED. +C + IF (WIND(1) .GT. WIND(2)) THEN + XMIRRO = .TRUE. + ENDIF + IF (WIND(3) .GT. WIND(4)) THEN + YMIRRO = .TRUE. + ENDIF +C +C IF IGPH=10, CHECK FOR X(Y) VALUES IN RANGE (IF NOT, CHANGE TO +C DEFAULT. +C + IF (IGPH .EQ. 10) THEN + XI = X + YI = Y + IF (((XI .LT. WIND(1) .OR. XI .GT. WIND(2)) .AND. .NOT. + 1 XMIRRO) .OR. (XMIRRO.AND.(XI.GT.WIND(1).OR.XI.LT.WIND(2)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--X VALUE OUT OF WINDOW RANGE',NERR,1) +C +NOAO - FTN writes and format statements deleted. Call to SETER okay. +C +C WRITE(IERUNT,1001)NERR +C1001 FORMAT(' ERROR',I3,' IN GRIDAL--X VALUE OUT OF WINDOW RANGE') + CALL ERROF + XI = WIND(1) + ENDIF + IF (((YI .LT. WIND(3) .OR. YI .GT. WIND(4)) .AND. .NOT. + 1 YMIRRO).OR.(YMIRRO.AND.(YI.GT.WIND(3).OR.YI.LT.WIND(4)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--Y VALUE OUT OF WINDOW RANGE',NERR,1) +C WRITE(IERUNT,1002)NERR +C1002 FORMAT(' ERROR',I3,' IN GRIDAL--Y VALUE OUT OF WINDOW RANGE') +C -NOAO + CALL ERROF + YI = WIND(3) + ENDIF + ENDIF + MX = MAJRX + MY = MAJRY + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) THEN + IF (MX .LT. 1) MX = 1 + IF (WIND(1) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(1) = ALOG10(WIND(1)) + ENDIF + IF (WIND(2) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(2) = ALOG10(WIND(2)) + ENDIF + IF (IGPH .EQ. 10) THEN + XI = ALOG10(XI) + ENDIF + ENDIF +C + IF(LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + IF (MY .LT. 1) MY = 1 + IF (WIND(3) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(3) = ALOG10(WIND(3)) + ENDIF + IF (WIND(4) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(4) = ALOG10(WIND(4)) + ENDIF + IF (IGPH .EQ. 10) THEN + YI = ALOG10(YI) + ENDIF + ENDIF +C +C DEFINE NORMALIZATION TRANSFORMATION NUMBER 1. +C + CALL GSWN(1,WIND(1),WIND(2),WIND(3),WIND(4)) + CALL GSVP(1,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + CALL GSELNT(1) +C +C CALCULATE X AND Y WORLD COORDINATE RANGES. +C + XRANGE = WIND(2) - WIND(1) + YRANGE = WIND(4) - WIND(3) +C +C IF LABELS ARE REQUESTED, INQUIRE AND SAVE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GQCHH(IERR,OLDCHH) + CALL GQCHUP(IERR,CHUPX,CHUPY) + CALL GQTXAL(IERR,OLDALH,OLDALV) + CALL GQTXCI (IERR,OTEXCI) + CALL GSTXCI (IGRITX) +C +C EXPAND WINDOW AND VIEWPORT FOR LABELS AND CALCULATE NEW +C X AND Y WORLD COORDINATE RANGES. +C + CALL EXPAND(NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) +C +C SET CHARACTER HEIGHT (1% OF Y RANGE.) +C + CHARH = SIZX * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + ENDIF +C + IF (IGPH .EQ. 0) GOTO 50 +C +C CALCULATE TIC LENGTH. +C +C IF NO LABELS AND TICK4 (OR TICKS) WERE NOT CALLED. +C + IF (MAJX .EQ. 0.) THEN + MAJX = .013 + MINX = .007 + TICMIN = MINX * YRANGE + TICMAJ = MAJX * YRANGE + ELSE +C +C EXPAND WINDOW IF NOT ALREADY EXPANDED. +C (IF LABMOD WAS NOT CALLED BUT TICK4(S) WAS.) +C + IF (IXLAB.NE.1 .AND. IYLAB.NE.1) THEN + CALL EXPAND (NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) + ENDIF + TICMIN = MINX * YRNEW + TICMAJ = MAJX * YRNEW + ENDIF +C +C **** X-AXIS TICS/GRIDS AND LABELS **** +C +C CALCULATE TIC/GRID INTERVALS ON X AXIS. +C + 50 IF (IXLAB .EQ. -1) GOTO 175 + MINCNT = MINRX + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + LOGMIN = .FALSE. + XINTM = XRANGE/MX + XINT = XINTM + IF (MINCNT .GT. 1) THEN + XINT = XINT/MINCNT + ENDIF +C +C CALCULATE TOTAL NUMBER OF TICS/GRIDS ON AXIS. +C + XTNUM = MX * MINCNT + IF (MINCNT .EQ. 0) XTNUM = MX + ELSE + XTNUM = 50 + XCUR = 10.**OWIND(1) + MAJDIV = 10 ** MX + IF (MINCNT .LE. 10 .AND. MX .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (Y COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(3) + ELSE + START = YI + ENDIF +C + XPOS = WIND(1) + PY(1) = START + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PX(1) = XPOS + PX(2) = PX(1) +C +C DRAW LEFT-MOST TICK ON X-AXIS (IF IGPH = 10 AND +C INTERSECTION OF AXES IS NOT AT BOTTOM LEFT OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (XI .NE. WIND(1)) THEN + PY(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW X-AXIS FOR IGPH = 10 +C + PX(2) = WIND(2) + PY(2) = PY(1) + CALL GPL(2,PX,PY) + PX(2) = PX(1) + ELSE +C +C DRAW Y-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + ENDIF +C +C TICKS OR GRIDS ? +C + IF (IGPH .EQ. 0 .OR. IGPH .EQ. 1 .OR. IGPH .EQ.2) THEN + PY(2) = WIND(4) + LGRID = .TRUE. + ELSE + PY(2) = TICEND + ENDIF +C + IF (IXLAB .EQ. 1) THEN +C +C IF VERTICAL X-AXIS LABEL ORIENTATION, THEN SET CHAR UP VECTOR +C TO BE VERTICAL AND TEXT ALIGNMENT TO (RIGHT,HALF), +C OTHERWISE TO (CENTER,TOP) +C + IF (YMIRRO) THEN + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSCHUP(0.,-1.) + CALL GSTXAL(2,1) + ENDIF + ELSE + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(-1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSTXAL(2,1) + ENDIF + ENDIF + IF (XDEC.NE.0. .AND. XDEC.NE.1.) THEN + DEC = XDEC * YRNEW + ELSE + DEC = .02 * YRNEW + ENDIF + IF (XDEC .NE. 1.) THEN + XLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + XLAB = WIND(4)+DEC + ELSE + XLAB = YI+DEC + ENDIF +C +C IF LABELS ARE ON TOP OF THE X-AXIS, SET THE TEXT +C ALIGNMENT TO (LEFT,HALF) IF THE X-AXIS LABELS ARE +C VERTICAL, OTHERWISE TO (CENTER,BASE). +C + IF (IXORI .EQ. 1) THEN + CALL GSTXAL(1,3) + ELSE + CALL GSTXAL(2,4) + ENDIF + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C +NOAO +C WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) +C -NOAO + ELSE +C +NOAO +C WRITE(LABEL,XFMT)XCUR + call encode (10, yfmt, label, xcur) +C -NOAO + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF +C + 80 TCOUNT = 1 +C + DO 100 I = 1,XTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + XPOS = XPOS + XINT + ELSE + IF (.NOT. LOGMIN) THEN + XCUR = XCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + XCUR = XCUR + XINT + ELSE + XCUR = XCUR + XINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (XCUR .GT. 10.**OWIND(2)-.1*XINT) THEN + XPOS = WIND(2) + ELSE + XPOS = ALOG10(XCUR) + ENDIF + ENDIF +C + PX(1) = XPOS + PX(2) = XPOS +C +C IF IGPH = 0,1,2,4,5,8 OR 9 AND XPOS=RIGHT AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 6 OR 10 DRAW TIC AND LABEL. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EXCUR = 10.**OWIND(2) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.2) .AND. (I .EQ. XTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.3).AND.XCUR.GE.EXCUR-.1*XINT)) + 2 .AND.(IGPH.NE.6.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + IF (IXLAB .EQ. 1) THEN + IF (LOGVAL.EQ.1 .OR. LOGVAL.EQ.2) THEN +C (NOAO) WRITE(LABEL,XFMT) XPOS + call encode (10, xfmt, label, xpos) + ELSE + IF (XCUR .GT. EXCUR+.1*XINT) THEN + GOTO 101 + ELSE +C (NOAO) WRITE(LABEL,XFMT) XCUR + call encode (10, xfmt, label, xcur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 101 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.3) .AND. XCUR.GT.EXCUR+.1*XINT) + 1 GOTO 101 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID +C + ELSE + IF (.NOT. LGRID) THEN + PY(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IXLAB .EQ. 1 .AND. LOOP .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C (NOAO) WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) + ELSE +C (NOAO) WRITE(LABEL,XFMT)XCUR + call encode (10, xfmt, label, xcur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PY(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) .AND. + 1 XCUR .GE. EXCUR-.1*XINT) GOTO 101 + 100 CONTINUE + 101 CONTINUE +C +C TOP X-AXIS TICKS ? +C + IF (LOOP.EQ.1 .AND. (IGPH.EQ.4 .OR. IGPH.EQ.5 .OR. IGPH.EQ.6)) + 1 THEN + START = WIND(4) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PY(1) = START + PY(2) = TICEND + XPOS = WIND(1) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ.3) THEN + XCUR = 10.**OWIND(1) + IF (LOGMIN) THEN + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 80 + ENDIF +C +C **** Y-AXIS TICS/GRIDS AND LABELS **** +C + 175 IF (IYLAB .EQ. -1) GOTO 999 +C +C CALCULATE Y-AXIS TICS +C + MINCNT = MINRY + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + LOGMIN = .FALSE. + YINTM = YRANGE/MY + YINT = YINTM + IF (MINCNT .GT. 1) THEN + YINT = YINT/MINCNT + ENDIF + YTNUM = MY * MINCNT + IF (MINCNT .EQ. 0) YTNUM = MY + ELSE + YTNUM = 50 + YCUR = 10.**OWIND(3) + MAJDIV = 10 ** MY + IF (MINCNT .LE. 10 .AND. MY .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (X COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(1) + ELSE + START = XI + ENDIF +C + YPOS = WIND(3) + PX(1) = START +C +C DETERMINE Y-AXIS TICK LENGTHS. +C + IF (MAJY .EQ. 0.) THEN + MAJY = .013 + MINY = .007 + ENDIF + IF (XRNEW .EQ. 0.) THEN + TICMIN = MINY * XRANGE + TICMAJ = MAJY * XRANGE + ELSE + TICMIN = MINY * XRNEW + TICMAJ = MAJY * XRNEW + ENDIF + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PY(1) = YPOS + PY(2) = PY(1) +C +C DRAW BOTTOM-MOST TICK ON Y-AXIS IF (IGPH = 10 +C AND INTERSECTION OF AXES IS NOT AT BOTTOM LEFT +C OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (YI .NE. WIND(3)) THEN + PX(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW Y-AXIS FOR IGPH = 10 +C + PY(2) = WIND(4) + PX(2) = PX(1) + CALL GPL(2,PX,PY) + PY(2) = PY(1) + ELSE +C +C DRAW X-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + ENDIF +C +C GRIDS OR TICS ? +C + IF ((IGPH .EQ. 0 .OR. IGPH .EQ. 4).OR. IGPH .EQ. 8) THEN + PX(2) = WIND(2) + LGRID = .TRUE. + ELSE + PX(2) = TICEND + ENDIF +C +C SET TEXT ATTRIBUTES IF Y-AXIS IS TO BE LABELLED. +C + IF (IYLAB .EQ. 1) THEN + IF (IXORI .EQ. 1) THEN + IF (YMIRRO) THEN + CALL GSCHUP(0.,-1.) + ELSE + CALL GSCHUP(0.,1.) + ENDIF + ENDIF +C +C SET TEXT ALIGNMENT TO (RIGHT,HALF) +C + CALL GSTXAL(3,3) +C +C RECALCULATE CHARACTER HEIGHT IF Y-AXIS LABELS ARE OF DIFFERENT +C SIZE FORM X-AXIS LABELS. +C + CHARH = SIZY * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + IF (YDEC .NE. 0. .AND. YDEC .NE. 1.) THEN + DEC = YDEC * XRNEW + ELSE + DEC = .02 * XRNEW + ENDIF + IF (YDEC .NE. 1.) THEN + YLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + YLAB = WIND(2)+DEC + ELSE + YLAB = XI+DEC + ENDIF +C +C SET TEXT ALIGNMENT TO (LEFT,HALF) IF LABELLING ON RIGHT OF Y-AXIS. +C + CALL GSTXAL(1,3) + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF +C + 180 TCOUNT = 1 +C + DO 200 I = 1,YTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + YPOS = YPOS + YINT + ELSE + IF (.NOT. LOGMIN) THEN + YCUR = YCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + YCUR = YCUR + YINT + ELSE + YCUR = YCUR + YINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (YCUR .GT. 10.**OWIND(4)-.1*YINT) THEN + YPOS = WIND(4) + ELSE + YPOS = ALOG10(YCUR) + ENDIF + ENDIF +C + PY(1) = YPOS + PY(2) = YPOS +C +C IF IGPH = 0,1,2,4,5,6 OR 8 AND YPOS = TOP AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 9 OR 10 DRAW TIC. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EYCUR = 10.**OWIND(4) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.3) .AND. (I .EQ. YTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.2).AND.YCUR.GE.EYCUR-.1*YINT)) + 2 .AND.(IGPH.NE.9.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + IF (IYLAB .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE + IF (YCUR .GT. EYCUR+.1*YINT) THEN + GOTO 201 + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 201 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.2) .AND. YCUR.GT.EYCUR+.1*YINT) + 1 GOTO 201 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID. +C + ELSE + IF (.NOT. LGRID) THEN + PX(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IYLAB .EQ. 1 .AND. LOOP .EQ.1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX(YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PX(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) .AND. + - YCUR .GE. EYCUR-.1*YINT) + 1 GOTO 201 + 200 CONTINUE + 201 CONTINUE +C +C RIGHT Y-AXIS TICKS ? +C + IF (LOOP .EQ. 1 .AND.(IGPH.EQ.1 .OR. IGPH .EQ. 5 .OR. + 1 IGPH .EQ. 9)) THEN + START = WIND(2) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PX(1) = START + PX(2) = TICEND + YPOS = WIND(3) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + YCUR = 10.**OWIND(3) + IF (LOGMIN) THEN + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 180 + ENDIF +C +C RESET NORMALIZATION TRANSFORMATION TO WHAT IT WAS UPON ENTRY. +C + IF (ICNT .NE. 0) THEN + CALL GSWN(ICNT,OWIND(1),OWIND(2),OWIND(3),OWIND(4)) + CALL GSVP(ICNT,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + ENDIF + CALL GSELNT(ICNT) +C +C IF LABELS, RESTORE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GSCHH(OLDCHH) + CALL GSCHUP(CHUPX,CHUPY) + CALL GSTXAL(OLDALH,OLDALV) + CALL GSTXCI(OTEXCI) + ENDIF +C +C RESTORE ORIGINAL COLOR. +C + CALL GSPLCI(OCOLI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IS WAS ON ENTRY. +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) +C + 999 RETURN + END + SUBROUTINE GRID(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRID','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,0,0.,0.) + RETURN + END + SUBROUTINE GRIDL(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDL','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,0,0.,0.) + RETURN + END + SUBROUTINE PERIM(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIM','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,5,0.,0.) + RETURN + END + SUBROUTINE PERIML(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIML','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,5,0.,0.) + RETURN + END + SUBROUTINE HALFAX(MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','HALFAX','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,10,X,Y) + RETURN + END + SUBROUTINE LABMOD(FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY,IXDEC,IYDEC, + 1 IXOR) +C +C RESETS PARAMETERS FOR TEXT GRAPHICS FROM DEFAULT VALUES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + CHARACTER*8 XFMT,YFMT,FMTX,FMTY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','LABMOD','VERSION 01') +C +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO + XFMT = ' ' + YFMT = ' ' + XFMT = FMTX + YFMT = FMTY +C + CALL GETUSV('XF',IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C +C SIZX AND SIZY ARE COMPUTED TO BE PERCENTAGES OF TOTAL SCREEN +C WIDTH. +C + IF (ISIZX .GT. 3) THEN + SIZX = FLOAT(ISIZX)/XRANGE + ELSEIF (ISIZX .EQ. 3) THEN + SIZX = 24./1024. + ELSEIF (ISIZX .EQ. 2) THEN + SIZX = 16./1024. + ELSEIF (ISIZX .EQ. 1) THEN + SIZX = 12./1024. + ELSE + SIZX = 8./1024. + ENDIF +C + IF (ISIZY .GT. 3) THEN + SIZY = FLOAT(ISIZY)/XRANGE + ELSEIF (ISIZY .EQ. 3) THEN + SIZY = 24./1024. + ELSEIF (ISIZY .EQ. 2) THEN + SIZY = 16./1024. + ELSEIF (ISIZY .EQ. 1) THEN + SIZY = 12./1024. + ELSE + SIZY = 8./1024. + ENDIF +C +C CALCULATE XDEC AND YDEC AS PERCENTAGES OF TOTAL SCREEN WIDTH +C IN PLOTTER ADDRESS UNITS. +C + IF (IXDEC .EQ. 0 .OR. IXDEC .EQ. 1) THEN + YDEC = FLOAT(IXDEC) + ELSE + YDEC = FLOAT(IXDEC)/XRANGE + ENDIF + IF (IYDEC .EQ. 0 .OR. IYDEC .EQ. 1) THEN + XDEC = FLOAT(IYDEC) + ELSE + XDEC = FLOAT(IYDEC)/YRANGE + ENDIF +C + IXORI = IXOR +C + RETURN + END + SUBROUTINE TICK4(LMAJX,LMINX,LMAJY,LMINY) +C +C CHANGES TICK LENGTH FOR EACH AXIS. +C + COMMON /TICK/ MAJX, MINX, MAJY, MINY + REAL MAJX, MINX, MAJY, MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICK4','VERSION 01') +C + CALL GETUSV('XF', IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C + MAJX = FLOAT(LMAJX)/YRANGE + MINX = FLOAT(LMINX)/YRANGE + MAJY = FLOAT(LMAJY)/XRANGE + MINY = FLOAT(LMINY)/XRANGE +C + RETURN + END + SUBROUTINE TICKS(LMAJ,LMIN) +C + COMMON /TICK/ MAJX,MINX,MAJY,MINY + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICKS','VERSION 01') +C + CALL TICK4(LMAJ,LMIN,LMAJ,LMIN) +C + RETURN + END + SUBROUTINE CHSTR(LABEL,FIRST,LAST) +C +C THIS CALCULATES THE POSITION OF THE FIRST NON-BLANK CHARACTER +C AND THE POSITION OF THE LAST NON-BLANK CHARACTER IN LABEL. +C + INTEGER FIRST, LAST + CHARACTER*15 LABEL +C + DO 100 I = 1,15 + IF (LABEL(I:I) .NE. ' ') GOTO 200 + 100 CONTINUE + 200 FIRST = I + LAST = 15 + IF (FIRST .NE. 15) THEN + DO 300 J = FIRST+1,15 + IF (LABEL(J:J) .EQ. ' ') THEN + LAST = J-1 + GOTO 999 + ENDIF + 300 CONTINUE + 999 CONTINUE + ENDIF + RETURN + END + SUBROUTINE EXPAND(MAXW) +C +C THE WINDOW IS EXPANDED AND THE NEW WORLD COORDINATES ARE +C CALCULATED TO CORRESPOND TO THE MAXIMUM VIEWPORT. +C THE ORIGINAL ASPECT RATIO OF WORLD COORDINATES TO VIEWPORT +C COORDINATES REMAINS THE SAME. UNDER THE NEWLY-DEFINED +C NORMALIZATION TRANSFORMATION, THE WINDOW OF THE ORIGINAL +C NORMALIZATION TRANSFORMATION IS MAPPED TO THE VIEWPORT +C OF THE ORIGINAL NORMALIZATION TRANSFORMATION IN EXACTLY +C THE SAME WAY AS IN THE INITIAL NORMALIZATION TRANSFORMATION. +C + REAL MAXW(4), VIEW(4), WIND(4) + REAL LEFT +C +C INQUIRE CURRENT WINDOW AND VIEWPORT SETTINGS. +C + CALL GQCNTN(IERR,ICNT) + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C CALCULATE RATIO OF Y WORLD/VIEWPORT COORDINATES. +C + YRATIO = (WIND(4) - WIND(3))/(VIEW(4) - VIEW(3)) +C +C CALCULATE RATIO OF X WORLD/VIEWPORT COORDINATES. +C + XRATIO = (WIND(2) - WIND(1))/(VIEW(2) - VIEW(1)) +C +C GET EXPANDED LOWER LIMIT Y COORDINATE. +C + VBOTTM = VIEW(3) - 0. + BOTTOM = YRATIO * VBOTTM + MAXW(3) = WIND(3) - BOTTOM +C +C GET EXPANDED UPPER LIMIT Y COORDINATE. +C + VTOP = 1. - VIEW(4) + TOP = YRATIO * VTOP + MAXW(4) = WIND(4) + TOP +C +C GET EXPANDED LEFT LIMIT X COORDINATE. +C + VLEFT = VIEW(1) - 0. + LEFT = XRATIO * VLEFT + MAXW(1) = WIND(1) - LEFT +C +C GET EXPANDED RIGHT LIMIT X COORDINATE. +C + VRIGHT = 1. - VIEW(2) + RIGHT = XRATIO * VRIGHT + MAXW(2) = WIND(2) + RIGHT +C +C SET NEW (EXPANDED) NORMALIZATION TRANSFORMATION. +C + CALL GSWN(1,MAXW(1),MAXW(2),MAXW(3),MAXW(4)) + CALL GSVP(1, 0., 1., 0., 1. ) + CALL GSELNT(1) +C + RETURN + END diff --git a/sys/gio/ncarutil/gridt.f b/sys/gio/ncarutil/gridt.f new file mode 100644 index 00000000..eb10ddf1 --- /dev/null +++ b/sys/gio/ncarutil/gridt.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c + noao: block data gridt changed to run time initialization +c BLOCK DATA GRIDT + subroutine gridt +C +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. +C +c DATA XFMT,YFMT /'(E10.3) ','(E10.3) '/ + XFMT = '(E10.3) ' + YFMT = '(E10.3) ' +c +c DATA SIZX,SIZY / 0.01, 0.01 / + SIZX = 0.01 + SIZY = 0.01 +c +c DATA XDEC,YDEC / 0., 0. / + XDEC = 0. + YDEC = 0. +c +c DATA IXORI / 0 / + IXORI = 0 +c +c DATA MAJX,MINX,MAJY,MINY / 0., 0., 0., 0./ + MAJX = 0. + MINX = 0. + MAJY = 0. + MINY = 0. +c +c DATA IGRIMJ,IGRIMN,IGRITX / 1, 1, 1/ +c+noao: These values changed so major axes and labels are bold + IGRIMJ = 2 + IGRIMN = 1 + IGRITX = 2 +C - noao + END +C REVISION HISTORY--------------- +C---------------------------------------------------------- + diff --git a/sys/gio/ncarutil/hafton.f b/sys/gio/ncarutil/hafton.f new file mode 100644 index 00000000..7d597470 --- /dev/null +++ b/sys/gio/ncarutil/hafton.f @@ -0,0 +1,830 @@ + SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C DIMENSION OF Z(L,M) +C ARGUMENTS +C +C LATEST REVISION JULY,1984 +C +C PURPOSE HAFTON DRAWS A HALF-TONE PICTURE FROM DATA +C STORED IN A RECTANGULAR ARRAY WITH THE +C INTENSITY IN THE PICTURE PROPORTIONAL TO +C THE DATA VALUE. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZHFTN (Z,M,N) +C +C ASSUMPTIONS: +C .ALL OF THE ARRAY IS TO BE DRAWN. +C .LOWEST VALUE IN Z WILL BE AT LOWEST +C INTENSITY ON READER/PRINTER OUTPUT. +C .HIGHEST VALUE IN Z WILL BE AT +C HIGHEST INTENSITY. +C .VALUES IN BETWEEN WILL APPEAR +C LINEARLY SPACED. +C .MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED. +C .THE PICTURE WILL HAVE A PERIMETER +C DRAWN. +C .FRAME WILL BE CALLED AFTER THE +C PICTURE IS DRAWN. +C .Z IS FILLED WITH NUMBERS THAT SHOULD +C BE USED (NO MISSING VALUES). +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL HAFTON (Z,L,M,N,FLO,HI,NLEV, +C NOPT,NPRM,ISPV,SPVAL) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZHFTN M BY N ARRAY TO BE USED TO GENERATE A +C HALF-TONE PLOT. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZHFTN +C +C ON INPUT Z +C FOR HAFTON THE ORIGIN OF THE ARRAY TO BE PLOTTED. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING ALL OF AN +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF Z THAT CORRESPONDS TO THE +C LOWEST INTENSITY. (WHEN NOPT.LT.0, FLO +C CORRESPONDS TO THE HIGHEST INTENSITY.) +C IF FLO=HI=0.0, MIN(Z) WILL BE USED FOR FLO. +C +C HI +C THE VALUE OF Z THAT CORRESPONDS TO THE +C HIGHEST INTENSITY. (WHEN NOPT.LT.0, HI +C CORRESPONDS TO THE LOWEST INTENSITY.) IF +C HI=FLO=0.0, MAX(Z) WILL BE USED FOR HI. +C +C NLEV +C THE NUMBER OF INTENSITY LEVELS DESIRED. +C 16 MAXIMUM. IF NLEV = 0 OR 1, 16 LEVELS +C ARE USED. +C +C NOPT +C FLAG TO CONTROL THE MAPPING OF Z ONTO THE +C INTENSITIES. THE SIGN OF NOPT CONTROLS +C THE DIRECTNESS OR INVERSENESS OF THE +C MAPPING. +C +C . NOPT POSITIVE YIELDS DIRECT MAPPING. +C THE LARGEST VALUE OF Z PRODUCES THE +C MOST DENSE DOTS. ON MECHANICAL PLOTTERS, +C LARGE VALUES OF Z WILL PRODUCE A DARK +C AREA ON THE PAPER. WITH THE FILM +C DEVELOPMENT METHODS USED AT NCAR, +C LARGE VALUES OF Z WILL PRODUCE MANY +C (WHITE) DOTS ON THE FILM, ALSO +C RESULTING IN A DARK AREA ON +C READER-PRINTER PAPER. +C . NOPT NEGATIVE YIELDS INVERSE MAPPING. +C THE SMALLEST VALUES OF Z PRODUCE THE +C MOST DENSE DOTS RESULTING IN DARK +C AREAS ON THE PAPER. +C +C THE ABSOLUTE VALUE OF NOPT DETERMINES THE +C MAPPING OF Z ONTO THE INTENSITIES. FOR +C IABS(NOPT) +C = 0 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 1 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 2 THE MAPPING IS EXPONENTIAL. FOR +C LARGER VALUES OF Z, THERE IS A +C LARGER DIFFERENCE IN INTENSITY FOR +C RELATIVELY CLOSE VALUES OF Z. DETAILS +C IN THE LARGER VALUES OF Z ARE DISPLAYED +C AT THE EXPENSE OF THE SMALLER VALUES +C OF Z. +C = 3 THE MAPPING IS LOGRITHMIC, SO +C DETAILS OF SMALLER VALUES OF Z ARE SHOWN +C AT THE EXPENSE OF LARGER VALUES OF Z. +C = 4 SINUSOIDAL MAPPING, SO MID-RANGE VALUES +C OF Z SHOW DETAILS AT THE EXPENSE OF +C EXTREME VALUES OF Z. +C = 5 ARCSINE MAPPING, SO EXTREME VALUES OF +C Z ARE SHOWN AT THE EXPENSE OF MID-RANGE +C VALUES OF Z. +C +C NPRM +C FLAG TO CONTROL THE DRAWING OF A +C PERIMETER AROUND THE HALF-TONE PICTURE. +C +C . NPRM=0: THE PERIMETER IS DRAWN WITH +C TICKS POINTING AT DATA LOCATIONS. +C (SIDE LENGTHS ARE PROPORTIONAL TO NUMBER +C OF DATA VALUES.) +C . NPRM POSITIVE: NO PERIMETER IS DRAWN. THE +C PICTURE FILLS THE FRAME. +C . NPRM NEGATIVE: THE PICTURE IS WITHIN THE +C CONFINES OF THE USER'S CURRENT VIEWPORT +C SETTING. +C +C ISPV +C FLAG TO TELL IF THE SPECIAL VALUE FEATURE +C IS BEING USED. THE SPECIAL VALUE FEATURE +C IS USED TO MARK AREAS WHERE THE DATA IS +C NOT KNOWN OR HOLES ARE WANTED IN THE +C PICTURE. +C +C . ISPV = 0: SPECIAL VALUE FEATURE NOT IN +C USE. SPVAL IS IGNORED. +C . ISPV NON-ZERO: SPECIAL VALUE FEATURE +C IN USE. SPVAL DEFINES THE SPECIAL +C VALUE. WHERE Z CONTAINS THE SPECIAL +C VALUE, NO HALF-TONE IS DRAWN. IF ISPV +C = 0 SPECIAL VALUE FEATURE NOT IN USE. +C SPVAL IS IGNORED. +C = 1 NOTHING IS DRAWN IN SPECIAL VALUE +C AREA. +C = 2 CONTIGUOUS SPECIAL VALUE AREAS ARE +C SURROUNDED BY A POLYGONAL LINE. +C = 3 SPECIAL VALUE AREAS ARE FILLED +C WITH X(S). +C = 4 SPECIAL VALUE AREAS ARE FILLED IN +C WITH THE HIGHEST INTENSITY. +C +C SPVAL +C THE VALUE USED IN Z TO DENOTE MISSING +C VALUES. THIS ARGUMENT IS IGNORED IF +C ISPV = 0. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR HAFTON +C +C NOTE THIS ROUTINE PRODUCES A HUGE NUMBER OF +C PLOTTER INSTRUCTIONS PER PICTURE, AVERAGING +C OVER 100,000 LINE-DRAWS PER FRAME WHEN M = N. +C +C +C ENTRY POINTS EZHFTN, HAFTON, ZLSET, GRAY, BOUND, HFINIT +C +C COMMON BLOCKS HAFT01, HAFT02, HAFT03, HAFT04 +C +C REQUIRED LIBRARY GRIDAL, THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS HALF-TONE PICTURE. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY REWRITE OF PHOMAP ORIGINALLY WRITTEN BY +C M. PERRY OF HIGH ALTITUDE OBSERVATORY, +C NCAR. +C +C ALGORITHM BI-LINEAR INTERPOLATION ON PLOTTER +C (RESOLUTION-LIMITED) GRID OF NORMALIZED +C REPRESENTATION OF DATA. +C +C PORTABILITY ANSI FORTRAN 77. +C +C +C +C INTERNAL PARAMTERSS +C VALUES SET IN BLOCK DATA +C NAME DEFAULT FUNCTION +C ---- ------- ________ +C +C XLT 0.1 LEFT-HAND EDGE OF THE PLOT WHEN NSET=0. (0.0= +C LEFT EDGE OF FRAME, 1.0=RIGHT EDGE OF FRAME.) +C YBT 0.1 BOTTOM EDGE OF THE PLOT WHEN NSET=0. (0.0= +C BOTTOM OF FRAME, 1.0=TOP OF FRAME.) +C SIDE 0.8 LENGTH OF LONGER EDGE OF PLOT (SEE ALSO EXT). +C EXT .25 LENGTHS OF THE SIDES OF THE PLOT ARE PROPOR- +C TIONAL TO M AND N (WHEN NSET=0) EXCEPT IN +C EXTREME CASES, NAMELY, WHEN MIN(M,N)/MAX(M,N) +C IS LESS THAN EXT. THEN A SQUARE PLOT IS PRO- +C DUCED. WHEN A RECTANGULAR PLOT IS PRODUCED, +C THE PLOT IS CENTERED ON THE FRAME (AS LONG AS +C SIDE+2*XLT = SIDE+2*YBT=1., AS WITH THE +C DEFAULTS.) +C ALPHA 1.6 A PARAMETER TO CONTROL THE EXTREMENESS OF THE +C MAPPING FUNCTION SPECIFIED BY NOPT. (FOR +C IABS(NOPT)=0 OR 1, THE MAPPING FUNCTION IS +C LINEAR AND INDEPENDENT OF ALPHA.) FOR THE NON- +C LINEAR MAPPING FUNCTIONS, WHEN ALPHA IS CHANGED +C TO A NUMBER CLOSER TO 1., THE MAPPING FUNCTION +C BECOMES MORE LINEAR; WHEN ALPHA IS CHANGED TO +C A LARGER NUMBER, THE MAPPING FUNCTION BECOMES +C MORE EXTREME. +C MXLEV 16 MAXIMUM NUMBER OF LEVELS. LIMITED BY PLOTTER. +C NCRTG 8 NUMBER OF CRT UNITS PER GRAY-SCALE CELL. +C LIMITED BY PLOTTER. +C NCRTF 1024 NUMBER OF PLOTTER ADDRESS UNITS PER FRAME. +C IL (BELOW) AN ARRAY DEFINING WHICH OF THE AVAILABLE IN- +C TENSITIES ARE USED WHEN LESS THAN THE MAXIMUM +C NUMBER OF INTENSITIES ARE REQUESTED. +C +C +C NLEV INTENSITIES USED +C ____ ________________ +C 2 5,11, +C 3 4, 8,12, +C 4 3, 6,10,13, +C 5 2, 5, 8,11,14, +C 6 1, 4, 7, 9,12,15, +C 7 1, 4, 6, 8,10,12,15, +C 8 1, 3, 5, 7, 9,11,13,15, +C 9 1, 3, 4, 6, 8,10,12,13,15 +C 10 1, 3, 4, 6, 7, 9,10,12,13,15, +C 11 1, 2, 3, 5, 6, 8,10,11,13,14,15, +C 12 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +C 13 1, 2, 3, 4, 6, 7, 8, 9,10,12,13,14,15 +C 14 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +C 15 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +C 16 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15 +C +C + + SAVE + DIMENSION Z(L,N) ,PX(2) ,PY(2) + DIMENSION ZLEV(16) ,VWPRT(4) ,WNDW(4) + DIMENSION VWPR2(4) ,WND2(4) + CHARACTER*11 IDUMMY +C +C + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT , + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +NOAO - Blockdata rewritten as run time initialization subroutine +C +C EXTERNAL HFINIT + call hfinit +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','HAFTON','VERSION 1') +C + NPOINT = 0 + ALPHA = ALPH + GLO = FLO + HA = HI + NLEVL = MIN0(IABS(NLEV),MXLEV) + IF (NLEVL .LE. 1) NLEVL = MXLEV + NOPTN = NOPT + IF (NOPTN .EQ. 0) NOPTN = 1 + NPRIM = NPRM + NSPV = MAX0(MIN0(ISPV,4),0) + IF (NSPV .NE. 0) SP = SPVAL + MX = L + NX = M + NY = N + CRTF = NCRTF + MSPV = 0 +C +C SET INTENSITY BOUNDARY LEVELS +C + CALL ZLSET (Z,MX,NX,NY,ZLEV,NLEVL) +C +C SET UP PERIMETER +C + X3 = NX + Y3 = NY + CALL GQCNTN (IERR,NTORIG) + CALL GETUSV('LS',IOLLS) + IF (NPRIM.LT.0) THEN + CALL GQNT (NTORIG,IERR,WNDW,VWPRT) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + ELSE IF (NPRIM.EQ.0) THEN + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .GE. EXT) THEN + IF (NX-NY.LT.0) THEN + X2 =SIDE*X3/Y3+XLT + X2 = (AINT(X2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + ELSE IF (NX-NY.GT.0) THEN + Y2 = SIDE*Y3/X3+YBT + Y2 = (AINT(Y2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + END IF + END IF + ELSE IF (NPRIM.GT.0) THEN + X1 = 0.0 + X2 = 1.0 + Y1 = 0.0 + Y2 = 1.0 + END IF + MX1 = X1*CRTF + MX2 = X2*CRTF + MY1 = Y1*CRTF + MY2 = Y2*CRTF + IF (NPRIM.GT.0) THEN + MX1 = 1 + MY1 = 1 + MX2 = NCRTF + MY2 = NCRTF + END IF +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING FOR USE WITH PERIM +C DRAW PERIMETER IF NPRIM EQUALS 0 +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + IF (NPRIM .EQ. 0) CALL PERIM (NX-1,1,NY-1,1) + IF (ICNST .NE. 0) THEN + CALL GSELNT (0) + CALL WTSTR(XLT*1.1,0.5,'CONSTANT FIELD',2,0,0) + GO TO 132 + END IF +C +C FIND OFFSET FOR REFERENCE TO IL, WHICH IS TRIANGULAR +C + IOFFST = NLEVL*((NLEVL-1)/2)+MOD(NLEVL-1,2)*(NLEVL/2)-1 +C +C OUTPUT INTENSITY SCALE +C + IF (NPRIM .GT. 0) GO TO 112 + LEV = 0 + KX = (1.1*XLT+SIDE)*CRTF + KY = YBT*CRTF + NNX = KX/NCRTG + 109 LEV = LEV+1 +C +NOAO +C The following statement moved from after statement label 111 (CONTINUE) to +C here. Otherwise an extra (unlabelled) grayscale box was being drawn. +C This was (eventually) causing a [floating operand error] on a Sun-3. + IF (LEV .GT. NLEVL) GO TO 112 +C -NOAO + ISUB = IOFFST+LEV + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + NNY = KY/NCRTG + DO 111 JJ=1,3 + DO 110 II=1,10 + I = NNX+II + J = NNY+JJ + CALL GRAY + 110 CONTINUE + 111 CONTINUE +C +NOAO - FTN internal write rewritten as call to encode. +C WRITE(IDUMMY,'(G11.4)') ZLEV(LEV) + call encode (11, '(g11.4)', idummy, zlev(lev)) +C -NOAO + TKX = KX + TKY = KY+38 + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL WTSTR (TKX,TKY,IDUMMY,0,0,-1) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) +C +C ADJUST 38 TO PLOTTER. +C + KY = KY+52 +C +C ADJUST 52 TO PLOTTER. +C + GO TO 109 +C +C STEP THROUGH PLOTTER GRID OF INTENSITY CELLS. +C + 112 IMIN = (MX1-1)/NCRTG+1 + IMAX = (MX2-1)/NCRTG + JMIN = (MY1-1)/NCRTG+1 + JMAX = (MY2-1)/NCRTG + XL = IMAX-IMIN+1 + YL = JMAX-JMIN+1 + XN = NX + YN = NY + LSRT = NLEVL/2 + DO 130 J=JMIN,JMAX +C +C FIND Y FOR THIS J AND Z FOR THIS Y. +C + YJ = (FLOAT(J-JMIN)+.5)/YL*(YN-1.)+1. + LOWY = YJ + YPART = YJ-FLOAT(LOWY) + IF (LOWY .NE. NY) GO TO 113 + LOWY = LOWY-1 + YPART = 1. + 113 IPEN = 0 + ZLFT = Z(1,LOWY)+YPART*(Z(1,LOWY+1)-Z(1,LOWY)) + ZRHT = Z(2,LOWY)+YPART*(Z(2,LOWY+1)-Z(2,LOWY)) + IF (NSPV .EQ. 0) GO TO 114 + IF (Z(1,LOWY).EQ.SP .OR. Z(2,LOWY).EQ.SP .OR. + 1 Z(1,LOWY+1).EQ.SP .OR. Z(2,LOWY+1).EQ.SP) IPEN = 1 + 114 IF (IPEN .EQ. 1) GO TO 117 +C +C FIND INT FOR THIS Z. +C + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 + 115 IF (ZLFT .GE. ZLEV(LSRT)) GO TO 117 +C +C LOOK LOWER +C + IF (LSRT .LE. 1) GO TO 117 + LSRT = LSRT-1 + GO TO 115 +C +C LOOK HIGHER +C + 116 IF (LSRT .GE. NLEVL) GO TO 117 + LSRT = LSRT+1 + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 +C +C OK +C + 117 IRHT = 2 + LAST = LSRT + DO 129 I=IMIN,IMAX +C +C FIND X FOR THIS I AND Z FOR THIS X AND Y. +C + IADD = 1 + XI = (FLOAT(I-IMIN)+.5)/XL*(XN-1.)+1. + LOWX = XI + XPART = XI-FLOAT(LOWX) + IF (LOWX .NE. NX) GO TO 118 + LOWX = LOWX-1 + XPART = 1. +C +C TEST FOR INTERPOLATION POSITIONING +C + 118 IF (LOWX .LT. IRHT) GO TO 119 +C +C MOVE INTERPOLATION ONE CELL TO THE RIGHT +C + ZLFT = ZRHT + IRHT = IRHT+1 + ZRHT = Z(IRHT,LOWY)+YPART*(Z(IRHT,LOWY+1)-Z(IRHT,LOWY)) + IF (NSPV .EQ. 0) GO TO 118 + IPEN = 0 + IF (Z(IRHT-1,LOWY).EQ.SP .OR. Z(IRHT,LOWY).EQ.SP .OR. + 1 Z(IRHT-1,LOWY+1).EQ.SP .OR. Z(IRHT,LOWY+1).EQ.SP) + 2 IPEN = 1 + GO TO 118 + 119 IF (IPEN .NE. 1) GO TO 123 +C +C SPECIAL VALUE AREA +C + GO TO (129,120,121,122),NSPV + 120 MSPV = 1 + GO TO 129 + 121 PX(1) = I*NCRTG + PY(1) = J*NCRTG + PX(2) = PX(1)+NCRTG-1 + PY(2) = PY(1)+NCRTG-1 + CALL GPL (2,PX,PY) + PYTMP = PY(1) + PY(1) = PY(2) + PY(2) = PYTMP + CALL GPL (2,PX,PY) +C + GO TO 129 + 122 INTEN = MXLEV + GO TO 128 + 123 ZZ = ZLFT+XPART*(ZRHT-ZLFT) +C +C TEST FOR SAME INT AS LAST TIME. +C + IF (ZZ .GT. ZLEV(LAST+1)) GO TO 126 + 124 IF (ZZ .GE. ZLEV(LAST)) GO TO 127 +C +C LOOK LOWER +C + IF (LAST .LE. 1) GO TO 125 + LAST = LAST-1 + GO TO 124 + 125 IF (ZZ .LT. ZLEV(LAST)) IADD = 0 + GO TO 127 +C +C LOOK HIGHER +C + 126 IF (LAST .GE. NLEVL) GO TO 127 + LAST = LAST+1 + IF (ZZ .GE. ZLEV(LAST+1)) GO TO 126 +C +C OK +C + 127 ISUB = LAST+IOFFST+IADD + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + 128 CALL GRAY + 129 CONTINUE + 130 CONTINUE +C +C PUT OUT ANY REMAINING BUFFERED POINTS. +C + IF (NPOINT.GT.0) THEN + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) + ENDIF +C +C CALL BOUND IF ISPV=2 AND SPECIAL VALUES WERE FOUND. +C + IF (MSPV .EQ. 1) THEN + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + CALL BOUND (Z,MX,NX,NY,SP) + END IF + 132 CONTINUE +C +C RESTORE NORMALIZATION TRANS 1 AND ORIGINAL NORMALIZATION NUMBER +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL SETUSV('LS',IOLLS) + CALL GSELNT (NTORIG) + RETURN +C + END + SUBROUTINE ZLSET (Z,MX,NX,NY,ZL,NLEVL) + SAVE +C + DIMENSION Z(MX,NY) ,ZL(NLEVL) +C + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST +C + BIG = R1MACH(2) +C +C ZLSET PUTS THE INTENSITY LEVEL BREAK POINTS IN ZL. +C ALL ARGUMENTS ARE AS IN HAFTON. +C + LX = NX + LY = NY + NLEV = NLEVL + NOPT = IABS(NOPTN) + RALPH = 1./ALPHA + ICNST = 0 + IF (GLO.NE.0. .OR. HA.NE.0.) GO TO 106 +C +C FIND RANGE IF NOT KNOWN. +C + GLO = BIG + HA = -GLO + IF (NSPV .NE. 0) GO TO 103 + DO 102 J=1,LY + DO 101 I=1,LX + ZZ = Z(I,J) + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 101 CONTINUE + 102 CONTINUE + GO TO 106 + 103 DO 105 J=1,LY + DO 104 I=1,LX + ZZ = Z(I,J) + IF (ZZ .EQ. SP) GO TO 104 + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 104 CONTINUE + 105 CONTINUE +C +C FILL ZL +C + 106 DELZ = HA-GLO + IF (DELZ .EQ. 0.) GO TO 115 + DZ = DELZ/FLOAT(NLEV) + NLEVM1 = NLEV-1 + DO 114 K=1,NLEVM1 + ZNORM = FLOAT(K)/FLOAT(NLEV) + GO TO (107,108,109,110,111),NOPT +C +C NOPT=1 +C + 107 ZL(K) = GLO+FLOAT(K)*DZ + GO TO 114 +C +C NOPT=2 +C + 108 ONORM = (1.-(1.-ZNORM)**ALPHA)**RALPH + GO TO 113 +C +C NOPT=3 +C + 109 ONORM = 1.-(1.-ZNORM**ALPHA)**RALPH + GO TO 113 +C +C NOPT=4 +C + 110 ONORM = .5*(1.-(ABS(ZNORM+ZNORM-1.))**ALPHA)**RALPH + GO TO 112 +C +C NOPT=5 +C + 111 ZNORM2 = ZNORM+ZNORM + IF (ZNORM .GT. .5) ZNORM2 = 2.-ZNORM2 + ONORM = .5*(1.-(1.-ABS(ZNORM2)**ALPHA)**RALPH) + 112 IF (ZNORM .GT. .5) ONORM = 1.-ONORM + 113 ZL(K) = GLO+DELZ*ONORM + 114 CONTINUE + ZL(NLEV) = BIG + RETURN + 115 ICNST = 1 + RETURN + END + SUBROUTINE GRAY +C +C SUBROUTINE GRAY COLORS HALF-TONE CELL (I,J) WITH INTENSITY INTEN. +C THE ROUTINE ASSUMES 8X8 CELL SIZE ON A VIRTUAL SCREEN 1024X1024. +C + DIMENSION IFOT(16) ,JFOT(16) + DIMENSION WNDW(4) ,VWPRT(4) +CCC DIMENSION MX(16) ,MY(16) + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) + SAVE +C + DATA + 1 IFOT(1),IFOT(2),IFOT(3),IFOT(4),IFOT(5),IFOT(6),IFOT(7),IFOT(8)/ + 2 1, 5, 1, 5, 3, 7, 3, 7 / + DATA + 1 IFOT(9),IFOT(10),IFOT(11),IFOT(12),IFOT(13),IFOT(14),IFOT(15)/ + 2 3, 7, 3, 7, 1, 5, 1/, + 3 IFOT(16)/ + 4 5 / +C + DATA + 1 JFOT(1),JFOT(2),JFOT(3),JFOT(4),JFOT(5),JFOT(6),JFOT(7),JFOT(8)/ + 2 1, 5, 5, 1, 3, 7, 7, 3 / + DATA + 1 JFOT(9),JFOT(10),JFOT(11),JFOT(12),JFOT(13),JFOT(14),JFOT(15)/ + 2 1, 5, 5, 1, 3, 7, 7/, + 3 JFOT(16)/ + 4 3 / +C + IF (INTEN) 103,103,101 + 101 I1 = I*8 + J1 = J*8 + IF ((NPOINT+INTEN) .LE.NPTMAX) GO TO 1015 + CALL GQNT(1,IERR,WNDW,VWPRT) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),1) + NPOINT = 0 + 1015 DO 102 I2=1,INTEN + NPOINT = NPOINT + 1 + XPNT(NPOINT) = I1+IFOT(I2) + YPNT(NPOINT) = J1+JFOT(I2) + 102 CONTINUE + 103 RETURN + END + SUBROUTINE BOUND (Z,MX,NNX,NNY,SSP) + DIMENSION Z(MX,NNY) ,PX(2) ,PY(2) +C +C BOUND DRAWS A POLYGONAL BOUNDRY AROUND ANY SPECIAL-VALUE AREAS IN Z. +C + SAVE + NX = NNX + NY = NNY +C +C VERTICAL LINES +C + SP = SSP + DO 103 IP1=3,NX + I = IP1-1 + PX(1) = I + PX(2) = I + IM1 = I-1 + DO 102 JP1=2,NY + PY(2) = JP1 + J = JP1-1 + PY(1) = J + KLEFT = 0 + IF (Z(IM1,J).EQ.SP .OR. Z(IM1,JP1).EQ.SP) KLEFT = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(I,JP1).EQ.SP) KCENT = 1 + KRIGT = 0 + IF (Z(IP1,J).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KRIGT = 1 + JUMP = KLEFT*4+KCENT*2+KRIGT+1 + GO TO (102,101,102,102,101,102,102,102,102),JUMP + 101 CALL GPL (2,PX,PY) + 102 CONTINUE + 103 CONTINUE +C +C HORIZONTAL +C + DO 106 JP1=3,NY + J = JP1-1 + PY(1) = J + PY(2) = J + JM1 = J-1 + DO 105 IP1=2,NX + PX(2) = IP1 + I = IP1-1 + PX(1) = I + KLOWR = 0 + IF (Z(I,JM1).EQ.SP .OR. Z(IP1,JM1).EQ.SP) KLOWR = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(IP1,J).EQ.SP) KCENT = 1 + KUPER = 0 + IF (Z(I,JP1).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KUPER = 1 + JUMP = KLOWR*4+KCENT*2+KUPER+1 + GO TO (105,104,105,105,104,105,105,105,105),JUMP + 104 CALL GPL (2,PX,PY) + 105 CONTINUE + 106 CONTINUE + RETURN + END + SUBROUTINE EZHFTN (Z,M,N) +C + DIMENSION Z(M,N) + SAVE +C +C HALF-TONE PICTURE VIA SHORTEST ARGUMENT LIST. +C ASSUMPTIONS-- +C ALL OF THE ARRAY IS TO BE DRAWN, +C LOWEST VALUE IN Z WILL BE AT LOWEST INTENSITY ON READER/PRINTER +C OUTPUT, HIGHEST VALUE IN Z WILL BE AT HIGHEST INTENSITY, VALUES IN +C BETWEEN WILL APPEAR LINEARLY SPACED, MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED, THE PICTURE WILL HAVE A PERIMETER DRAWN, +C FRAME WILL BE CALLED AFTER THE PICTURE IS DRAWN, Z IS FILLED WITH +C NUMBERS THAT SHOULD BE USED (NO UNKNOWN VALUES). +C IF THESE CONDITIONS ARE NOT MET, USE HAFTON. +C EZHFTN ARGUMENTS-- +C Z 2 DIMENSIONAL ARRAY TO BE USED TO GENERATE A HALF-TONE PLOT. +C M FIRST DIMENSION OF Z. +C N SECOND DIMENSION OF Z. +C + DATA FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV/0.0,0.0,0,0,0,0,0.0/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','EZHFTN','VERSION 1') +C + CALL HAFTON (Z,M,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV) +C +C +NOAO - EZHFTN no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C----------------------------------------------------------------------- +C +C REVISION HISTORY--- +C +C JULY 1984 CONVERTED TO FORTAN 77 AND GKS +C +C MARCH 1983 INSTITUTED BUFFERING OF POINTS WITHIN ROUTINE GRAY, +C WHICH DRAMATICALLY REDUCES SIZE OF OUTPUT PLOT CODE, +C METACODE. THIS IN TURN GENERALLY IMPROVES THROUGHPUT +C OF METACODE INTERPRETERS. +C +C FEBRUARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C +C----------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/hfinit.f b/sys/gio/ncarutil/hfinit.f new file mode 100644 index 00000000..e64207eb --- /dev/null +++ b/sys/gio/ncarutil/hfinit.f @@ -0,0 +1,229 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data hfinit changed to run time initialization +c BLOCKDATA HFINIT + subroutine hfinit +C + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT, + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA XLT, YBT,SIDE,EXT,IOFFM,ALPH,MXLEV,NCRTG,NCRTF/ +c 1 0.102,0.102,.805,.25, 0, 1.6, 16, 8, 1024/ +c +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c +noao: call to utilbd added to make sure those parameters set by getusv +c have been set before they are retrieved. + call utilbd +c -noao + XLT = 0.102 + YBT = 0.102 + SIDE = .805 + EXT = .25 + IOFFM = 0 + ALPH = 1.6 + MXLEV = 16 + NCRTG = 8 + NCRTF = 1024 +c +c DATA IL(1),IL(2),IL(3),IL(4),IL(5),IL(6),IL(7),IL(8),IL(9),IL(10), +c 1IL(11),IL(12),IL(13),IL(14),IL(15),IL(16),IL(17),IL(18),IL(19), +c 2IL(20),IL(21),IL(22),IL(23),IL(24),IL(25),IL(26),IL(27),IL(28), +c 3IL(29),IL(30),IL(31),IL(32),IL(33),IL(34),IL(35),IL(36),IL(37), +c 4IL(38),IL(39),IL(40),IL(41),IL(42),IL(43),IL(44)/ +c 5 5,11, +c 6 4, 8,12, +c 7 3, 6,10,13, +c 8 2, 5, 8,11,14, +c 9 1, 4, 7, 9,12,15, +c + 1, 4, 6, 8,10,12,15, +c 1 1, 3, 5, 7, 9,11,13,15, +c 2 1, 3, 4, 6, 8, 10, 12, 13, 15/ +c + IL(1) = 5 + IL(2) = 11 + IL(3) = 4 + IL(4) = 8 + IL(5) = 12 + IL(6) = 3 + IL(7) = 6 + IL(8) = 10 + IL(9) = 13 + IL(10) = 2 + IL(11) = 5 + IL(12) = 8 + IL(13) = 11 + IL(14) = 14 + IL(15) = 1 + IL(16) = 4 + IL(17) = 7 + IL(18) = 9 + IL(19) = 12 + IL(20) = 15 + IL(21) = 1 + IL(22) = 4 + IL(23) = 6 + IL(24) = 8 + IL(25) = 10 + IL(26) = 12 + IL(27) = 15 + IL(28) = 1 + IL(29) = 3 + IL(30) = 5 + IL(31) = 7 + IL(32) = 9 + IL(33) = 11 + IL(34) = 13 + IL(35) = 15 + IL(36) = 1 + IL(37) = 3 + IL(38) = 4 + IL(39) = 6 + IL(40) = 8 + IL(41) = 10 + IL(42) = 12 + IL(43) = 13 + IL(44) = 15 +c +c DATA IL(45),IL(46), +c 1IL(47),IL(48),IL(49),IL(50),IL(51),IL(52),IL(53),IL(54),IL(55), +c 2IL(56),IL(57),IL(58),IL(59),IL(60),IL(61),IL(62),IL(63),IL(64), +c 3IL(65),IL(66),IL(67),IL(68),IL(69),IL(70),IL(71),IL(72),IL(73), +c 4IL(74),IL(75),IL(76),IL(77),IL(78),IL(79),IL(80),IL(81),IL(82), +c 5IL(83),IL(84),IL(85),IL(86),IL(87),IL(88),IL(89),IL(90)/ +c 6 1, 3, 4, 6, 7, 9,10,12,13,15, +c 7 1, 2, 3, 5, 6, 8,10,11,13,14,15, +c 8 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +c 9 1, 2, 3, 4, 6, 7, 8, 9, 10, 12, 13, 14, 15/ +c + IL(45) = 1 + IL(46) = 3 + IL(47) = 4 + IL(48) = 6 + IL(49) = 7 + IL(50) = 9 + IL(51) = 10 + IL(52) = 12 + IL(53) = 13 + IL(54) = 15 + IL(55) = 1 + IL(56) = 2 + IL(57) = 3 + IL(58) = 5 + IL(59) = 6 + IL(60) = 8 + IL(61) = 10 + IL(62) = 11 + IL(63) = 13 + IL(64) = 14 + IL(65) = 15 + IL(66) = 1 + IL(67) = 2 + IL(68) = 3 + IL(69) = 5 + IL(70) = 6 + IL(71) = 7 + IL(72) = 9 + IL(73) = 10 + IL(74) = 11 + IL(75) = 13 + IL(76) = 14 + IL(77) = 15 + IL(78) = 1 + IL(79) = 2 + IL(80) = 3 + IL(81) = 4 + IL(82) = 6 + IL(83) = 7 + IL(84) = 8 + IL(85) = 9 + IL(86) = 10 + IL(87) = 12 + IL(88) = 13 + IL(89) = 14 + IL(90) = 15 +c +c DATA IL(91), +c 1IL(92),IL(93),IL(94),IL(95),IL(96),IL(97),IL(98),IL(99),IL(100), +c 2IL(101),IL(102),IL(103),IL(104),IL(105),IL(106),IL(107),IL(108), +c 3IL(109),IL(110),IL(111),IL(112),IL(113),IL(114),IL(115),IL(116), +c 4IL(117),IL(118),IL(119),IL(120),IL(121),IL(122),IL(123),IL(124), +c 5IL(125),IL(126),IL(127),IL(128),IL(129),IL(130),IL(131),IL(132), +c 6IL(133),IL(134),IL(135)/ +c 7 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +c 8 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +c 9 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15/ +c + IL(91) = 1 + IL(92) = 2 + IL(93) = 3 + IL(94) = 4 + IL(95) = 5 + IL(96) = 6 + IL(97) = 7 + IL(98) = 9 + IL(99) = 10 + IL(100) = 11 + IL(101) = 12 + IL(102) = 13 + IL(103) = 14 + IL(104) = 15 + IL(105) = 1 + IL(106) = 2 + IL(107) = 3 + IL(108) = 4 + IL(109) = 5 + IL(110) = 6 + IL(111) = 7 + IL(112) = 8 + IL(113) = 9 + IL(114) = 10 + IL(115) = 11 + IL(116) = 12 + IL(117) = 13 + IL(118) = 14 + IL(119) = 15 + IL(120) = 0 + IL(121) = 1 + IL(122) = 2 + IL(123) = 3 + IL(124) = 4 + IL(125) = 5 + IL(126) = 6 + IL(127) = 7 + IL(128) = 8 + IL(129) = 9 + IL(130) = 10 + IL(131) = 11 + IL(132) = 12 + IL(133) = 13 + IL(134) = 14 + IL(135) = 15 +c +C SIZE OF THE COORDINATE BUFFERING ARRAYS FOR POINTS BUFFERING. +c DATA NPTMAX/50/ + NPTMAX = 50 +c -noao + END diff --git a/sys/gio/ncarutil/isosrb.f b/sys/gio/ncarutil/isosrb.f new file mode 100644 index 00000000..5c1481a0 --- /dev/null +++ b/sys/gio/ncarutil/isosrb.f @@ -0,0 +1,98 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: blockdata isosrb changed to run time initialization subroutine + subroutine isosrb +c BLOCKDATA ISOSRB +C +C BLOCK DATA +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY, + 1 IS ,ISS ,NP ,CV, + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD, + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX, + 2 IFSY ,FIRST ,IYDIR ,IHX, + 3 IHB ,IHS ,IHV ,IVOLD, + 4 IVAL ,IHRX ,YCHANG ,ITPD, + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + COMMON /TEMPR/ RZERO + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C + logical first1 + SAVE + data first1 /.true./ + if (.not. first1) then + return + endif + first1 = .false. +c +c DATA LX,NX,NY/8,128,128/ + LX = 8 + NX = 128 + NY = 128 +c +c DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +c 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +c +c DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +c 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +c +c DATA NR/500/ + NR = 500 +c +c DATA NBPW/16/ + NBPW = 16 +c +c DATA IHF/.FALSE./ + IHF = .FALSE. +C +c DATA GENDON /.FALSE./ + GENDON = .FALSE. +c +c DATA RZERO/0./ + RZERO = 0. +C +C +C RX = (NX-1)/SCREEN WIDTH FROM TRN32I +C RY = (NY-1)/SCREEN HEIGHT FROM TRN32I +C +c DATA RX,RY/.00389,.00389/ + RX = .00389 + RY = .00389 +C +c -noao + END diff --git a/sys/gio/ncarutil/isosrf.f b/sys/gio/ncarutil/isosrf.f new file mode 100644 index 00000000..7be532ee --- /dev/null +++ b/sys/gio/ncarutil/isosrf.f @@ -0,0 +1,1696 @@ + SUBROUTINE ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C DIMENSION OF T(LU,LV,MW),EYE(3),SLAB(MUVWP2,MUVWP2) +C ARGUMENTS +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE ISOSRF DRAWS AN APPROXIMATION OF AN ISO-VALUED +C SURFACE FROM A THREE-DIMENSIONAL ARRAY WITH +C HIDDEN LINES REMOVED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C +C ASSUMPTIONS: +C -- ALL OF THE T ARRAY IS TO BE USED. +C -- IFLAG IS CHOSEN INTERNALLY. +C -- FRAME IS CALLED BY EZISOS. +C +C IF THE ASSUMPTIONS ARE NOT MET, USE +C +C CALL ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2, +C SLAB,TISO,IFLAG) +C +C ARGUMENTS +C +C ON INPUT T +C THREE DIMENSIONAL ARRAY OF DATA THAT DEFINES +C THE ISO-VALUED SURFACE. +C +C LU +C FIRST DIMENSION OF T IN THE CALLING PROGRAM. +C +C MU +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE U DIRECTION (THE FIRST +C SUBSCRIPT DIRECTION). WHEN PROCESSING THE +C ENTIRE ARRAY, LU = MU (AND LV = MV). +C +C LV +C SECOND DIMENSION OF T IN THE CALLING PROGRAM. +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE V DIRECTION (THE SECOND +C SUBSCRIPT DIRECTION). +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE W DIRECTION (THE THIRD +C SUBSCRIPT DIRECTION). +C +C EYE +C THE POSITION OF THE EYE IN THREE-SPACE. T IS +C CONSIDERED TO BE IN A BOX WITH OPPOSITE +C CORNERS (1,1,1) AND (MU,MV,MW). THE EYE IS +C AT (EYE(1),EYE(2),EYE(3)), WHICH MUST BE +C OUTSIDE THE BOX THAT CONTAINS T. WHILE GAINING +C EXPERIENCE WITH THE ROUTINE, A GOOD CHOICE +C FOR EYE MIGHT BE (5.0*MU,3.5*MV,2.0*MW). +C +C MUVWP2 +C THE MAXIMUM OF (MU,MV,MW)+2; THAT IS, +C MUVWP2 = MAX(MU,MV,MW)+2). +C +C SLAB +C A WORK SPACE USED FOR INTERNAL STORAGE. SLAB +C MUST BE AT LEAST MUVWP2*MUVWP2 WORDS LONG. +C +C TISO +C THE ISO-VALUE USED TO DEFINE THE SURFACE. THE +C SURFACE DRAWN WILL SEPARATE VOLUMES OF T THAT +C HAVE VALUES GREATER THAN OR EQUAL TO TISO FROM +C VOLUMES OF T THAT HAVE VALUES LESS THAN TISO. +C +C IFLAG +C THIS FLAG SERVES TWO PURPOSES. +C . FIRST, THE ABSOLUTE VALUE OF IFLAG +C DETERMINES WHICH TYPES OF LINES ARE DRAWN +C TO APPROXIMATE THE SURFACE. THREE TYPES +C OF LINES ARE CONSIDERED: LINES OF +C CONSTANT U, LINES OF CONSTANT V AND LINES +C OF CONSTANT W. THE FOLLOWING TABLE LISTS +C THE TYPES OF LINES DRAWN. +C +C LINES OF CONSTANT +C ----------------- +C IABS(IFLAG) U V W +C ----------- --- --- --- +C 1 NO NO YES +C 2 NO YES NO +C 3 NO YES YES +C 4 YES NO NO +C 5 YES NO YES +C 6 YES YES NO +C 0, 7 OR MORE YES YES YES +C +C . SECOND, THE SIGN OF IFLAG DETERMINES WHAT +C IS INSIDE AND WHAT IS OUTSIDE, HENCE, +C WHICH LINES ARE VISIBLE AND WHAT IS DONE +C AT THE BOUNDARY OF T. FOR IFLAG: +C +C POSITIVE T VALUES GREATER THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C NEGATIVE T VALUES LESS THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C IF THE ALGORITHM DRAWS A CUBE, REVERSE THE +C SIGN OF IFLAG. +C +C ON OUTPUT T,LU,MU,LV,MV,MW,EYE,MUVWP2,TISO AND IFLAG ARE +C UNCHANGED. SLAB HAS BEEN WRITTEN IN. +C +C NOTE . THIS ROUTINE IS FOR LOWER RESOLUTION ARRAYS +C THAN ISOSRFHR. 40 BY 40 BY 40 IS A +C PRACTICAL MAXIMUM. +C . TRANSFORMATIONS CAN BE ACHIEVED BY +C ADJUSTING SCALING STATEMENT FUNCTIONS IN +C ISOSRF, SET3D AND TR32. +C . THE HIDDEN-LINE ALGORITHM IS NOT EXACT, SO +C VISIBILITY ERRORS CAN OCCUR. +C . THREE-DIMENSIONAL PERSPECTIVE CHARACTER +C LABELING OF ISOSRF IS POSSIBLE BY USING +C THE UTILITY PWRZI. FOR A DESCRIPTION OF +C THE USAGE, SEE THE PWRZI DOCUMENTATION. +C +C ENTRY POINTS ISOSRF, EZISOS, SET3D, TRN32I, ZEROSC, +C STCNTR, DRCNTR, TR32, FRSTS, KURV1S, KURV2S, +C FRSTC, FILLIN, DRAWI, ISOSRB, MMASK +C +C COMMON BLOCKS ISOSR1, ISOSR2, ISOSR3, ISOSR4, ISOSR5, +C ISOSR6, ISOSR7, ISOSR8, ISOSR9, TEMPR, +C PWRZ1I +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SURFACE +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED FOR USERS OF ISOSRFHR WITH SMALLER +C ARRAYS. +C +C ALGORITHM CUTS THROUGH THE THREE-DIMENSIONAL ARRAY ARE +C CONTOURED WITH A SMOOTHING CONTOURER WHICH ALSO +C MARKS A MODEL OF THE PLOTTING PLANE. INTERIORS +C OF BOUNDARIES ARE FILLED IN AND THE RESULT IS +C .OR.ED INTO ANOTHER MODEL OF THE PLOTTING PLANE +C WHICH IS USED TO TEST SUBSEQUENT CONTOUR LINES +C FOR VISIBILITY. +C +C TIMING VARIES WIDELY WITH SIZE OF T AND THE VOLUME OF +C THE SPACE ENCLOSED BY THE SURFACE DRAWN. +C +C **NOTE** SPACE REQUIREMENTS CAN BE REDUCED BY +C CHANGING THE SIZE OF THE ARRAYS ISCR, ISCA +C (FOUND IN COMMON ISOSR2), MASK(FOUND IN +C COMMON ISOSR5) AND THE VARIABLE NBPW +C (COMMON ISOSR5). +C ISCR AND ISCA NEED 128X128 BITS. SO ON A +C 64 BIT MACHINE ISCR, ISCA CAN BE +C DIMENSIONED TO (2,128). NBPW SET IN +C SUBROUTINE MMASK SHOULD CONTAIN THE +C NUMBER OF BITS PER WORD YOU WISH TO +C UTILIZE. +C THE DIMENSION OF MASK AND NMASK SHOULD +C EQUAL THE VALUE OF NBPW. +C LS SHOULD BE SET TO THE FIRST DIMENSION +C OF ISCA AND ISCR. +C +C EXAMPLES: +C ON A 60 BIT MACHINE: +C DIMENSION ISCA(4,128), ISCR(4,128) +C DIMENSION MASK(32) +C NBPW = 32 +C ON A 64 BIT MACHINE: +C DIMENSION ISCA(2,128), ISCR(2,128) +C DIMENSION MASK(64) +C NBPW = 64 +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IREF 1 FLAG TO CONTROL DRAWING OF AXES. +C .IREF=NONZERO DRAW AXES. +C .IREF=ZERO DO NOT DRAW AXES. +C +C + SAVE + DIMENSION T(LU,LV,MW),EYE(3) ,SLAB(MUVWP2,MUVWP2) +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL GENDON + DATA IREF/1/ +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata ISOSRB rewritten as run time initialization +C EXTERNAL ISOSRB + call isosrb +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','ISOSRF','VERSION 12') + NERR = 0 +C +C 3-SPACE U,V,W,IU,IV,IW,ETC +C 2-SPACE X,Y,IX,IY,ETC +C +C INITIALIZE MASKS +C + IF (.NOT.GENDON) CALL MMASK +C +C SET SHIFT VALUE FOR X,Y PACKING +C +C IF YOUR MACHINE HAS MORE THAN 16 BITS PER WORD THIS CHECK MAY BE +C MODIFIED +C + IF (LU .LE. 256) GO TO 10 + NERR = NERR + 1 + CALL SETER('DIMENSION OF CUBE EXCEEDS 256',NERR,2) + RETURN + 10 DO 20 J=1,30 + IF (LU .LE. 2**(J-1)) GO TO 30 + 20 CONTINUE + 30 IXBIT = J + NU = MU + NUP2 = NU+2 + NV = MV + NVP2 = NV+2 + NW = MW + NWP2 = NW+2 + FNU = NU + FNV = NV + FNW = NW + SU1 = SU(1.) + SV1 = SV(1.) + SW1 = SW(1.) + SUNU = SU(FNU) + SVNV = SV(FNV) + SWNW = SW(FNW) + AVEU = AVE(SU1,SUNU) + AVEV = AVE(SV1,SVNV) + AVEW = AVE(SW1,SWNW) + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + NUVWP2 = MUVWP2 + TVAL = TISO + NFLAG = IABS(IFLAG) + IF (NFLAG.EQ.0 .OR. NFLAG.GE.8) NFLAG = 7 +C +C SET UP SCALING +C + FACT = -ISIGN(1,IFLAG) + CALL SET3D (EYE,1.,FNU,1.,FNV,1.,FNW) +C +C BOUND LOWER AND LEFT EDGE OF SLAB +C + EDGE = SIGN(BIG,FACT) + DO 40 IUVW=1,NUVWP2 + SLAB(IUVW,1) = EDGE + SLAB(1,IUVW) = EDGE + 40 CONTINUE +C +C SLICES PERPENDICULAR TO U. THAT IS, V W SLICES. T OF CONSTANT U. +C + IF (NFLAG .LT. 4) GO TO 100 + CALL ZEROSC + ISLBT = -1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 50 IV=2,NVP2 + SLAB(IV,NWP2) = EDGE + 50 CONTINUE + DO 60 IW=2,NWP2 + SLAB(NVP2,IW) = EDGE + 60 CONTINUE +C +C GO THRU 3-D ARRAY IN U DIRECTION. IUEW=IU EITHER WAY. +C PICK IU BASED ON EYEU. +C + DO 90 IUEW=1,NU + IU = IUEW + IF (EYEU .GT. AVEU) IU = NU+1-IUEW + U = IU +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 80 IV=1,NV + DO 70 IW=1,NW + SLAB(IV+1,IW+1) = T(IU,IV,IW) + 70 CONTINUE + 80 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NVP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 90 CONTINUE +C +C SLICES PERPENDICULAR TO V. U W SLICES. T OF CONSTANT V. +C + 100 IF (MOD(NFLAG/2,2) .EQ. 0) GO TO 160 + CALL ZEROSC + ISLBT = 0 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 110 IU=2,NUP2 + SLAB(IU,NWP2) = EDGE + 110 CONTINUE + DO 120 IW=2,NWP2 + SLAB(NUP2,IW) = EDGE + 120 CONTINUE +C +C GO THRU T IN V DIRECTION. IVEW=IV EITHER WAY. +C + DO 150 IVEW=1,NV + IV = IVEW + IF (EYEV .GT. AVEV) IV = NV+1-IVEW + V = IV +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 140 IU=1,NU + DO 130 IW=1,NW + SLAB(IU+1,IW+1) = T(IU,IV,IW) + 130 CONTINUE + 140 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 150 CONTINUE +C +C SLICES PERPENDICULAR TO W. U V SLICES. T OF CONSTANT W. +C + 160 IF (MOD(NFLAG,2) .EQ. 0) GO TO 220 + CALL ZEROSC +C + ISLBT = 1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 170 IU=2,NUP2 + SLAB(IU,NVP2) = EDGE + 170 CONTINUE + DO 180 IV=2,NVP2 + SLAB(NUP2,IV) = EDGE + 180 CONTINUE +C +C GO THRU T IN W DIRECTION. +C + DO 210 IWEW=1,NW + IW = IWEW + IF (EYEW .GT. AVEW) IW = NW+1-IWEW + W = IW +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 200 IU=1,NU + DO 190 IV=1,NV + SLAB(IU+1,IV+1) = T(IU,IV,IW) + 190 CONTINUE + 200 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NVP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 210 CONTINUE +C +C DRAW REFERENCE PLANE EDGES AND W AXIS. +C + 220 IF (IREF .EQ. 0) RETURN + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + IF (EYEV .LT. SV1) GO TO 240 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 230 IU=2,NU + CALL TRN32I (SU(FLOAT(IU)),SV1,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 230 CONTINUE + GO TO 250 + 240 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 250 IF (EYEU .GT. SUNU) GO TO 270 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 260 IV=2,NV + CALL TRN32I (SUNU,SV(FLOAT(IV)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 260 CONTINUE + GO TO 280 + 270 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 280 IF (EYEV .GT. SVNV) GO TO 300 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 290 IUOW=2,NU + CALL TRN32I (SU(FLOAT(NU-IUOW+1)),SVNV,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 290 CONTINUE + GO TO 310 + 300 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 310 IF (EYEU .LT. SU1) GO TO 330 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 320 IVOW=2,NV + CALL TRN32I (SU1,SV(FLOAT(NV-IVOW+1)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 320 CONTINUE + GO TO 340 + 330 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 340 IF (EYEU.LE.SU1 .OR. EYEV.LE.SV1) GO TO 360 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 350 IW=2,NW + CALL TRN32I (SU1,SV1,SW(FLOAT(IW)),XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 350 CONTINUE +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + 360 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SWNW,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + END + SUBROUTINE EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C + SAVE + DIMENSION T(MU,MV,MW),EYE(3) +C + DATA ANG,PI/.35,3.141592/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','EZISOS','VERSION 12') +C +C ARGUMENTS DESCRIBED IN ISOSRF +C +C PICK TYPES OF LINES TO DRAW +C + NU = MU + NV = MV + NW = MW + TVAL = TISO + MAX = MAX0(NU,NV,NW)+2 + ATU = NU/2 + ATV = NV/2 + ATW = NW/2 + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + RU = EYEU-ATU + RV = EYEV-ATV + RW = EYEW-ATW + RU2 = RU*RU + RV2 = RV*RV + RW2 = RW*RW + DU = SQRT(RV2+RW2) + DV = SQRT(RU2+RW2) + DW = SQRT(RU2+RV2) + DR = 1./SQRT(RU2+RV2+RW2) +C +C COMPUTE THE ARCCOSINE +C + TU = DU*DR + ANGU = ATAN(ABS(SQRT(1.-TU*TU)/TU)) + IF (TU .LE. 0.) ANGU = PI-ANGU + TV = DV*DR + ANGV = ATAN(ABS(SQRT(1.-TV*TV)/TV)) + IF (TV .LE. 0.) ANGV = PI-ANGV + TW = DW*DR + ANGW = ATAN(ABS(SQRT(1.-TW*TW)/TW)) + IF (TW .LE. 0.) ANGW = PI-ANGW +C +C BREAK POINT IS ABOUT 20 DEGREES OR ABOUT .35 RADIANS +C + IFLAG = 0 + IF (ANGU .GT. ANG) IFLAG = IFLAG+4 + IF (ANGV .GT. ANG) IFLAG = IFLAG+2 + IF (ANGW .GT. ANG) IFLAG = IFLAG+1 +C +C FIND SIGN OF IFLAG +C + ICNT = 0 + IF (ABS(RU) .LE. ATU) GO TO 30 + IU = 1 + IF (EYEU .GT. ATU) IU = NU + DO 20 IW=1,NW + DO 10 IV=1,NV + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 10 CONTINUE + 20 CONTINUE + 30 IF (ABS(RV) .LE. ATV) GO TO 60 + IV = 1 + IF (EYEV .GT. ATV) IV = NV + DO 50 IW=1,NW + DO 40 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 40 CONTINUE + 50 CONTINUE + 60 IF (ABS(RW) .LE. ATW) GO TO 90 + IW = 1 + IF (EYEW .GT. ATW) IW = NW + DO 80 IV=1,NV + DO 70 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 70 CONTINUE + 80 CONTINUE + 90 IFLAG = ISIGN(IFLAG,ICNT) + CALL ISOSRF (T,NU,NU,NV,NV,NW,EYE,MAX,SLAB,TVAL,IFLAG) +C +NOAO - Call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE SET3D (EYE,ULO,UHI,VLO,VHI,WLO,WHI) + SAVE + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C CONSTANTS FOR PWRZ +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELETIVE SIZE FEATURE IN USE. +C GENERATE EYE POSITION THAT MAKES BOX HAVE MAXIMUM PROJECTED SIZE. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32I (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32I (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32I (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32I (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C ARGUMENTS FOR SET +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C + SAVE + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 +C +C RANGE OF PLOTTER COORDINATES +C +C +C WARNING +C IF PLOTTER MAXIMUM VALUE RANGES (IN X OR Y DIRECTION) FALL BELOW +C 101, THEN CHANGES MUST BE MADE IN SUBROUTINE FRSTC. THE REQUIRED +C CHANGES ARE MARKED BY WARNING COMMENTS IN FRSTC. + DATA NLX,NBY,NRX,NTY/10,10,32760,32760/ + DATA PI/3.1411592/ +C +C STORE THE PARAMETERS OF THE SET CALL FOR USE +C WITH THE TRANSLATE CALL +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D +C +C COMPUTE THE ARCCOSINE +C + AL = ATAN(ABS(SQRT(1.-COSAL*COSAL)/COSAL)) + IF (COSAL .LE. 0.) AL = PI-AL + BE = ATAN(ABS(SQRT(1.-COSBE*COSBE)/COSBE)) + IF (COSBE .LE. 0.) BE = PI-BE + GA = ATAN(ABS(SQRT(1.-COSGA*COSGA)/COSGA)) + IF (COSGA .LE. 0.) GA = PI-GA + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = AMIN1(X4,AMAX1(X1,X1+X3*(FACT*UU-X0))) + YT = AMIN1(Y4,AMAX1(Y1,Y1+Y3*(FACT*VV-Y0))) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE ZEROSC + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) +C +C ZERO BOTH SCRENE MODELS. +C + DO 20 I=1,LX + DO 10 J=1,NY + ISCR(I,J) = 0 + ISCA(I,J) = 0 + 10 CONTINUE + 20 CONTINUE + RETURN + END + SUBROUTINE STCNTR (Z,L,M,N,CONV) +C + SAVE + DIMENSION Z(L,N) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 +C + IENTRY = 0 + NP = 0 + CV = CONV +C +C THE FOLLOWING CODE SHOULD BE RE-ENABLED IF THIS ROUTINE IS USED FOR +C GENERAL CONTOURING +C +C ISS=0 +C DO 2 IP1=2,M +C I=IP1-1 +C IF(Z(I,1).GE.CV.OR.Z(IP1,1).LT.CV) GO TO 1 +C IX=IP1 +C IY=1 +C IDX=-1 +C IDY=0 +C IS=1 +C CALL DRLINE(Z,L,M,N) +C 1 IF(Z(IP1,N).GE.CV.OR.Z(I,N).LT.CV) GO TO 2 +C IX=I +C IY=N +C IDX=1 +C IDY=0 +C IS=5 +C CALL DRLINE(Z,L,M,N) +C 2 CONTINUE +C DO 4 JP1=2,N +C J=JP1-1 +C IF(Z(M,J).GE.CV.OR.Z(M,JP1).LT.CV) GO TO 3 +C IX=M +C IY=JP1 +C IDX=0 +C IDY=-1 +C IS=7 +C CALL DRLINE(Z,L,M,N) +C 3 IF(Z(1,JP1).GE.CV.OR.Z(1,J).LT.CV) GO TO 4 +C IX=1 +C IY=J +C IDX=0 +C IDY=1 +C IS=3 +C CALL DRLINE(Z,L,M,N) +C 4 CONTINUE +C + ISS = 1 + DO 40 JP1=3,N + J = JP1-1 + DO 30 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 30 + IXY = IPXY(IP1,J) + IF (NP .EQ. 0) GO TO 20 + DO 10 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 30 + 10 CONTINUE + 20 NP = NP+1 + IF (NP .GT. NR) RETURN + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRCNTR (Z,L,M,N) + 30 CONTINUE + 40 CONTINUE + RETURN + END + SUBROUTINE DRCNTR (Z,L,MM,NN) + SAVE +C + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL IPEN ,IPENO +C + DATA IOFFP,SPVAL/0,0./ + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 + FX(X1,Y1) = X1 + FY(X1,Y1) = Y1 + C(P11,P21) = (P11-CV)/(P11-P21) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 10 + ASSIGN 100 TO JUMP1 + ASSIGN 150 TO JUMP2 + GO TO 20 + 10 ASSIGN 120 TO JUMP1 + ASSIGN 160 TO JUMP2 + 20 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 30 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 30 IF (IDX .EQ. 0) GO TO 40 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 50 + 40 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 50 IF (IPEN) CALL FRSTS (FX(X,Y),FY(X,Y),1) + 60 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 70 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 190 + 70 IF (CV-Z(IX2,IY2)) 80, 80, 90 + 80 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 60 + 90 IF (IS/2*2 .EQ. IS) GO TO 60 + GO TO JUMP1,(100,120) + 100 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 110 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 190 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 190 + 110 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 120 IF (IDX .EQ. 0) GO TO 130 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 140 + 130 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 140 GO TO JUMP2,(150,160) + 150 IF (.NOT.IPEN) GO TO 170 + IF (IPENO) GO TO 160 +C +C END OF LINE SEGMENT +C + CALL FRSTS (D1,D2,3) + CALL FRSTS (FX(XOLD,YOLD),FY(XOLD,YOLD),1) +C +C CONTINUE LINE SEGMENT +C + 160 CALL FRSTS (FX(X,Y),FY(X,Y),2) + 170 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 180 + NP = NP+1 + IF (NP .GT. NR) GO TO 190 + IR(NP) = IPXY(IX,IY) + 180 IF (ISS .EQ. 0) GO TO 60 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 60 +C +C END OF LINE +C + 190 CALL FRSTS (D1,D2,3) + RETURN + END + SUBROUTINE TR32 (X,Y,MX,MY) + SAVE +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C + XX = X + YY = Y + IF (ISLBT) 10, 20, 30 + 10 CALL TRN32I (SU(U),SV(XX-1.),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 20 CALL TRN32I (SU(XX-1.),SV(V),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 30 CALL TRN32I (SU(XX-1.),SV(YY-1.),SW(W),XT,YT,DUM,2) + 40 MX = XT + MY = YT + RETURN + END + SUBROUTINE FRSTS (XX,YY,IENT) +C +C THIS IS A SPECIAL VERSION OF THE SMOOTHING DASHED LINE PACKAGE. LINES +C ARE SMOOTHED IN THE SAME WAY, BUT NO SOFTFARE DASHED LINES ARE USED. +C CONDITIONAL PLOTTING ROUTINES ARE CALL WHICH DETERMINE THE VISIBILITY +C OF A LINE SEGMENT BEFORE PLOTTING. +C + SAVE + DIMENSION XSAVE(70) ,YSAVE(70) ,XP(70) ,YP(70) , + 1 TEMP(70) +C + COMMON /ISOSR7/ IENTRY ,IONES +C + DATA NP/150/ + DATA L1/70/ + DATA TENSN/2.5/ + DATA PI/3.14159265358/ + DATA SMALL/128./ +C + AVE(A,B) = .5*(A+B) +C +C DECIDE IF FRSTS,VECTS,LASTS CALL +C + GO TO ( 10, 20, 40),IENT + 10 DEG = 180./PI + X = XX + Y = YY + LASTFL = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 + CALL TR32 (X,Y,MX,MY) +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************* ENTRY VECTS ************************* +C ENTRY VECTS (XX,YY) +C + 20 X = XX + Y = YY +C +C VECTS SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + CALL TR32 (X,Y,MX,MY) +C +CIF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 50 + RETURN +C +C ************************* ENTRY LASTS ************************* +C ENTRY LASTS +C + 40 LASTFL = 1 +C +C LASTS CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C +C IFLAG = 0 OK TO CALL LASTS DIRECTLY +C IFLAG = 1 LASTS WAS JUST CALLED FROM BY VECTS +C IGNORE CALL TO LASTS +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 50 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 70 + IF (N-2) 160,150, 60 + 60 IF (N .GE. 4) GO TO 70 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 110 + 70 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 90 + IF (NSEG .GE. 1) GO TO 80 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 110 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 80 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 110 + 90 IF (NSEG .GE. 1) GO TO 100 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 110 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 100 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 110 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) + IF (IPRD.EQ.0 .AND. NSEG.EQ.0 .AND. S.LT.70.) GO TO 170 + IENTRY = 1 +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 120 + NPRIME = FLOAT(NP)-(S*FLOAT(NP))/(2.*32768.) + IF (S .GE. 32768.) NPRIME = .5*FLOAT(NP) + NPL = FLOAT(NPRIME)*S/32768. + IF (NPL .LT. 2) NPL = 2 + 120 DT = 1./FLOAT(NPL) + IF (NSEG .LE. 0) CALL FRSTC (IFIX(XSAVE(1)),IFIX(YSAVE(1)),1) + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + XSOLD = XSAVE(1) + YSOLD = YSAVE(1) + DO 130 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XS),IFIX(YS),2) + XSOLD = XS + YSOLD = YS + 130 CONTINUE + IF (IPRD .NE. 0) GO TO 140 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XSV1),IFIX(YSV1),2) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 140 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + 150 CONTINUE + 160 RETURN + 170 N = 0 + RETURN + END + SUBROUTINE FRSTC (MX,MY,IENT) + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C +C +C DRAW LINE TO THE POINT MX,MY +C +C ENTER THE POINT INTO THE CURRENT SCREEN, ISCR, IF THE POINT CONFORMS +C TO THE SHADING ALGORITHM. +C THE POINT IS NOT ENTERED WHEN; +C 1. IT IS THE SAME POINT USED IN THE LAST CALL, RESOLUTION PROBLEM +C 2. IT IS PART OF A HORIZONTAL LINE BUT NOT AN END POINT +C 3. THE ENTIRE CONTOUR RESTS ON A HORIZONTAL PLANE +C +C WHEN DRAWING A HORIZONTAL LINE THREE CONDITIONS EXIST; +C 1. WHEN THE LINE IS A HORIZONTAL STEP ENTER ONLY THE OUTSIDE POINT. +C A HORIZONTAL STEP IS DEFINED BY THE ENTERING AND EXITING Y +C DIRECTION THAT IS THE SAME. +C 2. ENTER BOTH END POINTS OF A HORIZONTAL TURNING POINT. A HORIZONTAL +C TURNING POINT IS A LINE WITH GREATER THAN 1 HORIZONTAL BITS +C AND THE ENTERING AND EXITING Y DIRECTION IS DIFFIRENT. +C 3. WHEN THE ENTIRE CONTOUR IS A HORIZONTAL LINE NO POINTS ARE +C ENTERED. THIS CONDITION IS DETECTED BY THE STATUS OF YCHANG. +C IF IT IS TRUE THEN THE CONTOUR IS NOT A SINGLE HORIZONTAL LINE. +C +C THE PREVIOUS POINT IS ERASED IF IT IS A VERTICAL TURNING POINT. +C A VERTICAL TURNING POINT IS A HORIZONTAL LINE WITH ONLY 1 POINT +C AND THE ENTERING AND EXITING Y DIRECTION DIFFERS.THIS DATA IS +C IN THE VARIABLES IOSLSN-OLD SLOPE AND ISLSGN-NEW SLOPE. +C THE CHANGE IN SLOPE MUST BE -1 TO 1 OR 1 TO -1. +C +C OTHERWISE THE POINT IS ENTERED INTO ISCR. +C +C THE TWO ENTRY POINTS ARE REQUIRED BY THE HARDWARE DRAWING ROUTINES. +C FIRSTC IS USED FOR THE FIRST POINT ON THE CONTOUR. THE REMAINING +C POINTS ON THE SAME CONTOUR ARE ENTERED VIA VECTC. +C + DATA IONE/1/ + AVE(A,B) = (A+B)*.5 +C +C COMPUTE VISIBILITY OF THIS POINT +C +C WARNING +C IF X OR Y PLOTTER MAXIMUM VALUE RANGES FALL BELOW 101 THEN THE +C FOLLOWING TWO STATEMENTS WHICH SET IX AND IY MUST BE CHANGED. +C REPLACE THE CONSTANT 1.0 BY 0.5 IN THE STATEMENTS WHERE THE +C MAXIMUM PLOTTER VALUE IS LESS THAN 101 FOR THAT DIRECTION. THE +C PLOTTER CORDINATE RANGES ARE SET IN SET32. +C + IX = FLOAT(MX-1)*RX+1.0 + NRLX = IX + IY = FLOAT(MY-1)*RY+1.0 + IBIT = NBPW-MOD(IX,NBPW) + IX = IX/NBPW+1 + IVNOW = IAND(ISHIFT(ISCA(IX,IY),1-IBIT),IONE) +C +C DECIDE IF FRSTC OR VECTC CALL +C + IF (IENT .NE. 1) GO TO 10 +C + XOLD = MX + YOLD = MY +C +C +C SET INITIAL VALUES +C + IHF = .FALSE. + IYDIR = 0 + ITPD = 0 + IVAL = 0 + IOSLSN = 0 + IFSX = NRLX + IFSY = IY + LASTV = IVNOW + HBFLAG = .FALSE. + YCHANG = .FALSE. + CALL PLOTIT (IFIX(XOLD),IFIX(YOLD),0) + GO TO 180 +C +C**************************** ENTRY VECTC **************************** +C ENTRY VECTC (MX,MY) +C + 10 XNOW = MX + YNOW = MY + JUMP = IVNOW*2+LASTV+1 + GO TO ( 20, 30, 40, 50),JUMP +C +C BOTH VISIBLE +C + 20 CALL PLOTIT (IFIX(XNOW),IFIX(YNOW),1) + GO TO 50 +C +C JUST TURNED VISIBLE +C + 30 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),0) + GO TO 50 +C +C JUST TURNED INVISIBLE +C + 40 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),1) +C +C BOTH INVISIBLE +C + 50 XOLD = XNOW + YOLD = YNOW + LASTV = IVNOW +C +C TEST FOR RESOLUTION PROBLEM +C + IF (NRLX.EQ.LRLX .AND. IY.EQ.IYOLD) RETURN +C +C TEST FOR HORIZONTAL BITS +C + IF (IYOLD .NE. IY) GO TO 70 +C +C HORIZONTAL BITS DETECTED. SET FLAG AND EXIT. +C THIS AND THE NEXT HORIZONTAL BIT TEST IS NECESSARY FOR ISCR TO +C CONFORM TO THE SHADING ALGORITHM IN SUBROUTINE FILLIN +C +C +C IF HORIZONTAL LINE PREVIOUSLY DETECTED EXIT +C + IF (.NOT.HBFLAG) GO TO 60 +C +C IF END OF CONTOUR ON A HORIZONTAL LINE BRANCH FOR SPECIAL PROCESSING. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C SAVE SLOPE PRIOR TO HORIZONTAL LINE +C + 60 IHX = IXOLD + IHB = IBTOLD + IHS = IOSLSN + IOSLSN = 0 + HBFLAG = .TRUE. + IHRX = LRLX + IHV = IVOLD + IF (LRLX.EQ.IFSX .AND. IYOLD.EQ.IFSY) IHF = .TRUE. +C +C THIS IS THE SECOND TRAP FOR END OF CONTOUR ON A HORIZONTAL LINE. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C COMPUTE THE SLOPE TO THIS POINT +C + 70 IF (IY-IYOLD) 80, 90,100 + 80 ISLSGN = 1 + GO TO 110 + 90 ISLSGN = 0 + GO TO 120 + 100 ISLSGN = -1 + 110 IF (IYDIR .EQ. 0) IYDIR = ISLSGN + 120 CONTINUE +C +C IF PROCESS REACHES THIS CODE THE CONTOUR IS NOT CONTAINED ON A SINGLE +C HORIZONTAL PLANE, SO RECORD THIS FACT BY SETTING Y CHANGE FLAG. +C + YCHANG = .TRUE. +C +C TEST FOR END OF HORIZONTAL LINE +C + IF (.NOT.HBFLAG) GO TO 160 + HBFLAG = .FALSE. +C +C HORIZONTAL LINE JUST ENDED +C +C TEST FOR REDRAW +C + ITEMP = IAND(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + IF ((IHV .EQ. 0) .AND. (ITEMP .EQ. 0)) GO TO 130 +C +C REDRAWING ERASE THIS POINT +C + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C TEST FOR STEP PROBLEM +C + 130 IF (IHS .NE. ISLSGN) GO TO 140 +C +C STEP PROBLEM +C + GO TO 170 +C +C TURNING PROBLEM HORIZONTAL LINE IS A TURNING POINT +C + 140 CONTINUE +C +C ENTER THE TURNING POINT ONLY IF IT IS NOT THE SECOND SUCCEEDING +C EVENT IN A ROW +C + ICTPD = 1 + IF (IHRX .GT. NRLX) ICTPD = -1 + IF (ICTPD .NE. ITPD) GO TO 150 + ITPD = 0 +C +C ERASE THE FIRST POINT +C + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C ENTER THE TURNING POINT +C + 150 CONTINUE + ITPD = ICTPD +C +C ENTER THE SECOND POINT +C + ISCR(IXOLD,IYOLD) = IOR(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + GO TO 170 +C +C CHECK IF PREVIOUS ENTRY WAS A VERTICAL TURNING POINT. +C IF SO ERASE IT. +C + 160 IF (ISLSGN.EQ.IOSLSN .OR. (IOSLSN.EQ.0 .OR. ISLSGN.EQ.0)) + 1 GO TO 170 + ITPD = 0 + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) +C + 170 IOSLSN = ISLSGN +C +C CHECK IF THIS GRID POINT PREVIOUSLY ACTIVATED +C + IVAL = IAND(ISCR(IX,IY),MASK(IBIT)) +C +C IF GRID POINTS ACTIVATED BRANCH +C + IF (IVAL .NE. 0) GO TO 190 +C +C GRID POINT NOT ACTIVATED SET AND EXIT +C + 180 CONTINUE + ISCR(IX,IY) = IOR(ISCR(IX,IY),MASK(IBIT)) + GO TO 200 +C +C THIS POINT IS BEING REDRAWN SO ERASE IT. +C (THIS IS TO CONFORM WITH THE SHADING ALGORITHM, FILLIN. +C HOWEVER IF BACK TO STARTING POINT DO NOT ERASE +C + 190 IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) RETURN + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) +C +C + 200 IXOLD = IX + LRLX = NRLX + IYOLD = IY + IBTOLD = IBIT + IVOLD = IVAL + RETURN +C +C PERFORM THIS OPERATION WHEN A CONTOUR STARTS OR ENDS ON A HORIZONTAL +C LINE. +C + 210 CONTINUE +C +C ERASE THE FIRST POINT OF A CONTOUR WHEN IT IS PART OF A HORIZONTAL +C LINE SEGMENT AND IS NOT THE ENDPOINT OF THE SEGMENT +C + IF (.NOT.IHF) GO TO 220 + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) + 220 CONTINUE +C +C ERASE THE FIRST POINT OF A HORIZONTAL LINE SEGMENT WHEN IT ENDS +C THE CONTOUR AND IS NOT THE HIGHEST LINE SEG ON THS SIDE. +C + IF (.NOT.YCHANG) GO TO 230 + IF (IYDIR .NE. IHS) GO TO 200 + 230 ISCR(IHX,IY) = IAND(ISCR(IHX,IY),NMASK(IHB)) + GO TO 200 + END + SUBROUTINE FILLIN +C + SAVE + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES +C + IF (IENTRY .EQ. 0) RETURN +C +C THIS IS A SHADING ALGORITHM IT IS USED TO DETERMINE CONTOUR LINES +C THAT ARE HIDDEN BY THE PRESENT LINE. THE ALGORITHM PROCESSES +C HORIZONTAL ROWS. IT ASSUMES THAT THE BIT PATTERN PASSED TO IT +C HAS ONLY BITS SET TO MARK THE START AND END OF SHADING. THE +C ALGORITHM ALSO ASSUMES THAT WHEN AN ON BIT IS ENCOUNTERED THAT A +C CORRESPONDING OFF BIT IS INCLUDED IN THE SAME ROW. +C +C +C PULL OUT ROWS OF THE CONTOUR PATTERN +C + IBVAL = 0 + DO 80 IYNOW=1,NY + DO 40 IXNOW=1,LX +C +C IF NO ACTIVATED BITS BRANCH +C + ICRWD = ISCR(IXNOW,IYNOW) + IF (ICRWD .EQ. 0) GO TO 30 +C +C ACTIVATED BITS IN WORD SET SHADING FLAG +C +C CHECK BIT BY BIT FOR ON/OFF FLAGS +C + DO 20 IB=1,NBPW + IBIT = (NBPW+1)-IB +C +C +C PULL OUT THE CURRENT GRID POINT VALUE +C + IVAL = IAND(ICRWD,MASK(IBIT)) +C +C IF IVAL SET, THIS IS AN ON/OFF FLAG +C + IF (IVAL .EQ. 0) GO TO 10 +C +C FLAG BIT, ALWAYS SET +C + IBVAL = MOD(IBVAL+1,2) + GO TO 20 +C +C SHADE THE SCREEN ACCORDING TO THE STATUS OF IBVAL +C + 10 IF (IBVAL .NE. 0) ICRWD = IOR(ICRWD,MASK(IBIT)) +C + 20 CONTINUE +C +C ZERO OUT THE SCREEN +C + ISCR(IXNOW,IYNOW) = 0 + ISCA(IXNOW,IYNOW) = IOR(ICRWD,ISCA(IXNOW,IYNOW)) + GO TO 40 +C + 30 IF (IBVAL .NE. 0) ISCA(IXNOW,IYNOW) = IONES + 40 CONTINUE +C +C FIX FOR NONCORRECTABLE RUNAWAYS +C + IF (IBVAL .EQ. 0) GO TO 80 + IBVAL = 0 + DO 70 K=1,LX + ITEST = 0 + IF (IYNOW .EQ. 1) GO TO 50 + ITEST = ISCA(K,IYNOW-1) + IF (IYNOW .EQ. NY) GO TO 60 + 50 ITEST = IOR(ITEST,ISCA(K,IYNOW+1)) + 60 ISCA(K,IYNOW) = ITEST + 70 CONTINUE +C + 80 CONTINUE + RETURN + END + SUBROUTINE DRAWI (IXA,IYA,IXB,IYB) +C +C INCLUDED FOR USE BY PWRZ +C + SAVE + CALL FRSTC (IXA,IYA,1) + CALL FRSTC (IXB,IYB,2) + RETURN + END + SUBROUTINE MMASK +C +C MAKE THE MACHINE DEPENDENT MASKS USED IN THE CONTOUR DRAWING +C AND SHADING ALGORITHMS +C + SAVE + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF + GENDON = .TRUE. + NBPW = 16 +C +C GET BIGGEST REAL NUMBER +C + BIG = R1MACH(2) +C +C MASKS TO SELECT A SPECIFIC BIT +C + DO 10 K=1,NBPW + MASK(K) = ISHIFT(1,K-1) + 10 CONTINUE +C +C GENERATE THE BIT PATTERN 177777 OCTAL +C + ITEMP1 = 0 + ITEMP = MASK(NBPW) + IST = NBPW-1 + DO 20 K=1,IST + ITEMP1 = IOR(ITEMP,ISHIFT(ITEMP1,-1)) + 20 CONTINUE + MFIX = IOR(ITEMP1,1) +C +C MASKS TO CLEAR A SPECIFIC BIT +C + DO 30 K=1,NBPW + NMASK(K) = IAND(ITEMP1,MFIX) + ITEMP1 = IOR(ISHIFT(ITEMP1,1),1) + 30 CONTINUE + IONES = MFIX + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C JANUARY 1979 NEW SHADING ALGORITHM +C MARCH 1979 MADE CODE MACHINE INDEPENDENT AND CONFORM +C TO 66 FORTRAN STANDARD +C JUNE 1979 THIS VERSION PLACED ON ULIB. +C SEPTEMBER 1979 FIXED PROBLEM IN EZISOS DEALING WITH +C DETERMINATION OF VISIBILITY OF W PLANE. +C DECEMBER 1979 FIXED PROBLEM WITH PEN DOWN ON CONTOUR +C INITIALIZATION IN SUBROUTINE FRSTC +C MARCH CHANGED ROUTINE NAMES TRN32I AND DRAW TO +C TRN32I AND DRAWI TO BE CONSISTENT WITH THE +C USAGE OF THE NEW ROUTINE PWRZI. +C JUNE 1980 FIXED PROBLEM WITH ZERO INDEX COMPUTATION IN +C SUBROUTINE FRSTC. ADDED INPUT PARAMETER +C DIMENSION STATEMENT MISSING IN EZISOS. +C FIXED ERROR IN COMPUTATION OF ARCCOSINE +C IN EZISOS AND TRN32I. +C DECEMBER 1984 CONVERTED TO GKS LEVEL 0A AND STANDARD FORTRAN 77 +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/kurv.f b/sys/gio/ncarutil/kurv.f new file mode 100644 index 00000000..1d160b89 --- /dev/null +++ b/sys/gio/ncarutil/kurv.f @@ -0,0 +1,451 @@ + SUBROUTINE KURV1S (N,X,Y,SLOP1,SLOPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N),TEMP(N) +C ARGUMENTS +C +C LATEST REVISION FEBRUARY 5, 1974 +C +C PURPOSE KURV1S DETERMINES THE PARAMETERS NECESSARY TO +C COMPUTE A SPLINE UNDER TENSION PASSING THROUGH +C A SEQUENCE OF PAIRS +C (X(1),Y(1)),...,(X(N),Y(N)) IN THE PLANE. +C THE SLOPES AT THE TWO ENDS OF THE CURVE MAY BE +C SPECIFIED OR OMITTED. FOR ACTUAL COMPUTATION +C OF POINTS ON THE CURVE IT IS NECESSARY TO CALL +C THE SUBROUTINE KURV2S. +C +C USAGE CALL KURV1S(N,X,Y,SLP1,SLPN,XP,YP,TEMP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT N +C IS THE NUMBER OF POINTS TO BE INTERPOLATED +C (N .GE. 2). +C +C X +C IS AN ARRAY CONTAINING THE N X-COORDINATES +C OF THE POINTS. +C +C Y +C IS AN ARRAY CONTAINING THE N Y-COORDINATES +C OF THE POINTS. +C +C SLOP1 AND SLOPN +C CONTAIN THE DESIRED VALUES FOR THE SLOPE OF +C THE CURVE AT (X(1),Y(1)) AND (X(N),Y(N)), +C RESPECTIVELY. THESE QUANTITIES ARE IN +C DEGREES AND MEASURED COUNTER-CLOCKWISE +C FROM THE POSITIVE X-AXIS. IF ISLPSW IS NON- +C ZERO, ONE OR BOTH OF SLP1 AND SLPN MAY BE +C DETERMINED INTERNALLY BY KURV1S. +C +C XP AND YP +C ARE ARRAYS OF LENGTH AT LEAST N. +C +C TEMP +C IS AN ARRAY OF LENGTH AT LEAST N WHICH IS +C USED FOR SCRATCH STORAGE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR. THIS IS +C NON-ZERO AND INDICATES THE CURVINESS DESIRED. +C IF ABS(SIGMA) IS VERY LARGE (E.G., 50.) THE +C RESULTING CURVE IS VERY NEARLY A POLYGONAL +C LINE. A STANDARD VALUE FOR SIGMA IS ABOUT 2. +C +C ISLPSW +C IS AN INTEGER INDICATING WHICH END SLOPES +C HAVE BEEN USER PROVIDED AND WHICH MUST BE +C COMPUTED BY KURV1S. FOR ISLPSW +C = 0 INDICATES BOTH SLOPES ARE PROVIDED, +C = 1 ONLY SLOP1 IS PROVIDED, +C = 2 ONLY SLOPN IS PROVIDED, +C = 3 NEITHER SLOP1 NOR SLOPN IS PROVIDED. +C = 4 NEITHER SLOP1 NOR SLOPN IS PROVIDED, +C BUT SLOP1=SLOPN. IN THIS CASE X(1)= +C X(N), Y(1)=Y(N) AND N.GE.3. +C ON OUTPUT XP AND YP +C CONTAIN INFORMATION ABOUT THE CURVATURE OF +C THE CURVE AT THE GIVEN NODES. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C N, X, Y, SLP1, SLPN, SIGMA AND ISLPSW ARE +C UNCHANGED. +C +C ENTRY POINTS KURV1S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL X(N) ,Y(N) ,XP(N) ,YP(N) , + 1 TEMP(N) ,S ,SIGMA + SAVE +C + DATA PI /3.1415926535897932/ +C + NN = N + JSLPSW = ISLPSW + SLP1 = SLOP1 + SLPN = SLOPN + DEGRAD = PI/180. + NM1 = NN-1 + NP1 = NN+1 + DELX1 = X(2)-X(1) + DELY1 = Y(2)-Y(1) + DELS1 = SQRT(DELX1*DELX1+DELY1*DELY1) + DX1 = DELX1/DELS1 + DY1 = DELY1/DELS1 +C +C DETERMINE SLOPES IF NECESSARY +C + IF (JSLPSW .NE. 0) GO TO 70 + 10 SLPP1 = SLP1*DEGRAD + SLPPN = SLPN*DEGRAD +C +C SET UP RIGHT HAND SIDES OF TRIDIAGONAL LINEAR SYSTEM FOR XP +C AND YP +C + XP(1) = DX1-COS(SLPP1) + YP(1) = DY1-SIN(SLPP1) + + TEMP(1) = DELS1 + SS = DELS1 + IF (NN .EQ. 2) GO TO 30 + DO 20 I=2,NM1 + DELX2 = X(I+1)-X(I) + DELY2 = Y(I+1)-Y(I) + DELS2 = SQRT(DELX2*DELX2+DELY2*DELY2) + DX2 = DELX2/DELS2 + DY2 = DELY2/DELS2 + XP(I) = DX2-DX1 + YP(I) = DY2-DY1 + TEMP(I) = DELS2 + DELX1 = DELX2 + DELY1 = DELY2 + DELS1 = DELS2 + DX1 = DX2 + DY1 = DY2 +C +C ACCUMULATE POLYGONAL ARCLENGTH +C + SS = SS+DELS1 + 20 CONTINUE + 30 XP(NN) = COS(SLPPN)-DX1 + YP(NN) = SIN(SLPPN)-DY1 +C +C DENORMALIZE TENSION FACTOR +C + SIGMAP = ABS(SIGMA)*FLOAT(NN-1)/SS +C +C PERFORM FORWARD ELIMINATION ON TRIDIAGONAL SYSTEM +C + S = SS + DELS = SIGMAP*TEMP(1) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(1)*SINHS) + DIAG1 = SINHIN*(DELS*.5*(EXPS+1./EXPS)-SINHS) + DIAGIN = 1./DIAG1 + XP(1) = DIAGIN*XP(1) + YP(1) = DIAGIN*YP(1) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(1) = DIAGIN*SPDIAG + IF (NN .EQ. 2) GO TO 50 + DO 40 I=2,NM1 + DELS = SIGMAP*TEMP(I) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(I)*SINHS) + DIAG2 = SINHIN*(DELS*(.5*(EXPS+1./EXPS))-SINHS) + DIAGIN = 1./(DIAG1+DIAG2-SPDIAG*TEMP(I-1)) + XP(I) = DIAGIN*(XP(I)-SPDIAG*XP(I-1)) + YP(I) = DIAGIN*(YP(I)-SPDIAG*YP(I-1)) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(I) = DIAGIN*SPDIAG + DIAG1 = DIAG2 + 40 CONTINUE + 50 DIAGIN = 1./(DIAG1-SPDIAG*TEMP(NM1)) + XP(NN) = DIAGIN*(XP(NN)-SPDIAG*XP(NM1)) + YP(NN) = DIAGIN*(YP(NN)-SPDIAG*YP(NM1)) +C +C PERFORM BACK SUBSTITUTION +C + DO 60 I=2,NN + IBAK = NP1-I + XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1) + YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) + 60 CONTINUE + RETURN + 70 IF (NN .EQ. 2) GO TO 100 +C +C IF NO SLOPES ARE GIVEN, USE SECOND ORDER INTERPOLATION ON +C INPUT DATA FOR SLOPES AT ENDPOINTS +C + IF (JSLPSW .EQ. 4) GO TO 90 + IF (JSLPSW .EQ. 2) GO TO 80 + DELNM1 = SQRT((X(NN-2)-X(NM1))**2+(Y(NN-2)-Y(NM1))**2) + DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELNM1+DELN + C1 = (DELNN+DELN)/DELNN/DELN + C2 = -DELNN/DELN/DELNM1 + C3 = DELN/DELNN/DELNM1 + SX = C3*X(NN-2)+C2*X(NM1)+C1*X(NN) + SY = C3*Y(NN-2)+C2*Y(NM1)+C1*Y(NN) +C + SLPN = ATAN2(SY,SX)/DEGRAD + 80 IF (JSLPSW .EQ. 1) GO TO 10 + DELS2 = SQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2) + DELS12 = DELS1+DELS2 + C1 = -(DELS12+DELS1)/DELS12/DELS1 + C2 = DELS12/DELS1/DELS2 + C3 = -DELS1/DELS12/DELS2 + SX = C1*X(1)+C2*X(2)+C3*X(3) + SY = C1*Y(1)+C2*Y(2)+C3*Y(3) +C + SLP1 = ATAN2(SY,SX)/DEGRAD + GO TO 10 + 90 DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELS1+DELN + C1 = -DELS1/DELN/DELNN + C2 = (DELS1-DELN)/DELS1/DELN + C3 = DELN/DELNN/DELS1 + SX = C1*X(NM1)+C2*X(1)+C3*X(2) + SY = C1*Y(NM1)+C2*Y(1)+C3*Y(2) + IF (SX.EQ.0. .AND. SY.EQ.0.) SX = 1. + SLP1 = ATAN2(SY,SX)/DEGRAD + SLPN = SLP1 + GO TO 10 +C +C IF ONLY TWO POINTS AND NO SLOPES ARE GIVEN, USE STRAIGHT +C LINE SEGMENT FOR CURVE +C + 100 IF (JSLPSW .NE. 3) GO TO 110 + XP(1) = 0. + XP(2) = 0. + YP(1) = 0. + YP(2) = 0. +C + SLP1 = ATAN2(Y(2)-Y(1),X(2)-X(1))/DEGRAD + SLPN = SLP1 + RETURN +C + 110 IF (JSLPSW .EQ. 2) + 1 SLP1 = ATAN2(Y(2)-Y(1)-SLPN*(X(2)-X(1)), + 2 X(2)-X(1)-SLPN*(Y(2)-Y(1)))/DEGRAD +C + IF (JSLPSW .EQ. 1) + 1 SLPN = ATAN2(Y(2)-Y(1)-SLP1*(X(2)-X(1)), + 2 X(2)-X(1)-SLP1*(Y(2)-Y(1)))/DEGRAD + GO TO 10 + END + SUBROUTINE KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N) +C ARGUMENTS +C +C LATEST REVISION OCTOBER 22, 1973 +C +C PURPOSE KURV2S PERFORMS THE MAPPING OF POINTS IN THE +C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. +C THE SUBROUTINE KURV1S SHOULD BE CALLED EARLIER +C TO DETERMINE CERTAIN NECESSARY PARAMETERS. +C THE RESULTING CURVE HAS A PARAMETRIC +C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE +C SPLINES UNDER TENSION AND FUNCTIONS OF THE +C POLYGONAL ARCLENGTH PARAMETER. +C +C ACCESS CARDS *FORTRAN,S=ULIB,N=KURV +C *COSY +C +C USAGE CALL KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT T +C CONTAINS A REAL VALUE OF ABSOLUTE VALUE LESS +C THAN OR EQUAL TO 1. TO BE MAPPED TO A POINT +C ON THE CURVE. THE SIGN OF T IS IGNORED AND +C THE INTERVAL (0.,1.) IS MAPPED ONTO THE +C ENTIRE CURVE. IF T IS NEGATIVE, THIS +C INDICATES THAT THE SUBROUTINE HAS BEEN CALLED +C PREVIOUSLY (WITH ALL OTHER INPUT VARIABLES +C UNALTERED) AND THAT THIS VALUE OF T EXCEEDS +C THE PREVIOUS VALUE IN ABSOLUTE VALUE. WITH +C SUCH INFORMATION THE SUBROUTINE IS ABLE TO +C MAP THE POINT MUCH MORE RAPIDLY. THUS IF THE +C USER SEEKS TO MAP A SEQUENCE OF POINTS ONTO +C THE SAME CURVE, EFFICIENCY IS GAINED BY +C ORDERING THE VALUES INCREASING IN MAGNITUDE +C AND SETTING THE SIGNS OF ALL BUT THE FIRST +C NEGATIVE. +C +C N +C CONTAINS THE NUMBER OF POINTS WHICH WERE +C INTERPOLATED TO DETERMINE THE CURVE. +C +C X AND Y +C ARRAYS CONTAINING THE X- AND Y-COORDINATES +C OF THE INTERPOLATED POINTS. +C +C XP AND YP +C ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING +C CURVATURE INFORMATION. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR (ITS SIGN IS +C IGNORED). +C +C NSLPSW +C IS AN INTEGER SWITCH WHICH TURNS ON OR OFF +C THE CALCULATION OF SLP +C NSLPSW +C = 0 INDICATES THAT SLP WILL NOT BE +C CALCULATED +C = 1 SLP WILL BE CALCULATED +C +C THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA +C SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF +C KURV1S. +C +C ON OUTPUT XS AND YS +C CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE +C POINT ON THE CURVE. +C +C SLP +C CONTAINS THE SLOPE OF THE CURVE IN DEGREES AT +C THIS POINT. +C +C T, N, X, Y, XP, YP, S AND SIGMA ARE UNALTERED. +C +C ENTRY POINTS KURV2S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL T ,XS ,YS ,X(N) , + 1 Y(N) ,XP(N) ,YP(N) ,S , + 2 SIGMA ,SLP + SAVE +C + DATA PI /3.1415926535897932/ +C +C +C DENORMALIZE SIGMA +C + SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S +C +C STRETCH UNIT INTERVAL INTO ARCLENGTH DISTANCE +C + TN = ABS(T*S) +C +C FOR NEGATIVE T START SEARCH WHERE PREVIOUSLY TERMINATED, +C OTHERWISE START FROM BEGINNING +C + IF (T .LT. 0.) GO TO 10 + DEGRAD = PI/180. + I1 = 2 + XS = X(1) + YS = Y(1) + SUM = 0. + IF (T .LT. 0.) RETURN +C +C DETERMINE INTO WHICH SEGMENT TN IS MAPPED +C + 10 DO 30 I=I1,N + DELX = X(I)-X(I-1) + DELY = Y(I)-Y(I-1) + DELS = SQRT(DELX*DELX+DELY*DELY) + IF (SUM+DELS-TN) 20,40,40 + 20 SUM = SUM+DELS + 30 CONTINUE +C +C IF ABS(T) IS GREATER THAN 1., RETURN TERMINAL POINT ON +C CURVE +C + XS = X(N) + YS = Y(N) + RETURN +C +C SET UP AND PERFORM INTERPOLATION +C + 40 DEL1 = TN-SUM + DEL2 = DELS-DEL1 + EXPS1 = EXP(SIGMAP*DEL1) + SINHD1 = .5*(EXPS1-1./EXPS1) + EXPS2 = EXP(SIGMAP*DEL2) + SINHD2 = .5*(EXPS2-1./EXPS2) + EXPS = EXPS1*EXPS2 + SINHS = .5*(EXPS-1./EXPS) + XS = (XP(I)*SINHD1+XP(I-1)*SINHD2)/SINHS+ + 1 ((X(I)-XP(I))*DEL1+(X(I-1)-XP(I-1))*DEL2)/DELS + YS = (YP(I)*SINHD1+YP(I-1)*SINHD2)/SINHS+ + 1 ((Y(I)-YP(I))*DEL1+(Y(I-1)-YP(I-1))*DEL2)/DELS + I1 = I + IF (NSLPSW .EQ. 0) RETURN + COSHD1 = .5*(EXPS1+1./EXPS1)*SIGMAP + COSHD2 = .5*(EXPS2+1./EXPS2)*SIGMAP + XT = (XP(I)*COSHD1-XP(I-1)*COSHD2)/SINHS+ + 1 ((X(I)-XP(I))-(X(I-1)-XP(I-1)))/DELS + YT = (YP(I)*COSHD1-YP(I-1)*COSHD2)/SINHS+ + 1 ((Y(I)-YP(I))-(Y(I-1)-YP(I-1)))/DELS + SLP = ATAN2(YT,XT)/DEGRAD + RETURN + END diff --git a/sys/gio/ncarutil/mkpkg b/sys/gio/ncarutil/mkpkg new file mode 100644 index 00000000..20b06e09 --- /dev/null +++ b/sys/gio/ncarutil/mkpkg @@ -0,0 +1,51 @@ +# Make the NCAR utilities library libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + @sysint + @autograph + @conlib + + conran.f # blockdata for the conrec utility + conbdn.f # blockdata for the conran utility + #conraq.f - Conran, conraq and conras form the "conran" family. + #conras.f - Conran is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + # + conrec.f + conbd.f + #conrcqck.f - Conrcqck, conrcspr and conrec form the "conrec" family. + #conrcspr.f - Conrec is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + #dashchar.f + #dashline.f - Like the "conrec" family above, the "dash" family contains + dashsmth.f #- duplicate entry points and blockdatas. Only dashsmth is + #- included in "libncar.a". The others are redundant. + dashbd.f # blockdata for the dashsmth utility + #dashsupr.f + #ezmapg.f + gridal.f + gridt.f #- blockdata for the gridal utility + hafton.f + hfinit.f #- blockdata for the hafton utility + isosrf.f + isosrb.f #- blockdata for the isosrf utility + kurv.f #- support routines for dashsmth and isosrf + pwrity.f + pwrzi.f + pwrzs.f + pwrzt.f + srface.f + srfabd.f #- blockdata for the srface utility + #strmln.f + threed.f + threbd.f #- blockdata for the threed utility + velvct.f + veldat.f #- blockdata for the velvct utility + ; diff --git a/sys/gio/ncarutil/pwrity.f b/sys/gio/ncarutil/pwrity.f new file mode 100644 index 00000000..5685c9b7 --- /dev/null +++ b/sys/gio/ncarutil/pwrity.f @@ -0,0 +1,604 @@ + SUBROUTINE PWRITY (X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY 1984 +C +C PURPOSE PWRITY IS A CHARACTER PLOTTING ROUTINE. IT HAS +C SOME FEATURES NOT FOUND IN WTSTR, BUT IS NOT AS +C FANCY AS PWRITX. +C +C +C USAGE CALL PWRITY(X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C ARGUMENTS +C +C ON INPUT X,Y +C POSITIONING COORDINATES FOR THE CHARACTERS TO +C BE DRAWN. X AND Y ARE USER WORLD COORDINATES +C AND ARE SCALED ACCORDING TO THE CURRENT +C NORMALIZATION TRANSFORMATION. ALSO, SEE ICNT. +C +C ID +C CHARACTER STRING TO BE DRAWN. +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS CHOSEN AS +C 1., 1.5, 2., OR 3. TIMES AN 8 PLOTTER +C ADDRESS CHARACTER WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C ITHETA +C ANGLE, IN DEGREES, AT WHICH THE CHARACTERS ARE +C PLOTTED (COUNTER CLOCKWISE FROM THE POSITIVE +C X AXIS.) +C +C ICNT +C CENTERING OPTION: +C = -1 (X,Y) IS THE CENTER OF THE LEFT EDGE +C OF THE FIRST CHARACTER. +C = 0 (X,Y) IS THE CENTER OF THE ENTIRE +C STRING. +C = 1 (X,Y) IS THE CENTER OD THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C ENTRY POINTS PWRY, PWRYSO, PWRYGT, PWRITY, PWRYBD +C +C COMMON BLOCKS PWRCOM +C +C REQUIRED LIBRARY THE SPPS. +C + +C +C I/O PLOTS CHARACTERS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE IN DASHCHAR. +C MADE PORTABLE IN JANUARY 1977 +C FOR USE ON COMPUTER SYSTEMS WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BITS RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JULY, 1984. +C +C ALGORITHM DIGITIZATIONS OF THE CHARACTERS ARE STORED +C NTERNALLY AND ADJUSTED ACCORDING TO X, Y, +C ISIZE AND ICNT, THEN PLOTTED. +C +C TIMING SLOWER THAN WTSTR, FASTER THAN PWRITX. +C +C PORTABILITY FORTRAN +C +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + COMMON /PWRCOM/ USABLE + LOGICAL USABLE + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C + DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LEN IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRY. +C LRES IS THE NUMBER OF BITS OF ACCURACY USED FOR INTEGER INPUT TO +C THE SYSTEM PLOT PACKAGE. +C + DATA NSIZE/46/ +c Variable LEN not used. +c DATA LEN/494/ + DATA LENTRY/.FALSE./ + DATA LRES/15/ + DATA DEGRAD/0.017453293/ + IF (USABLE) GO TO 101 +C +C THIS IS A PWRITY CALL +C + CALL Q8QST4 ('GRAPHX','PWRITY','PWRITY','VERSION 1') + 101 USABLE = .FALSE. +C +C SEE IF THIS IS THE FIRST CALL TO PWRITY. +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRY. +C + CALL PWRYSO (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C +C TRANSFORM THE INPUT COORDINATES TO INTEGER SPACE. +C + 103 CALL FL2INT (X,Y,IX,IY) +C + NN = N + IF (NN .LE. 0) GO TO 113 + FNNM1 = NN-1 + JCNT = ICNT +C +C GET USER SET RESOLUTION. +C + CALL GETUSV ('XF',LXSAVE) + CALL GETUSV ('YF',LYSAVE) +C +C PUT RELATIVE SIZE IN Q. +C + Q = ISIZE + IF (Q .LE. 3.) GO TO 104 + Q = Q/FLOAT(ISHIFT(6,LXSAVE-10)) + GO TO 105 + 104 Q = (1.+.5*(FLOAT(IFIX(Q)+IFIX(Q)/3)))*4./3. + 105 Q = Q*FLOAT(ISHIFT(1,LRES-10)) +C +C CALCULATE COMBINED TRANSFORMATION. +C + THETA = FLOAT(ITHETA)*DEGRAD + CT = Q*COS(THETA) + ST = Q*SIN(THETA) +C +C FIND PLOTTER ADDRESS COORDINATES FOR BEGINNING. +C + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-WHITE*CT+HIGH*.5*ST + YC = YC-WHITE*ST-HIGH*.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCENT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (107,106,108),JCENT + 106 XC = XC-CT*FNNM1*WIDE*.5 + YC = YC-ST*FNNM1*WIDE*.5 + GO TO 109 + 107 XC = XC+CT*WHITE + YC = YC+ST*WHITE + GO TO 109 + 108 XC = XC-CT*WHITE + YC = YC-ST*WHITE + XC = XC-CT*FNNM1*WIDE + YC = YC-ST*FNNM1*WIDE +C +C SET PLOTTER TO STARTING POINT. +C + 109 CALL PLOTIT (IFIX(XC),IFIX(YC),0) +C +C PLOT ALL THE CHARACTERS IN THE INPUT STRING. +C + DO 112 K=1,NN + YB = YC + XB = XC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C DRAW INDIVIDUAL CHARACTER. +C + L = 0 + 110 ISUB = IPOINT+L + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY + L = L+1 +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 110,112,110 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL PLOTTING ROUTINE. MODE DETERMINED BY OP-CODE. +C + CALL PLOTIT (IFIX(XC+.5),IFIX(YC+.5),IP) + IP = 1 + GO TO 110 + 112 CONTINUE +C + 113 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PWRYSO (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN + END + SUBROUTINE PWRY (X,Y,ID,N,SIZE,THETA,ICNT) +C +C PWRY IS AN OLD ENTRY POINT AND HAS BEEN REMOVED - USE PWRITY +C ENTRY POINT +C +C +NOAO - FTN writes and format statements commented out. +C WRITE (I1MACH(4),1001) +C WRITE (I1MACH(4),1002) +C STOP +C +C1001 FORMAT ('1'//////////) +C1002 FORMAT (' ****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRY IS NO LONGER *'/ +C 4 ' * SUPPORTED. PLEASE USE THE MORE *'/ +C 5 ' * RECENT VERSION PWRITY. *'/ +C 6 ' * *'/ +C 7 ' * *'/ +C 8 ' ****************************************') +C -NOAO + END +C +NOAO - Blockdata rewritten as subroutine +C BLOCKDATA PWRYBD + subroutine pwrybd + COMMON /PWRCOM/ USABLE + LOGICAL USABLE +C DATA USABLE/.FALSE./ + usable = .false. +C -NOAO +C REVISION HISTORY------ +C FEBURARY 1979 CREATED NEW ALGORITHM PWRITY TO REPLACE PWRY +C ADDED REVISION HISTORY +C JUNE 1979 CHANGE ARGUMENT THETA IN PWRITY FROM FLOATING TO +C INTEGER, USING ITHETA AS THE NEW NAME. ITS +C MEANING IS NOW DEGREES INSTEAD OF RADIANS. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/pwrzi.f b/sys/gio/ncarutil/pwrzi.f new file mode 100644 index 00000000..d49b9ff5 --- /dev/null +++ b/sys/gio/ncarutil/pwrzi.f @@ -0,0 +1,732 @@ + SUBROUTINE PWRZI (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZI IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C ISOSRF. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C PWRZI WILL NOT WORK WITH ISOSRFHR. +C +C +C USAGE CALL PWRZI (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZI AFTER CALLING +C ISOSRF AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C ISOSRF. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZI, INITZI, PWRZOI, PWRZGI +C +C COMMON BLOCKS PWRZ1I,PWRZ2I +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH ISOSRF. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following variables are used. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZI. +C + DATA NSIZE/46/ +c Variable LNGTH is not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZI','PWRZI','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZI +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZI. +C + CALL PWRZOI (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 32. + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)*(2**(15-LX))/6. +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZI (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZI (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZI (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZI (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZI (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2I/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZI (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZI (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1I/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2I/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZI,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZI - LINE OR ITOP IMPROPER IN PWRZI CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32I (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + RETURN + 120 CALL PLOTIT (IFIX(XT),IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN ISOSRF +C + CALL DRAWI (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOI (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C ISOSRF +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzs.f b/sys/gio/ncarutil/pwrzs.f new file mode 100644 index 00000000..cfda613e --- /dev/null +++ b/sys/gio/ncarutil/pwrzs.f @@ -0,0 +1,772 @@ + SUBROUTINE PWRZS (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZS IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C SRFACE. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZS (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZS AFTER CALLING +C SRFACE AND BEFORE CALLING FRAME +C NOTE: SRFACE WILL HAVE TO BE CHANGED +C TO SUPPRESS THE FRAME CALL. SEE IFR +C IN SRFACE INTERNAL PARAMETERS. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C SRFACE. +C +C ID +C CHARACTER STRING TO BE DRAWN +C +C N +C THE NUMBER OF CHARACTERS IN ID +C +C ISIZE +C SIZE OF THE CHARACTER +C . IF BETWEEN 0 AND 3 THE FACTOR IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3 IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER. NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZS, INITZS, PWRZOS, PWRZGS +C +C COMMON BLOCKS PWRZ1S,PWRZ2S +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH SRFACE. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + DIMENSION VWPRT(4) ,WNDW(4) + LOGICAL LENTRY +c +NOAO: common block added for user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZS. +C + DATA NSIZE/46/ +c Variable LNGTH never used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZS','PWRZS','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND LOG SCALING FLAG +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV('LS',IOLLS) +C +C DEFINE NORMALIZATION TRANS 1 FOR USE WITH DRAWS +C +c +NOAO: device viewport now user controlled through common noaovp + call set (vpx1, vpx2, vpy1, vpy2, 1., 1024., 1., 1024., 1) +c CALL SET(0.0,1.0,0.0,1.0,1.0,1024.0,1.0,1024.0,1) +c-NOAO +C +C SEE IF THIS IS THE FIRST CALL TO PWRZS +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZS. +C + CALL PWRZOS (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZS (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZS (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZS (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZS (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) +C +C RESTORE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + + WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE INTZS (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2S/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZS (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZS (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2S/ X ,Y ,Z +c +NOAO: common block added to allow user control of device viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZS,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZS - LINE OR ITOP IMPROPER IN PWRZS CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32S (XX,YY,ZZ,XT,YT,DUMMY,1) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C +c +NOAO: Remove the assumption that window coordinates 1-1024 map to the +c full plotter metacode range 1-32768 +c + 119 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 0) +c 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN +c + 120 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 1) +c 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) +c -NOAO + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN SRFACE +C + CALL DRAWS (IX1,IY1,IX2,IY2,1,0) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOS (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C SRFACE +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzt.f b/sys/gio/ncarutil/pwrzt.f new file mode 100644 index 00000000..eea2b0d0 --- /dev/null +++ b/sys/gio/ncarutil/pwrzt.f @@ -0,0 +1,731 @@ + SUBROUTINE PWRZT (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZT IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C THREED. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZT (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZT AFTER CALLING +C THREED AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C THREED. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZT, INITZT, PWRZOT, PWRZGT +C +C COMMON BLOCKS PWRZ1T,PWRZ2T +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY THREED, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH THREED. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywhere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZT. +C + DATA NSIZE/46/ +c Variable LNGTH not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZT','PWRZT','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZT +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZT. +C + CALL PWRZOT (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZT (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZT (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZT (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZT (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZT (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2T/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZT (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZT (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1T/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2T/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZT,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZT - LINE OR ITOP IMPROPER IN PWRZT CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32T (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN + 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN THREED +C + CALL DRAWT (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOT (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C THREED +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/srfabd.f b/sys/gio/ncarutil/srfabd.f new file mode 100644 index 00000000..25712c27 --- /dev/null +++ b/sys/gio/ncarutil/srfabd.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: here is the changed block data +c BLOCKDATA SRFABD + subroutine srfabd +c + integer first, temp + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX, + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +noao: common block added 4NOV85 to allow user control of viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c-noao +C +c +noao: following flag added to prevent initialization more than once + common /frstfg/ first + SAVE + data temp /1/ + first = temp + if (first .ne. 1) then + return + endif + temp = 0 +c +C +noao: by default, the full device viewport is used + vpx1 = 0.0 + vpx2 = 1.0 + vpy1 = 0.0 + vpy2 = 1.0 +c -noao +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA ISPVAL/-999/ + ISPVAL = -999 + +c DATA IFR,ISTP,IROTS,IDRX,IDRY,IDRZ,IUPPER,ISKIRT,NCLA/ +c 1 1, 0, 0, 1, 1, 0, 0, 0, 6/ +c +noao: initial value of ifr changed to 0 to suppress frame advance. This +c function should be performed by the calling procedure. +c -noao + IFR = 0 + ISTP = 0 + IROTS = 0 + IDRX = 1 + IDRY = 1 + IDRZ = 0 + IUPPER = 0 + ISKIRT = 0 + NCLA = 6 + +c DATA THETA,HSKIRT,CHI,CLO,CINC/ +c 1 .02, 0., 0., 0., 0./ + THETA =.02 + HSKIRT = 0. + CHI = 0. + CLO = 0. + CINC = 0. + +c DATA NRSWT/0/ + NRSWT = 0 + +c DATA IOFFP,SPVAL/0,0.0/ + IOFFP = 0 + SPVAL = 0.0 + +C LINE COLOR INDEX +c DATA ISRFMJ/1/ + ISRFMJ = 1 +C +c -noao + END diff --git a/sys/gio/ncarutil/srface.f b/sys/gio/ncarutil/srface.f new file mode 100644 index 00000000..8a5981db --- /dev/null +++ b/sys/gio/ncarutil/srface.f @@ -0,0 +1,1347 @@ + SUBROUTINE SRFACE (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(NX),Y(NY),Z(MX,NY),M(2,NX,NY),S(6) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE SRFACE DRAWS A PERSPECTIVE PICTURE OF A +C FUNCTION OF TWO VARIABLES WITH HIDDEN LINES +C REMOVED. THE FUNCTION IS APPROXIMATED BY A +C TWO-DIMENSIONAL ARRAY OF HEIGHTS. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C CALL EZSRFC (Z,M,N,ANGH,ANGV,WORK) +C +C ASSUMPTIONS: +C .THE ENTIRE ARRAY IS TO BE DRAWN, +C .THE DATA IS EQUALLY SPACED (IN THE +C X-Y PLANE), +C .NO STEREO PAIRS, +C .SCALING IS CHOSEN INTERNALLY. +C +C IF THESE ASSUMPTIONS ARE NOT MET USE +C CALL SRFACE (X,Y,Z,M,MX,NX,NY,S, +C STEREO) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZSRFC THE M BY N ARRAY TO BE DRAWN. +C +C M +C THE FIRST DIMENSION OF Z. +C +C N +C THE SECOND DIMENSION OF Z. +C +C ANGH +C ANGLE IN DEGREES IN THE X-Y PLANE TO THE +C LINE OF SIGHT (COUNTER-CLOCK WISE FROM +C THE PLUS-X AXIS). +C +C ANGV +C ANGLE IN DEGREES FROM THE X-Y PLANE TO +C THE LINE OF SIGHT (POSITIVE ANGLES ARE +C ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C +C WORK +C A SCRATCH STORAGE DIMENSIONED AT LEAST +C 2*M*N+M+N. +C +C ON OUTPUT Z, M, N, ANGH, ANGV ARE UNCHANGED. WORK +C FOR EZSRFC HAS BEEN WRITTEN IN. +C +C +C ARGUMENTS +C +C ON INPUT X +C FOR SRFACE A LINEAR ARRAY NX LONG CONTAINING THE X +C COORDINATES OF THE POINTS IN THE SURFACE +C APPROXIMATION. SEE NOTE, BELOW. +C +C Y +C THE LINEAR ARRAY NY LONG CONTAINING THE +C Y COORDINATES OF THE POINTS IN THE +C SURFACE APPROXIMATION. SEE NOTE, BELOW. +C +C Z +C AN ARRAY MX BY NY CONTAINING THE SURFACE +C TO BE DRAWN IN NX BY NY CELLS. +C Z(I,J) = F(X(I),Y(J)). SEE NOTE, BELOW. +C +C M +C SCRATCH ARRAY AT LEAST 2*NX*NY WORDS +C LONG. +C +C MX +C FIRST DIMENSION OF Z. +C +C NX +C NUMBER OF POINTS IN THE X DIRECTION +C IN Z. WHEN PLOTTING AN ENTIRE ARRAY, +C MX=NX. SEE APPENDIX 1 OF THE GRAPHICS +C CHAPTER FOR AN EXPLANATION OF USING THIS +C ARGUMENT LIST TO PROCESS ANY PART OF AN +C ARRAY. +C +C NY +C NUMBER OF POINTS IN THE Y DIRECTION IN Z. +C +C S +C S DEFINES THE LINE OF SIGHT. THE VIEWER'S +C EYE IS AT (S(1), S(2), S(3)) AND THE +C POINT LOOKED AT IS AT (S(4), S(5), S(6)). +C THE EYE SHOULD BE OUTSIDE THE BLOCK WITH +C OPPOSITE CORNERS (X(1), Y(1), ZMIN) AND +C (X(NX), Y(NY), ZMAX) AND THE POINT LOOKED +C AT SHOULD BE INSIDE IT. FOR A NICE +C PERSPECTIVE EFFECT, THE DISTANCE BETWEEN +C THE EYE AND THE POINT LOOKED AT SHOULD BE +C 5 TO 10 TIMES THE SIZE OF THE BLOCK. SEE +C NOTE, BELOW. +C +C STEREO +C FLAG TO INDICATE IF STEREO PAIRS ARE TO +C BE DRAWN. 0.0 MEANS NO STEREO PAIR (ONE +C PICTURE). NON-ZERO MEANS PUT OUT TWO +C PICTURES. THE VALUE OF STEREO IS THE +C RELATIVE ANGLE BETWEEN THE EYES. A VALUE +C OF 1.0 PRODUCES STANDARD SEPARATION. +C NEGATIVE STEREO REVERSES THE LEFT AND +C RIGHT FIGURES. +C +C ON OUTPUT X, Y, Z, MX, NX, NY, S, STEREO ARE +C FOR SRFACE UNCHANGED. M HAS BEEN WRITTEN IN. +C +C NOTES . THE RANGE OF Z COMPARED WITH THE RANGE +C OF X AND Y DETERMINES THE SHAPE OF THE +C PICTURE. THEY ARE ASSUMED TO BE IN THE +C SAME UNITS AND NOT WILDLY DIFFERENT IN +C MAGNITUDE. S IS ASSUMED TO BE IN THE +C SAME UNITS AS X, Y, AND Z. +C . PICTURE SIZE CAN BE MADE RELATIVE TO +C DISTANCE. SEE COMMENTS IN SETR. +C . TRN32S CAN BE USED TO TRANSLATE FROM 3 +C SPACE TO 2 SPACE. SEE COMMENTS THERE. +C . DATA WITH EXTREME DISCONTINUITIES MAY +C CAUSE VISIBILITY ERRORS. IF THIS PROBLEM +C OCCURS, USE A DISTANT EYE POSITION +C AWAY FROM THE +Z AXIS. +C . THE DEFAULT LINE COLOR IS SET TO +C COLOR INDEX 1. IF THE USER WISHES TO +C CHANGE THE LINE COLOR, HE CAN DO SO BY +C DEFINING COLOR INDEX 1 BEFORE CALLING +C SRFACE, OR BY PUTTING THE COMMON BLOCK +C SRFINT IN HIS CALLING PROGRAM AND +C DEFINING AND USING COLOR INDEX ISRFMJ +C (DEFAULTED TO 1 IN BLOCKDATA.) +C +C ENTRY POINTS SRFACE, SRFGK, EZSRFC, SETR, DRAWS, TRN32S, +C CLSET, CTCELL, SRFABD +C +C COMMON BLOCKS PWRZ1S, SRFBLK, SRFINT, SRFIP1 +C +C I/O PLOTS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY CONVERTED TO FORTRAN 77 AND GKS IN MARCH 1984. +C +C PREPARED FOR SIGGRAPH, AUGUST 1976. +C +C STANDARDIZED IN JANUARY 1973. +C +C WRITTEN IN DECEMBER 1971. REPLACED K.S.+G. +C ALGORITHM CALLED SOLIDS AT NCAR. +C +C +C ALGORITHM HIGHEST SO FAR IS VISIBLE FROM ABOVE. (SEE +C REFERENCE.) +C +C REFERENCE WRIGHT, T.J., A TWO SPACE SOLUTION TO THE +C HIDDEN LINE PROBLEM FOR PLOTTING A FUNCTION +C OF TWO VARIABLES. IEEE TRANS. COMP., +C PP 28-33, JANUARY 1973. +C +C ACCURACY IF THE ENDS OF A LINE SEGMENT ARE VISIBLE, +C THE MIDDLE IS ASSUMED VISIBLE. +C +C TIMING PROPORTIONAL TO NX*NY. +C +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IFR 1 -1 CALL FRAME FIRST. +C 0 DO NOT CALL FRAME. +C +1 CALL FRAME WHEN DONE. +c +NOAO: The value of ifr has been changed from its default of +1 to 0. +c -NOAO +C +C ISTP 0 STEREO TYPE IF STEREO +C NON-ZERO. +C -1 ALTERNATING FRAMES, +C SLIGHTLY OFFSET (FOR +C MOVIES. IROTS = 0). +C 0 BLANK FRAME BETWEEN +C FOR STEREO SLIDE. +C IROTS = 1). +C +1 BOTH ON SAME FRAME. +C (LEFT PICTURE TO LEFT +C SIDE. IROTS = 0). +C +C IROTS 0 0 +Z IN VERTICAL PLOTTING +C DIRECTION (CINE MODE). +C +1 +Z IN HORIZONTAL +C PLOTTING DIRECTION +C (COMIC MODE). +C +C IDRX 1 +1 DRAW LINES OF CONSTANT +C X. +C 0 DO NOT. +C +C IDRY 1 +1 DRAW LINES OF CONSTANT +C Y. +C 0 DO NOT. +C +C IDRZ 0 +1 DRAW LINES OF CONSTANT +C Z (CONTOUR LINES). +C 0 DO NOT. +C +C IUPPER 0 +1 DRAW UPPER SIDE OF +C SURFACE. +C 0 DRAW BOTH SIDES. +C -1 DRAW LOWER SIDE. +C +C ISKIRT 0 +1 DRAW A SKIRT AROUND THE +C SURFACE. +C BOTTOM = HSKIRT. +C 0 DO NOT. +C +C NCLA 6 APPROXIMATE NUMBER OF +C LEVELS OF CONSTANT Z THAT +C ARE DRAWN IF LEVELS ARE NOT +C SPECIFIED. 40 LEVELS +C MAXIMUM. +C +C THETA .02 ANGLE IN RADIANS BETWEEN +C EYES FOR STEREO PAIRS. +C +C HSKIRT 0. HEIGHT OF SKIRT +C (IF ISKIRT = 1). +C +C CHI 0. HIGHEST LEVEL OF CONSTANT +C Z. +C +C CLO 0. LOWEST LEVEL OF CONSTANT Z. +C +C CINC 0. INCREMENT BETWEEN LEVELS. +C +C [IF CHI, CLO, OR CINC IS ZERO, A NICE +C VALUE IS GENERATED AUTOMATICALLY.] +C +C IOFFP 0 FLAG TO CONTROL USE OF SPECIAL +C VALUE FEATURE. DO NOT HAVE +C BOTH IOFFP=1 AND ISKIRT=1. +C 0 FEATURE NOT IN USE +C +1 FEATURE IN USE. NO LINES +C DRAWN TO DATA POINTS IN Z +C THAT ARE EQUAL TO SPVAL. +C +C SPVAL 0. SPECIAL VALUE USED TO MARK UN- +C KNOWN DATA WHEN IOFFP=1. +C +C +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY), M(2,NX,NY), + 1 S(6) + DIMENSION WIN1(4) ,VP1(4) ,LASF(13) + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +NOAO: common block added 4NOV85 to allow user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO + CALL Q8QST4 ('GRAPHX','SRFACE','SRFACE','VERSION 01') +C +C THIS DRIVER SAVES THE CURRENT NORMALIZATION TRANSFORMATION +C INFORMATION, DEFINES THE NORMALIZATION TRANSFORMATION +C APPROPRIATE FOR SRFGK, CALLS SRFGK, AND RESTORES THE ORIGINAL +C NORMALIZATION TRANSFORMATION. +C +C GET CURRENT NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN (IER,NTORIG) +C +C STORE WINDOW AND VIEWPORT OF NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT (NTORIG,IER,WIN1,VP1) + CALL GETUSV('LS',IOLLS) +C +C SET WINDOW AND VIEWPORT FOR SRFGK +C +c CALL SET(0.,1.,0.,1.,1.,1024.,1.,1024.,1) +c +NOAO: viewport limits now stored in common block noaovp + CALL SET(vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) +c -NOAO +C +C SET LINE COLOR TO INDIVIDUAL (SAVE CURRENT SETTING) +C + CALL GQASF (IER,LASF) + LASFSV = LASF(3) + LASF(3) = 1 + CALL GSASF(LASF) +C +C SET LINE COLOR INDEX TO COMMON VARIABLE ISRFMJ (SAVE +C CURRENT SETTING) +C + CALL GQPLCI (IER,LCISV) + CALL GSPLCI (ISRFMJ) +C +C DRAW PLOT +C + CALL SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C RESTORE INITIAL LINE COLOR SETTINGS +C + LASF(3) = LASFSV + CALL GSASF(LASF) + CALL GSPLCI (LCISV) +C +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION +C + CALL SET(VP1(1),VP1(2),VP1(3),VP1(4),WIN1(1),WIN1(2), + - WIN1(3),WIN1(4),IOLLS) + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY) ,M(2,NX,NY) , + 1 S(6) + DIMENSION MXS(2) ,MXF(2) ,MXJ(2) ,MYS(2), + 1 MYF(2) ,MYJ(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL +c +NOAO: + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C + DATA JF, IF, LY, LX, ICNST /1, 1, 2, 2, 0/ + CALL Q8QST4 ('GRAPHX','SRFACE','SRFGK','VERSION 01') + BIGEST = R1MACH(2) + MMXX = MX + NNXX = NX + NNYY = NY + STER = STEREO + NXP1 = NNXX+1 + NYP1 = NNYY+1 + NLA = NCLA + NSPVAL = ISPVAL + NDRZ = IDRZ + IF (IDRZ .NE. 0) + 1 CALL CLSET (Z,MMXX,NNXX,NNYY,CHI,CLO,CINC,NLA,40,CL,NCL, + 2 ICNST,IOFFP,SPVAL,BIGEST) + IF (IDRZ .NE. 0) NDRZ = 1-ICNST + STHETA = SIN(STER*THETA) + CTHETA = COS(STER*THETA) + RX = S(1)-S(4) + RY = S(2)-S(5) + RZ = S(3)-S(6) + D1 = SQRT(RX*RX+RY*RY+RZ*RZ) + D2 = SQRT(RX*RX+RY*RY) + DX = 0. + DY = 0. + IF (STEREO .EQ. 0.) GO TO 20 + D1 = D1*STEREO*THETA + IF (D2 .GT. 0.) GO TO 10 + DX = D1 + GO TO 20 + 10 AGL = ATAN2(RX,-RY) + DX = D1*COS(AGL) + DY = D1*SIN(AGL) + 20 IROT = IROTS + NPIC = 1 + IF (STER .NE. 0.) NPIC = 2 + FACT = 1. + IF (NRSWT .NE. 0) FACT = RZERO/D1 + IF (ISTP.EQ.0 .AND. STER.NE.0.) IROT = 1 + DO 570 IPIC=1,NPIC + NUPPER = IUPPER + IF (IFR .LT. 0) CALL FRAME +C +C SET UP MAPING FROM FLOATING POINT 3-SPACE TO CRT SPACE. +C + SIGN1 = IPIC*2-3 + EYEX = S(1)+SIGN1*DX + POIX = S(4)+SIGN1*DX + EYEY = S(2)+SIGN1*DY + POIY = S(5)+SIGN1*DY + EYEZ = S(3) + POIZ = S(6) + LL = 0 + XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + LL = IPIC+2*ISTP+3 + IF (STER .EQ. 0.) LL = 1 + IF (NRSWT .NE. 0) GO TO 100 + XXMIN = X(1) + XXMAX = X(NNXX) + YYMIN = Y(1) + YYMAX = Y(NNYY) + UMIN = BIGEST + VMIN = BIGEST + ZZMIN = BIGEST + UMAX = -UMIN + VMAX = -VMIN + ZZMAX = -ZZMIN + DO 40 J=1,NNYY + DO 30 I=1,NNXX + ZZ = Z(I,J) + IF (IOFFP.EQ.1 .AND. ZZ.EQ.SPVAL) GO TO 30 + ZZMAX = AMAX1(ZZMAX,ZZ) + ZZMIN = AMIN1(ZZMIN,ZZ) + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 30 CONTINUE + 40 CONTINUE + IF (ISKIRT .NE. 1) GO TO 70 + NXSTP = NNXX-1 + NYSTP = NNYY-1 + DO 60 J=1,NNYY,NYSTP + DO 50 I=1,NNXX,NXSTP + CALL TRN32S (X(I),Y(J),HSKIRT,UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + WIDTH = UMAX-UMIN + HIGHT = VMAX-VMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 80,100, 90 + 80 UMIN = UMIN+DIF + UMAX = UMAX-DIF + GO TO 100 + 90 VMIN = VMIN-DIF + VMAX = VMAX+DIF + 100 XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + DO 120 J=1,NNYY + DO 110 I=1,NNXX + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + M(1,I,J) = UT + M(2,I,J) = VT + 110 CONTINUE + 120 CONTINUE +C +C INITIALIZE UPPER AND LOWER VISIBILITY ARRAYS +C + DO 130 K=1,1024 + LIMU(K) = 0 + LIML(K) = 1024 + 130 CONTINUE +C +C FIND ORDER TO DRAW LINES +C + NXPASS = 1 + IF (S(1) .GE. X(NNXX)) GO TO 160 + IF (S(1) .LE. X(1)) GO TO 170 + DO 140 I=2,NNXX + LX = I + IF (S(1) .LE. X(I)) GO TO 150 + 140 CONTINUE + 150 MXS(1) = LX-1 + MXJ(1) = -1 + MXF(1) = 1 + MXS(2) = LX + MXJ(2) = 1 + MXF(2) = NNXX + NXPASS = 2 + GO TO 180 + 160 MXS(1) = NNXX + MXJ(1) = -1 + MXF(1) = 1 + GO TO 180 + 170 MXS(1) = 1 + MXJ(1) = 1 + MXF(1) = NNXX + 180 NYPASS = 1 + IF (S(2) .GE. Y(NNYY)) GO TO 210 + IF (S(2) .LE. Y(1)) GO TO 220 + DO 190 J=2,NNYY + LY = J + IF (S(2) .LE. Y(J)) GO TO 200 + 190 CONTINUE + 200 MYS(1) = LY-1 + MYJ(1) = -1 + MYF(1) = 1 + MYS(2) = LY + MYJ(2) = 1 + MYF(2) = NNYY + NYPASS = 2 + GO TO 230 + 210 MYS(1) = NNYY + MYJ(1) = -1 + MYF(1) = 1 + GO TO 230 + 220 MYS(1) = 1 + MYJ(1) = 1 + MYF(1) = NNYY +C +C PUT ON SKIRT ON FRONT SIDE IF WANTED +C + 230 IF (NXPASS.EQ.2 .AND. NYPASS.EQ.2) GO TO 490 + IF (ISKIRT .EQ. 0) GO TO 290 + IN = MXS(1) + IF = MXF(1) + JN = MYS(1) + JF = MYF(1) + IF (NYPASS .NE. 1) GO TO 260 + CALL TRN32S (X(1),Y(JN),HSKIRT,UX1,VX1,DUMMY,1) + CALL TRN32S (X(NNXX),Y(JN),HSKIRT,UX2,VX2,DUMMY,1) + QU = (UX2-UX1)/(X(NNXX)-X(1)) + QV = (VX2-VX1)/(X(NNXX)-X(1)) + YNOW = Y(JN) + DO 240 I=1,NNXX + CALL TRN32S (X(I),YNOW,HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,I,JN),M(2,I,JN),1,0) + 240 CONTINUE + CALL DRAWS (IFIX(UX1),IFIX(VX1),IFIX(UX2),IFIX(VX2),1,1) + IF (IDRY .NE. 0) GO TO 260 + DO 250 I=2,NNXX + CALL DRAWS (M(1,I-1,JN),M(2,I-1,JN),M(1,I,JN),M(2,I,JN),1,1) + 250 CONTINUE + 260 IF (NXPASS .NE. 1) GO TO 290 + CALL TRN32S (X(IN),Y(1),HSKIRT,UY1,VY1,DUMMY,1) + CALL TRN32S (X(IN),Y(NNYY),HSKIRT,UY2,VY2,DUMMY,1) + QU = (UY2-UY1)/(Y(NNYY)-Y(1)) + QV = (VY2-VY1)/(Y(NNYY)-Y(1)) + XNOW = X(IN) + DO 270 J=1,NNYY + CALL TRN32S (XNOW,Y(J),HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,IN,J),M(2,IN,J),1,0) + 270 CONTINUE + CALL DRAWS (IFIX(UY1),IFIX(VY1),IFIX(UY2),IFIX(VY2),1,1) + IF (IDRX .NE. 0) GO TO 290 + DO 280 J=2,NNYY + CALL DRAWS (M(1,IN,J-1),M(2,IN,J-1),M(1,IN,J),M(2,IN,J),1,1) + 280 CONTINUE +C +C PICK PROPER ALGORITHM +C + 290 LI = MXJ(1) + MI = MXS(1)-LI + NI = IABS(MI-MXF(1)) + LJ = MYJ(1) + MJ = MYS(1)-LJ + NJ = IABS(MJ-MYF(1)) +C +C WHEN LINE OF SIGHT IS NEARER TO PARALLEL TO THE X AXIS, +C HAVE J LOOP OUTER-MOST, OTHERWISE HAVE I LOOP OUTER-MOST. +C + IF (ABS(RX) .LE. ABS(RY)) GO TO 360 + IF (ISKIRT.NE.0 .OR. NYPASS.NE.1) GO TO 310 + I = MXS(1) + DO 300 J=2,NNYY + CALL DRAWS (M(1,I,J-1),M(2,I,J-1),M(1,I,J),M(2,I,J),0,1) + 300 CONTINUE + 310 DO 350 II=1,NNXX + I = MI+II*LI + IPLI = I+LI + IF (NYPASS .EQ. 1) GO TO 320 + K = MYS(1) + L = MYS(2) + IF (IDRX .NE. 0) + 1 CALL DRAWS (M(1,I,K),M(2,I,K),M(1,I,L),M(2,I,L),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),K) + 320 DO 340 JPASS=1,NYPASS + LJ = MYJ(JPASS) + MJ = MYS(JPASS)-LJ + NJ = IABS(MJ-MYF(JPASS)) + DO 330 JJ=1,NJ + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (IDRX.NE.0 .AND. JJ.NE.NJ) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,JPLJ), + 2 M(2,I,JPLJ),1,1) + IF (I.NE.MXF(1) .AND. IDRY.NE.0) + 1 CALL DRAWS (M(1,IPLI,J),M(2,IPLI,J),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ .AND. II.NE.NNXX) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE + GO TO 430 + 360 IF (ISKIRT.NE.0 .OR. NXPASS.NE.1) GO TO 380 + J = MYS(1) + DO 370 I=2,NNXX + CALL DRAWS (M(1,I-1,J),M(2,I-1,J),M(1,I,J),M(2,I,J),0,1) + 370 CONTINUE + 380 DO 420 JJ=1,NNYY + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (NXPASS .EQ. 1) GO TO 390 + K = MXS(1) + L = MXS(2) + IF (IDRY .NE. 0) + 1 CALL DRAWS (M(1,K,J),M(2,K,J),M(1,L,J),M(2,L,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,K,MIN0(J,J+LJ)) + 390 DO 410 IPASS=1,NXPASS + LI = MXJ(IPASS) + MI = MXS(IPASS)-LI + NI = IABS(MI-MXF(IPASS)) + DO 400 II=1,NI + I = MI+II*LI + IPLI = I+LI + IF (IDRY.NE.0 .AND. II.NE.NI) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,IPLI,J), + 2 M(2,IPLI,J),1,1) + IF (J.NE.MYF(1) .AND. IDRX.NE.0) + 1 CALL DRAWS (M(1,I,JPLJ),M(2,I,JPLJ),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI .AND. JJ.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 400 CONTINUE + 410 CONTINUE + 420 CONTINUE + 430 IF (ISKIRT .EQ. 0) GO TO 520 +C +C FIX UP IF SKIRT IS USED WITH LINES ONE WAY. +C + IF (IDRX .NE. 0) GO TO 460 + DO 450 IPASS=1,NXPASS + IF (NXPASS .EQ. 2) IF = 1+(IPASS-1)*(NNXX-1) + DO 440 J=2,NNYY + CALL DRAWS (M(1,IF,J-1),M(2,IF,J-1),M(1,IF,J),M(2,IF,J), + 1 1,0) + 440 CONTINUE + 450 CONTINUE + 460 IF (IDRY .NE. 0) GO TO 520 + DO 480 JPASS=1,NYPASS + IF (NYPASS .EQ. 2) JF = 1+(JPASS-1)*(NNYY-1) + DO 470 I=2,NNXX + CALL DRAWS (M(1,I-1,JF),M(2,I-1,JF),M(1,I,JF),M(2,I,JF), + 1 1,0) + 470 CONTINUE + 480 CONTINUE + GO TO 520 +C +C ALL VISIBLE IF VIEWED FROM DIRECTLY ABOVE OR BELOW. +C + 490 IF (NUPPER.GT.0 .AND. S(3).LT.S(6)) GO TO 520 + IF (NUPPER.LT.0 .AND. S(3).GT.S(6)) GO TO 520 + NUPPER = 1 + IF (S(3) .LT. S(6)) NUPPER = -1 + DO 510 I=1,NNXX + DO 500 J=1,NNYY + IF (IDRX.NE.0 .AND. J.NE.NNYY) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,J+1),M(2,I,J+1), + 2 1,0) + IF (IDRY.NE.0 .AND. I.NE.NNXX) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I+1,J),M(2,I+1,J), + 2 1,0) + IF (IDRZ.NE.0 .AND. I.NE.NNXX .AND. J.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,I,J) + 500 CONTINUE + 510 CONTINUE + 520 IF (STER .EQ. 0.) GO TO 560 + IF (ISTP) 540,530,550 + 530 CALL FRAME + 540 CALL FRAME + GO TO 570 + 550 IF (IPIC .NE. 2) GO TO 570 + 560 IF (IFR .GT. 0) CALL FRAME + 570 CONTINUE + RETURN + END + SUBROUTINE EZSRFC (Z,M,N,ANGH,ANGV,WORK) + DIMENSION Z(M,N) ,WORK(1) +C +C WORK(2*M*N+M+N) +C +C PERSPECTIVE PICTURE OF A SURFACE STORED IN A TWO DIMENSIONAL ARRAY +C VIA A VERY SHORT ARGUMENT LIST. +C +C ASSUMPTIONS-- +C THE ENTIRE ARRAY IS TO BE DRAWN, +C THE DATA IS EQUALLY SPACED (IN THE X-Y PLANE), +C NO STEREO PAIRS. +C IF THESE ASSUMPTIONS ARE NOT MET USE SRFACE. +C +C ARGUMENTS-- +C Z THE 2 DIMENSIONAL ARRAY TO BE DRAWN. +C M THE FIRST DIMENSION OF Z. +C N THE SECOND DIMENSION OF Z. +C ANGH ANGLE IN DEGREES IN THE X-Y PLANE TO THE LINE OF SIGHT +C (COUNTER-CLOCK WISE FROM THE PLUS-X AXIS). +C ANGV ANGLE IN DEGREES FROM THE X-Y PLANE TO THE LINE OF SIGHT +C (POSITIVE ANGLES ARE ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C WORK A SCRATCH STORAGE DIMENSIONED AT LEAST 2*M*N+M+N. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 NOFFP ,NSPVAL ,SPV ,BIGEST + DIMENSION S(6) + DATA S(4),S(5),S(6)/0.0,0.0,0.0/ +C +C FACT1 IS THE PERSPECTIVE RATIO AND IS DEFINED TO BE THE RATIO +C MAXIMUM(LENGTH,WIDTH)/HEIGHT +C +C FACT2 IS THE RATIO (LENGTH OF LINE OF SIGHT)/MAXIMUM(LENGTH,WIDTH) +C + DATA FACT1,FACT2/2.0,5.0/ + BIGEST = R1MACH(2) +C +C FIND RANGE OF Z +C + MX = M + NY = N + ANG1 = ANGH*3.14159265358979/180. + ANG2 = ANGV*3.14159265358979/180. + FLO = BIGEST + HI = -FLO + DO 20 J=1,NY + DO 10 I=1,MX + IF (NOFFP.EQ.1 .AND. Z(I,J).EQ.SPV) GO TO 10 + HI = AMAX1(Z(I,J),HI) + FLO = AMIN1(Z(I,J),FLO) + 10 CONTINUE + 20 CONTINUE +C +C SET UP LINEAR X AND Y ARRAYS FOR SRFACE +C + DELTA = (HI-FLO)/(AMAX0(MX,NY)-1.)*FACT1 + XMIN = -(FLOAT(MX/2)*DELTA+FLOAT(MOD(MX+1,2))*DELTA) + YMIN = -(FLOAT(NY/2)*DELTA+FLOAT(MOD(NY+1,2))*DELTA) + DO 30 I=1,MX + WORK(I) = XMIN+FLOAT(I-1)*DELTA + 30 CONTINUE + DO 40 J=1,NY + K = MX+J + WORK(K) = YMIN+FLOAT(J-1)*DELTA + 40 CONTINUE +C +C SET UP EYE POSITION +C + FACTE = (HI-FLO)*FACT1*FACT2 + CANG2 = COS(ANG2) + S(1) = FACTE*CANG2*COS(ANG1) + S(2) = FACTE*CANG2*SIN(ANG1) + S(3) = FACTE*SIN(ANG2)+(FLO+HI)*.5 +C +C READY +C + CALL SRFACE (WORK(1),WORK(MX+1),Z,WORK(K+1),MX,MX,NY,S,0.) + RETURN + END + SUBROUTINE SETR (XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,R0) +C +C THIS ROUTINE ESTABLISHES CERTAIN CONSTANTS SO THAT SRFACE +C PRODUCES A PICTURE WHOSE SIZE CHANGES WITH RESPECT TO THE +C VIEWERS DISTANCE FROM THE OBJECT. IT CAN ALSO BE USED +C WHEN MAKING A MOVIE OF AN OBJECT EVOLVING IN TIME TO KEEP +C IT POSITIONED PROPERLY ON THE SCREEN, SAVING COMPUTER TIME +C IN THE BARGIN. CALL IT WITH R0 NEGATIVE TO TURN OFF THIS +C FEATURE. +C PARAMETERS +C XMIN,XMAX - RANGE OF X ARRAY THAT WILL BE PASSED TO SRFACE. +C YMIN,YMAX - SAME IDEA, BUT FOR Y. +C ZMIN,ZMAX - SAME IDEA, BUT FOR Z. IF A MOVIE IS BEING +C MADE OF AN EVOLVING Z ARRAY, ZMIN AND ZMAX +C SHOULD CONTAIN RANGE OF THE UNION OF ALL THE Z +C ARRAYS. THEY NEED NOT BE EXACT. +C R0 - DISTANCE BETWEEN OBSERVER AND POINT LOOKED AT +C WHEN THE PICTURE IS TO FILL THE SCREEN WHEN +C VIEWED FROM THE DIRECTION WHICH MAKES THE PIC- +C TURE BIGGEST. IF R0 IS NOT POSITIVE, THEN THE +C RELATIVE SIZE FEATURE IS TURNED OFF, AND SUB- +C SEQUENT PICTURES WILL FILL THE SCREEN. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ +C +C + CALL Q8QST4 ('GRAPHX','SRFACE','SETR','VERSION 01') + IF (R0) 10, 10, 20 + 10 NRSWT = 0 + RETURN + 20 NRSWT = 1 + XXMIN = XMIN + XXMAX = XMAX + YYMIN = YMIN + YYMAX = YMAX + ZZMIN = ZMIN + ZZMAX = ZMAX + RZERO = R0 + LL = 0 + XAT = (XXMAX+XXMIN)*.5 + YAT = (YYMAX+YYMIN)*.5 + ZAT = (ZZMAX+ZZMIN)*.5 + ALPHA = -(YYMIN-YAT)/(XXMIN-XAT) + YEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + XEYE = YEYE*ALPHA + YEYE = YEYE+YAT + XEYE = XEYE+XAT + ZEYE = ZAT + CALL TRN32S (XAT,YAT,ZAT,XEYE,YEYE,ZEYE,0) + XMN = XXMIN + XMX = XXMAX + YMN = YYMIN + YMX = YYMAX + ZMN = ZZMIN + ZMX = ZZMAX + CALL TRN32S (XMN,YMN,ZAT,UMN,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMN,DUMMY,VMN,DUMMIE,1) + CALL TRN32S (XMX,YMX,ZAT,UMX,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMX,DUMMY,VMX,DUMMIE,1) + UMIN = UMN + UMAX = UMX + VMIN = VMN + VMAX = VMX + BIGD = SQRT((XXMAX-XXMIN)**2+(YYMAX-YYMIN)**2+(ZZMAX-ZZMIN)**2)*.5 + RETURN + END + SUBROUTINE DRAWS (MX1,MY1,MX2,MY2,IDRAW,IMARK) +C +C THIS ROUTINE DRAWS THE VISIBLE PART OF THE LINE CONNECTING +C (MX1,MY1) AND (MX2,MY2). IF IDRAW .NE. 0, THE LINE IS DRAWN. +C IF IMARK .NE. 0, THE VISIBILITY ARRAY IS MARKED. +C + LOGICAL VIS1 ,VIS2 + DIMENSION PXS(2) ,PYS(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA STEEP/5./ + DATA MX, MY /0, 0/ +C +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO +C MAKE LINE LEFT TO RIGHT. +C + MMX1 = MX1 + MMY1 = MY1 + MMX2 = MX2 + MMY2 = MY2 + IF (MMX1.EQ.NSPVAL .OR. MMX2.EQ.NSPVAL) RETURN + IF (MMX1 .GT. MMX2) GO TO 10 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 20 + 10 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 20 IF (NUPPER .LT. 0) GO TO 180 +C +C CHECK UPPER VISIBILITY. +C + VIS1 = NY1 .GE. (LIMU(NX1)-1) + VIS2 = NY2 .GE. (LIMU(NX2)-1) +C +C VIS1 AND VIS2 TRUE MEANS VISIBLE. +C + IF (VIS1 .AND. VIS2) GO TO 120 +C +C VIS1 AND VIS2 FALSE MEANS INVISIBLE. +C + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 180 +C +C FIND CHANGE POINT. +C + IF (NX1 .EQ. NX2) GO TO 110 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 60 + DO 30 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIMU(K)) GO TO 40 + 30 CONTINUE + 40 IF (ABS(DY) .GE. STEEP) GO TO 90 + 50 NX1 = MX + NY1 = MY + GO TO 120 + 60 DO 70 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIMU(K)) GO TO 80 + 70 CONTINUE + 80 IF (ABS(DY) .GE. STEEP) GO TO 100 + NX2 = MX-1 + NY2 = MY + GO TO 120 + 90 IF (LIMU(MX) .EQ. 0) GO TO 50 + NX1 = MX + NY1 = LIMU(NX1) + GO TO 120 + 100 NX2 = MX-1 + NY2 = LIMU(NX2) + GO TO 120 + 110 IF (VIS1) NY2 = MIN0(LIMU(NX1),LIMU(NX2)) + IF (VIS2) NY1 = MIN0(LIMU(NX1),LIMU(NX2)) + 120 IF (IDRAW .EQ. 0) GO TO 150 +C +C DRAW VISIBLE PART OF LINE. +C + IF (IROT) 130,140,130 + 130 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 150 + 140 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 150 IF (IMARK .EQ. 0) GO TO 180 + IF (NX1 .EQ. NX2) GO TO 170 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 160 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .GT. LIMU(K)) LIMU(K) = LTEMP + 160 CONTINUE + GO TO 180 + 170 LTEMP = MAX0(NY1,NY2) + IF (LTEMP .GT. LIMU(NX1)) LIMU(NX1) = LTEMP + 180 IF (NUPPER) 190,190,370 +C +C SAME IDEA AS ABOVE, BUT FOR LOWER SIDE. +C + 190 IF (MMX1 .GT. MMX2) GO TO 200 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 210 + 200 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 210 VIS1 = NY1 .LE. (LIML(NX1)+1) + VIS2 = NY2 .LE. (LIML(NX2)+1) + IF (VIS1 .AND. VIS2) GO TO 310 + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 300 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 250 + DO 220 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIML(K)) GO TO 230 + 220 CONTINUE + 230 IF (ABS(DY) .GE. STEEP) GO TO 280 + 240 NX1 = MX + NY1 = MY + GO TO 310 + 250 DO 260 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIML(K)) GO TO 270 + 260 CONTINUE + 270 IF (ABS(DY) .GE. STEEP) GO TO 290 + NX2 = MX-1 + NY2 = MY + GO TO 310 + 280 IF (LIML(MX) .EQ. 1024) GO TO 240 + NX1 = MX + NY1 = LIML(NX1) + GO TO 310 + 290 NX2 = MX-1 + NY2 = LIML(NX2) + GO TO 310 + 300 IF (VIS1) NY2 = MAX0(LIML(NX1),LIML(NX2)) + IF (VIS2) NY1 = MAX0(LIML(NX1),LIML(NX2)) + 310 IF (IDRAW .EQ. 0) GO TO 340 + IF (IROT) 320,330,320 + 320 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 340 + 330 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 340 IF (IMARK .EQ. 0) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 360 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 350 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .LT. LIML(K)) LIML(K) = LTEMP + 350 CONTINUE + RETURN + 360 LTEMP = MIN0(NY1,NY2) + IF (LTEMP .LT. LIML(NX1)) LIML(NX1) = LTEMP + 370 RETURN + END + SUBROUTINE TRN32S (X,Y,Z,XT,YT,ZT,IFLAG) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C IFLAG=0 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C IFLAG=1 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. +C USE IFIX(XT) AND IFIX(YT) IN GPL CALLS. +C ZT NOT USED. +C IF LL (IN COMMON) =0 XT AND YT ARE IN THE SAME SCALE AS X, Y, AND Z. +C + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DIMENSION NLU(7) ,NRU(7) ,NBV(7) ,NTV(7) +C +C SAVE INSERTED BY BEN DOMENICO 9/8/85 BECAUSE OF ASSUMPTION THAT +C JUMP, JUMP2, AND JUMP3 ARE PRESERVED BETWEEN CALLS. +C THERE MAY BE OTHER SUCH ASSUMPTIONS AS WELL. +C + SAVE +C +C PICTURE CORNER COORDINATES FOR LL=1 +C + DATA NLU(1),NRU(1),NBV(1),NTV(1)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=2 +C + DATA NLU(2),NRU(2),NBV(2),NTV(2)/ 10, 924, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=3 +C + DATA NLU(3),NRU(3),NBV(3),NTV(3)/ 100,1014, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=4 +C + DATA NLU(4),NRU(4),NBV(4),NTV(4)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=5 +C + DATA NLU(5),NRU(5),NBV(5),NTV(5)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=6 +C + DATA NLU(6),NRU(6),NBV(6),NTV(6)/ 10, 512, 256, 758/ +C +C PICTURE CORNER COORDINATES FOR LL=7 +C + DATA NLU(7),NRU(7),NBV(7),NTV(7)/ 512,1014, 256, 758/ +C +C STORE THE PARAMETERS OF THE SET32 CALL FOR USE WHEN +C TRN32 IS CALLED. +C + IF (IFLAG) 40, 10, 40 + 10 CONTINUE + ASSIGN 60 TO JUMP3 + IF (IOFFP .EQ. 1) ASSIGN 50 TO JUMP3 + AX = X + AY = Y + AZ = Z + EX = XT + EY = YT + EZ = ZT +C +C AS MUCH COMPUTATION AS POSSIBLE IS DONE DURING EXECUTION +C THIS ROUTINE WHEN IFLAG=0 BECAUSE CALLS IN THAT MODE ARE INFREQUENT. +C + DX = AX-EX + DY = AY-EY + DZ = AZ-EZ + D = SQRT(DX*DX+DY*DY+DZ*DZ) + COSAL = DX/D + COSBE = DY/D + COSGA = DZ/D + SINGA = SQRT(1.-COSGA*COSGA) + ASSIGN 120 TO JUMP2 + IF (LL .EQ. 0) GO TO 20 + ASSIGN 100 TO JUMP2 + DELCRT = NRU(LL)-NLU(LL) + U0 = UMIN + V0 = VMIN + U1 = NLU(LL) + V1 = NBV(LL) + U2 = NRU(LL)-NLU(LL) + V2 = NTV(LL)-NBV(LL) + U3 = U2/(UMAX-UMIN) + V3 = V2/(VMAX-VMIN) + U4 = NRU(LL) + V4 = NTV(LL) + IF (NRSWT .EQ. 0) GO TO 20 + U0 = -BIGD + V0 = -BIGD + U3 = U2/(2.*BIGD) + V3 = V2/(2.*BIGD) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE Z AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE Z AXIS, THE 3-SPACE Y AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE Z AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + 20 IF (SINGA .LT. 0.0001) GO TO 30 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 30 SINBE = SQRT(1.-COSBE*COSBE) + R = 1./SINBE + ASSIGN 80 TO JUMP + RETURN + 40 CONTINUE + XX = X + YY = Y + ZZ = Z + GO TO JUMP3,( 50, 60) + 50 IF (ZZ .EQ. SPVAL) GO TO 110 + 60 Q = D/((XX-EX)*COSAL+(YY-EY)*COSBE+(ZZ-EZ)*COSGA) + GO TO JUMP,( 70, 80) + 70 XX = ((EX+Q*(XX-EX)-AX)*COSBE-(EY+Q*(YY-EY)-AY)*COSAL)*R + YY = (EZ+Q*(ZZ-EZ)-AZ)*R + GO TO 90 + 80 XX = ((EZ+Q*(ZZ-EZ)-AZ)*COSAL-(EX+Q*(XX-EX)-AX)*COSGA)*R + YY = (EY+Q*(YY-EY)-AY)*R + 90 GO TO JUMP2,(100,120) +c + NOAO: Clipping is done at the gio level and is unnecessary here. The +c following statements were preventing labels from being positioned properly +c at the edges of the surface plot, even when the viewport had been reset. + 100 xx = u1 + u3 * (fact * xx - u0) + yy = v1 + v3 * (fact * yy - v0) +c 100 XX = AMIN1(U4,AMAX1(U1,U1+U3*(FACT*XX-U0))) +c YY = AMIN1(V4,AMAX1(V1,V1+V3*(FACT*YY-V0))) +c -NOAO + GO TO 120 + 110 XX = NSPVAL + YY = NSPVAL +C + 120 XT = XX + YT = YY + RETURN + END + SUBROUTINE CLSET (Z,MX,NX,NY,CHI,CLO,CINC,NLA,NLM,CL,NCL,ICNST, + 1 IOFFP,SPVAL,BIGEST) + DIMENSION Z(MX,NY) ,CL(NLM) + DATA KK /0/ +C +C CLSET PUTS THE VALUS OF THE CONTOUR LEVELS IN CL +C + ICNST = 0 + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 10, 20, 50 + 10 GLO = HA + HA = CLO + GO TO 50 + 20 GLO = BIGEST + HA = -GLO + DO 40 J=1,NY + DO 30 I=1,NX + IF (IOFFP.EQ.1 .AND. Z(I,J).EQ.SPVAL) GO TO 30 + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 30 CONTINUE + 40 CONTINUE + 50 IF (FANC) 60, 70, 90 + 60 CRAT = -FANC + 70 FANC = (HA-GLO)/CRAT + IF (FANC) 140,140, 80 + 80 P = 10.**(IFIX(ALOG10(FANC)+500.)-500) + FANC = AINT(FANC/P)*P + 90 IF (CHI-CLO) 110,100,110 + 100 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC + 110 DO 120 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 130 + KK = K + CL(K) = CC + 120 CONTINUE + 130 NCL = KK + RETURN + 140 ICNST = 1 + RETURN + END + SUBROUTINE CTCELL (Z,MX,NX,NY,M,I0,J0) +C +C CTCELL COMPUTES LINES OF CONSTANT Z (CONTOUR LINES) IN ONE +C CELL OF THE ARRAY Z FOR THE SRFACE PACKAGE. +C Z,MX,NX,NY ARE THE SAME AS IN SRFACE. +C M BY THE TIME CTCELL IS FIRST CALLED, M CONTAINS +C THE TWO-SPACE PLOTTER LOCATION OF EACH Z POINT. +C U(Z(I,J))=M(1,I,J). V(Z(I,J))=M(2,I,J) +C I0,J0 THE CELL Z(I0,J0) TO Z(I0+1,J0+1) IS THE ONE TO +C BE CONTOURED. +C + DIMENSION Z(MX,NY) ,M(2,NX,NY) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA IDUB/0/ + R(HO,HU) = (HO-CV)/(HO-HU) + I1 = I0 + I1P1 = I1+1 + J1 = J0 + J1P1 = J1+1 + H1 = Z(I1,J1) + H2 = Z(I1,J1P1) + H3 = Z(I1P1,J1P1) + H4 = Z(I1P1,J1) + IF (IOFFP .NE. 1) GO TO 10 + IF (H1.EQ.SPVAL .OR. H2.EQ.SPVAL .OR. H3.EQ.SPVAL .OR. + 1 H4.EQ.SPVAL) RETURN + 10 IF (AMIN1(H1,H2,H3,H4) .GT. CL(NCL)) RETURN + DO 110 K=1,NCL +C +C FOR EACH CONTOUR LEVEL, DESIDE WHICH OF THE 16 BASIC SIT- +C UATIONS EXISTS, THEN INTERPOLATE IN TWO-SPACE TO FIND THE +C END POINTS OF THE CONTOUR LINE SEGMENT WITHIN THIS CELL. +C + CV = CL(K) + K1 = (IFIX(SIGN(1.,H1-CV))+1)/2 + K2 = (IFIX(SIGN(1.,H2-CV))+1)/2 + K3 = (IFIX(SIGN(1.,H3-CV))+1)/2 + K4 = (IFIX(SIGN(1.,H4-CV))+1)/2 + JUMP = 1+K1+K2*2+K3*4+K4*8 + GO TO (120, 30, 50, 60, 70, 20, 80, 90, 90, 80, + 1 40, 70, 60, 50, 30,110),JUMP + 20 IDUB = 1 + 30 RA = R(H1,H2) + MUA = FLOAT(M(1,I1,J1))+RA*FLOAT(M(1,I1,J1P1)-M(1,I1,J1)) + MVA = FLOAT(M(2,I1,J1))+RA*FLOAT(M(2,I1,J1P1)-M(2,I1,J1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 40 IDUB = -1 + 50 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H2,H3) + MUB = FLOAT(M(1,I1,J1P1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVB = FLOAT(M(2,I1,J1P1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + GO TO 100 + 60 RA = R(H2,H3) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 70 RA = R(H3,H2) + MUA = FLOAT(M(1,I1P1,J1P1))+ + 1 RA*FLOAT(M(1,I1,J1P1)-M(1,I1P1,J1P1)) + MVA = FLOAT(M(2,I1P1,J1P1))+ + 1 RA*FLOAT(M(2,I1,J1P1)-M(2,I1P1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + IDUB = 0 + GO TO 100 + 80 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + GO TO 100 + 90 RA = R(H4,H1) + MUA = FLOAT(M(1,I1P1,J1))+RA*FLOAT(M(1,I1,J1)-M(1,I1P1,J1)) + MVA = FLOAT(M(2,I1P1,J1))+RA*FLOAT(M(2,I1,J1)-M(2,I1P1,J1)) + RB = R(H4,H3) + MUB = FLOAT(M(1,I1P1,J1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1P1,J1)) + MVB = FLOAT(M(2,I1P1,J1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1P1,J1)) + IDUB = 0 + 100 CALL DRAWS (MUA,MVA,MUB,MVB,1,0) + IF (IDUB) 90,110, 70 + 110 CONTINUE + 120 RETURN + END diff --git a/sys/gio/ncarutil/strmln.f b/sys/gio/ncarutil/strmln.f new file mode 100644 index 00000000..411caed8 --- /dev/null +++ b/sys/gio/ncarutil/strmln.f @@ -0,0 +1,957 @@ + SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C DIMENSION OF U(IMAX,JPTSY) , V(IMAX,JPTSY) , +C ARGUMENTS WORK(2*IMAX*JPTSY) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE STRMLN DRAWS A STREAMLINE REPRESENTATION OF +C THE FLOW FIELD. THE REPRESENTATION IS +C INDEPENDENT OF THE FLOW SPEED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZSTRM (U,V,WORK,IMAX,JMAX) +C +C ASSUMPTIONS: +C --THE WHOLE ARRAY IS TO BE PROCESSED. +C --THE ARRAYS ARE DIMENSIONED +C U(IMAX,JMAX) , V(IMAX,JMAX) AND +C WORK(2*IMAX*JMAX). +C --WINDOW AND VIEWPORT ARE TO BE CHOSEN +C BY STRMLN. +C --PERIM IS TO BE CALLED. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY, +C NSET,IER) +C +C THE USER MUST CALL FRAME IN THE CALLING +C ROUTINE. +C +C THE USER MAY CHANGE VARIOUS INTERNAL +C PARAMETERS VIA COMMON BLOCKS. SEE BELOW. +C +C ARGUMENTS +C +C ON INPUT U, V +C TWO DIMENSIONAL ARRAYS CONTAINING THE +C VELOCITY FIELDS TO BE PLOTTED. +C (NOTE: IF THE U AND V COMPONENTS +C ARE, FOR EXAMPLE, DEFINED IN CARTESIAN +C COORDINATES AND THE USER WISHES TO PLOT THEM +C ON A DIFFERENT PROJECTION (I.E., STEREO- +C GRAPHIC), THEN THE APPROPRIATE +C TRANSFORMATION MUST BE MADE TO THE U AND V +C COMPONENTS VIA THE FUNCTIONS FU AND FV +C (LOCATED IN DRWSTR). +C +C WORK +C USER PROVIDED WORK ARRAY. THE DIMENSION +C OF THIS ARRAY MUST BE .GE. 2*IMAX*JPTSY. +C CAUTION: THIS ROUTINE DOES NOT CHECK THE +C SIZE OF THE WORK ARRAY. +C +C IMAX +C THE FIRST DIMENSION OF U AND V IN THE +C CALLING PROGRAM. (X-DIRECTION) +C +C IPTSX +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C FIRST SUBSCRIPT DIRECTION. (X-DIRECTION) +C +C JPTSY +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C SECOND SUBSCRIPT DIRECTION. (Y-DIRECTION) +C +C NSET +C FLAG TO CONTROL SCALING +C > 0 STRMLN ASSUMES THAT THE WINDOW +C AND VIEWPORT HAVE BEEN SET BY THE +C USER IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS +C GENERATED BY STRMLN. PERIM IS NOT +C CALLED. +C = 0 STRMLN WILL ESTABLISH THE WINDOW AND +C VIEWPORT TO PROPERLY SCALE THE +C PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW +C THE BORDER. +C < 0 STRMLN ESTABLISHES THE WINDOW +C AND VIEWPORT SO AS TO PLACE THE +C STREAMLINES WITHIN THE LIMITS +C OF THE USER'S WINDOW. PERIM IS +C NOT CALLED. +C +C ON OUTPUT ONLY THE IER ARGUMENT MAY BE CHANGED. ALL +C OTHER ARGUMENTS ARE UNCHANGED. +C +C +C IER +C = 0 WHEN NO ERRORS ARE DETECTED +C = -1 WHEN THE ROUTINE IS CALLED WITH ICYC +C .NE. 0 AND THE DATA ARE NOT CYCLIC +C (ICYC IS AN INTERNAL PARAMETER +C DESCRIBED BELOW); IN THIS CASE THE +C ROUTINE WILL DRAW THE +C STREAMLINES WITH THE NON-CYCLIC +C INTERPOLATION FORMULAS. +C +C ENTRY POINTS STRMLN, DRWSTR, EZSTRM, GNEWPT, CHKCYC +C +C COMMON BLOCKS STR01, STR02, STR03, STR04 +C +C REQUIRED LIBRARY GRIDAL, GBYTES, AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O DRAWS STREAMLINES +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN 1979. +C CONVERTED TO FORTRAN 77 AND GKS IN JUNE 1984. +C +C PORTABILITY FORTRAN 77 +C +C ALGORITHM WIND COMPONENTS ARE NORMALIZED TO THE VALUE +C OF DISPL. THE LEAST SIGNIFICANT TWO +C BITS OF THE WORK ARRAY ARE +C UTILIZED AS FLAGS FOR EACH GRID BOX. FLAG 1 +C INDICATES WHETHER ANY STREAMLINE HAS +C PREVIOUSLY PASSED THROUGH THIS BOX. FLAG 2 +C INDICATES WHETHER A DIRECTIONAL ARROW HAS +C ALREADY APPEARED IN A BOX. JUDICIOUS USE +C OF THESE FLAGS PREVENTS OVERCROWDING OF +C STREAMLINES AND DIRECTIONAL ARROWS. +C EXPERIENCE INDICATES THAT A FINAL PLEASING +C PICTURE IS PRODUCED WHEN STREAMLINES ARE +C INITIATED IN THE CENTER OF A GRID BOX. THE +C STREAMLINES ARE DRAWN IN ONE DIRECTION THEN +C IN THE OPPOSITE DIRECTION. +C +C REFERENCE THE TECHNIQUES UTILIZED HERE ARE DESCRIBED +C IN AN ARTICLE BY THOMAS WHITTAKER (U. OF +C WISCONSIN) WHICH APPEARED IN THE NOTES AND +C CORRESPONDENCE SECTION OF MONTHLY WEATHER +C REVIEW, JUNE 1977. +C +C TIMING HIGHLY VARIABLE +C IT DEPENDS ON THE COMPLEXITY OF THE +C FLOW FIELD AND THE PARAMETERS: DISPL, +C DISPC , CSTOP , INITA , INITB , ITERC , +C AND IGFLG. (SEE BELOW FOR A DISCUSSION +C OF THESE PARAMETERS.) IF ALL VALUES +C ARE DEFAULT, THEN A SIMPLE LINEAR +C FLOW FIELD FOR A 40 X 40 GRID WILL +C TAKE ABOUT 0.4 SECONDS ON THE CRAY1-A; +C A FAIRLY COMPLEX FLOW FIELD WILL TAKE ABOUT +C 1.5 SECONDS ON THE CRAY1-A. +C +C +C INTERNAL PARAMETERS +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C EXT 0.25 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO +C IPTSX AND JPTSY EXCEPT IN +C THE CASE WHEN MIN(IPTSX,JPT +C / MAX(IPTSX,JPTSY) .LT. EXT; +C IN THAT CASE A SQUARE +C GRAPH IS PLOTTED. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF +C PLOT. (SEE ALSO EXT.) +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0.0 = LEFT EDGE OF FRAME) +C (1.0 = RIGHT EDGE OF FRAME) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT. +C (0.0 = BOTTOM ; 1.0 = TOP) +C +C (YBT+SIDE AND XLT+SIDE MUST +C BE .LE. 1. ) +C +C INITA 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE TO +C START A STREAMLINE. +C FOR EXAMPLE, A VALUE OF 4 +C MEANS THAT EVERY FOURTH +C GRID BOX IS ELIGIBLE ; A +C VALUE OF 2 MEANS THAT EVERY +C OTHER GRID BOX IS ELIGIBLE. +C (SEE INITB) +C +C INITB 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE FOR +C DIRECTION ARROWS. +C IF THE USER CHANGES THE +C DEFAULT VALUES OF INITA +C AND/OR INITB, IT SHOULD +C BE DONE SUCH THAT +C MOD(INITA,INITB) = 0 . +C FOR A DENSE GRID TRY +C INITA=4 AND INITB=2 TO +C REDUCE THE CPU TIME. +C +C AROWL 0.33 LENGTH OF DIRECTION ARROW. +C FOR EXAMPLE, 0.33 MEANS +C EACH DIRECTIONAL ARROW WILL +C TAKE UP A THIRD OF A GRID +C BOX. +C +C ITERP 35 EVERY 'ITERP' ITERATIONS +C THE STREAMLINE PROGRESS +C IS CHECKED. +C +C ITERC -99 THE DEFAULT VALUE OF THIS +C PARAMETER IS SUCH THAT +C IT HAS NO EFFECT ON THE +C CODE. WHEN SET TO SOME +C POSITIVE VALUE, THE PROGRAM +C WILL CHECK FOR STREAMLINE +C CROSSOVER EVERY 'ITERC' +C ITERATIONS. (THE ROUTINE +C CURRENTLY DOES THIS EVERY +C TIME IT ENTERS A NEW GRID +C BOX.) CAUTION: WHEN +C THIS PARAMETER IS ACTIVATED +C CPU TIME WILL INCREASE. +C +C IGFLG 0 A VALUE OF ZERO MEANS THAT +C THE SIXTEEN POINT BESSEL +C INTERPOLATION FORMULA WILL +C BE UTILIZED WHERE POSSIBLE; +C WHEN NEAR THE GRID EDGES, +C QUADRATIC AND BI-LINEAR +C INTERPOLATION WILL BE +C USED. THIS MIXING OF +C INTERPOLATION SCHEMES CAN +C SOMETIMES CAUSE SLIGHT +C RAGGEDNESS NEAR THE EDGES +C OF THE PLOT. IF IGFLG.NE.0, +C THEN ONLY THE BILINEAR +C INTERPOLATION FORMULA +C IS USED; THIS WILL GENERALLY +C RESULT IN SLIGHTLY FASTER +C PLOT TIMES BUT A LESS +C PLEASING PLOT. +C +C IMSG 0 IF ZERO, THEN NO MISSING +C U AND V COMPONENTS ARE +C PRESENT. +C IF .NE. 0, STRMLN WILL +C UTILIZE THE +C BI-LINEAR INTERPOLATION +C SCHEME AND TERMINATE IF +C ANY DATA POINTS ARE MISSING. +C +C UVMSG 1.E+36 VALUE ASSIGNED TO A MISSING +C POINT. +C +C ICYC 0 ZERO MEANS THE DATA ARE +C NON-CYCLIC IN THE X +C DIRECTION. +C IF .NE 0, THE +C CYCLIC INTERPOLATION +C FORMULAS WILL BE USED. +C (NOTE: EVEN IF THE DATA +C ARE CYCLIC IN X LEAVING +C ICYC = 0 WILL DO NO HARM.) +C +C DISPL 0.33 THE WIND SPEED IS +C NORMALIZED TO THIS VALUE. +C (SEE THE DISCUSSION BELOW.) +C +C DISPC 0.67 THE CRITICAL DISPLACEMENT. +C IF AFTER 'ITERP' ITERATIONS +C THE STREAMLINE HAS NOT +C MOVED THIS DISTANCE, THE +C STREAMLINE WILL BE +C TERMINATED. +C +C CSTOP 0.50 THIS PARAMETER CONTROLS +C THE SPACING BETWEEN +C STREAMLINES. THE CHECKING +C IS DONE WHEN A NEW GRID +C BOX IS ENTERED. +C +C DISCUSSION OF ASSUME A VALUE OF 0.33 FOR DISPL. THIS +C DISPL,DISPC MEANS THAT IT WILL TAKE THREE STEPS TO MOVE +C AND CSTOP ACROSS ONE GRID BOX IF THE FLOW WAS ALL IN THE +C X DIRECTION. IF THE FLOW IS ZONAL, THEN A +C LARGER VALUE OF DISPL IS IN ORDER. +C IF THE FLOW IS HIGHLY TURBULENT, THEN +C A SMALLER VALUE IS IN ORDER. NOTE: THE SMALLER +C DISPL, THE MORE THE CPU TIME. A VALUE +C OF 2 TO 4 TIMES DISPL IS A REASONABLE VALUE +C FOR DISPC. DISPC SHOULD ALWAYS BE GREATER +C THAN DISPL. A VALUE OF 0.33 FOR CSTOP WOULD +C MEAN THAT A MAXIMUM OF THREE STREAM- +C LINES WILL BE DRAWN PER GRID BOX. THIS MAX +C WILL NORMALLY ONLY OCCUR IN AREAS OF SINGULAR +C POINTS. +C +C *************************** +C ANY OR ALL OF THE ABOVE +C PARAMETERS MAY BE CHANGED +C BY UTILIZING COMMON BLOCKS +C STR02 AND/OR STR03 +C *************************** +C +C UXSML 1.E-50 THE SMALLEST REAL NUMBER +C ON THE HOST COMPUTER. THIS +C IS SET AUTOMATICALLY BY +C R1MACH. +C +C NCHK 750 THIS PARAMETER IS LOCATED +C IN DRWSTR. IT SPECIFIES THE +C LENGTH OF THE CIRCULAR +C LISTS USED FOR CHECKING +C FOR STRMLN CROSSOVERS. +C FOR MOST PLOTS THIS NUMBER +C MAY BE REDUCED TO 500 +C OR LESS AND THE PLOTS WILL +C NOT BE ALTERED. +C +C ISKIP NUMBER OF BITS TO BE +C SKIPPED TO GET TO THE +C LEAST TWO SIGNIFICANT BITS +C IN A FLOATING POINT NUMBER. +C THE DEFAULT VALUE IS SET TO +C I1MACH(5) - 2 . THIS VALUE +C MAY HAVE TO BE CHANGED +C DEPENDING ON THE TARGET +C COMPUTER, SEE SUBROUTINE +C DRWSTR. +C +C +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) , + 1 WORK(1) + DIMENSION WNDW(4) ,VWPRT(4) +C + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR02/ EXT , SIDE , XLT , YBT + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C + EXT = 0.25 + SIDE = 0.90 + XLT = 0.05 + YBT = 0.05 +C + INITA = 2 + INITB = 2 + AROWL = 0.33 + ITERP = 35 + ITERC = -99 + IGFLG = 0 + ICYC = 0 + IMSG = 0 +C +NOAO +C UVMSG = 1.E+36 + uvmsg = 1.E+16 +C -NOAO + DISPL = 0.33 + DISPC = 0.67 + CSTOP = 0.50 +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'STRMLN', 'VERSION 01') +C + IER = 0 +C +C LOAD THE COMMUNICATION COMMON BLOCK WITH PARAMETERS +C + IS = 1 + IEND = IPTSX + JS = 1 + JEND = JPTSY + IEND1 = IEND-1 + JEND1 = JEND-1 + IEND2 = IEND-2 + JEND2 = JEND-2 + XNX = FLOAT(IEND-IS+1) + XNY = FLOAT(JEND-JS+1) + ICYC1 = ICYC + IGFL1 = IGFLG + IMSG1 = 0 +C +C IF ICYC .NE. 0 THEN CHECK TO MAKE SURE THE CYCLIC CONDITION EXISTS. +C + IF (ICYC1.NE.0) CALL CHKCYC (U,V,IMAX,JPTSY,IER) +C +C SAVE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN ( IERR,NTORIG ) +C +C SET UP SCALING +C + IF (NSET) 10 , 20 , 60 + 10 CALL GETUSV ( 'LS' , ITYPE ) + CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + CALL GETUSV('LS',IOLLS) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + GO TO 55 +C + 20 ITYPE = 1 + X1 = XLT + X2 = (XLT+SIDE) + Y1 = YBT + Y2 = (YBT+SIDE) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + IF (AMIN1(XNX,XNY)/AMAX1(XNX,XNY).LT.EXT) GO TO 50 + IF (XNX-XNY) 30, 50, 40 + 30 X2 = (SIDE*(XNX/XNY) + XLT) + GO TO 50 + 40 Y2 = (SIDE*(XNY/XNX) + YBT) + 50 CONTINUE +C +C CENTER THE PLOT +C + DX = 0.25*( 1. - (X2-X1) ) + DY = 0.25*( 1. - (Y2-Y1) ) + X1 = (XLT+DX) + X2 = (X2+DX ) + Y1 = (YBT+DY) + Y2 = (Y2+DY ) +C + 55 CONTINUE +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT ( 1,IERR,WNDW,VWPRT ) +C +C DEFINE AND SELECT NORMALIZATION TRANS, SET LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,ITYPE) +C + IF (NSET.EQ.0) CALL PERIM (1,0,1,0) +C + 60 CONTINUE +C +C DRAW THE STREAMLINES +C . BREAK THE WORK ARRAY INTO TWO PARTS. SEE DRWSTR FOR FURTHER +C . COMMENTS ON THIS. +C + CALL DRWSTR (U,V,WORK(1),WORK(IMAX*JPTSY+1),IMAX,JPTSY) +C +C RESET NORMALIATION TRANSFORMATION 1 TO ORIGINAL VALUES +C + IF (NSET .LE. 0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + ENDIF + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE DRWSTR (U,V,UX,VY,IMAX,JPTSY) +C + PARAMETER (NCHK=750) +C +C THIS ROUTINE DRAWS THE STREAMLINES. +C . THE XCHK AND YCHK ARRAYS SERVE AS A CIRCULAR LIST. THEY +C . ARE USED TO PREVENT LINES FROM CROSSING ONE ANOTHER. +C +C THE WORK ARRAY HAS BEEN BROKEN UP INTO TWO ARRAYS FOR CLARITY. THE +C . TOP HALF OF WORK (CALLED UX) WILL HAVE THE NORMALIZED (AND +C . POSSIBLY TRANSFORMED) U COMPONENTS AND WILL BE USED FOR BOOK +C . KEEPING. THE LOWER HALF OF THE WORK ARRAY (CALLED VY) WILL +C . CONTAIN THE NORMALIZED (AND POSSIBLY TRANSFORMED) V COMPONENTS. +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + 1 , UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP + COMMON /STR04/ XCHK(NCHK) ,YCHK(NCHK) , NUMCHK , UXSML +C +C + SAVE +C +C STATEMENT FUNCTIONS FOR SPATIAL AND VELOCITY TRANSFORMATIONS. +C . (IF THE USER WISHES OTHER TRANSFORMATIONS REPLACE THESE STATEMENT +C . FUNCTIONS WITH THE APPROPRIATE NEW ONES, OR , IF THE TRANSFORMA- +C . TIONS ARE COMPLICATED DELETE THESE STATEMENT FUNCTIONS +C . AND ADD EXTERNAL ROUTINES WITH THE SAME NAMES TO DO THE TRANS- +C . FORMING.) +C + FX(X,Y) = X + FY(X,Y) = Y + FU(X,Y) = X + FV(X,Y) = Y +C +C INITIALIZE +C + ISKIP = I1MACH(5) - 2 + ISKIP1 = ISKIP + 1 + UXSML = R1MACH(1) +C +C + NUMCHK = NCHK + LCHK = 1 + ICHK = 1 + XCHK(1) = 0. + YCHK(1) = 0. + KFLAG = 0 + IZERO = 0 + IONE = 1 + ITWO = 2 +C +C +C COMPUTE THE X AND Y NORMALIZED (AND POSSIBLY TRANSFORMED) +C . DISPLACEMENT COMPONENTS (UX AND VY). +C + DO 40 J=JS,JEND + DO 30 I=IS,IEND + IF (U(I,J).EQ.0. .AND. V(I,J).EQ.0.) GO TO 10 + UX(I,J) = FU(U(I,J),V(I,J)) + VY(I,J) = FV(U(I,J),V(I,J)) + CON = DISPL/SQRT(UX(I,J)*UX(I,J) + VY(I,J)*VY(I,J)) + UX(I,J) = CON*UX(I,J) + VY(I,J) = CON*VY(I,J) +C + IF(UX(I,J) .EQ. 0.) UX(I,J) = CON*FU(UXSML,V(I,J)) +C + GO TO 20 + 10 CONTINUE +C +C BOOKKEEPING IS DONE IN THE LEAST SIGNIFICANT BITS OF THE UX ARRAY. +C . WHEN UX(I,J) IS EXACTLY ZERO THIS CAN PRESENT SOME PROBLEMS. +C . TO GET AROUND THIS PROBLEM SET IT TO SOME VERY SMALL NUMBER. +C + UX(I,J) = FU(UXSML,0.) + VY(I,J) = 0. +C +C MASK OUT THE LEAST SIGNIFICANT TWO BITS AS FLAGS FOR EACH GRID BOX +C . A GRID BOX IS ANY REGION SURROUNDED BY FOUR GRID POINTS. +C . FLAG 1 INDICATES WHETHER ANY STREAMLINE HAS PREVIOUSLY PASSED +C . THROUGH THIS BOX. +C . FLAG 2 INDICATES WHETHER ANY DIRECTIONAL ARROW HAS ALREADY +C . APPEARED IN THIS BOX. +C . JUDICIOUS USE OF THESE FLAGS PREVENTS OVERCROWDING OF +C . STREAMLINES AND DIRECTIONAL ARROWS. +C + 20 CALL SBYTES( UX(I,J) , IZERO , ISKIP , 2 , 0 , 1 ) +C + IF (MOD(I,INITA).NE.0 .OR. MOD(J,INITA).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP1, 1 , 0 , 1 ) + IF (MOD(I,INITB).NE.0 .OR. MOD(J,INITB).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP , 1 , 0 , 1 ) +C + 30 CONTINUE + 40 CONTINUE +C + 50 CONTINUE +C +C START A STREAMLINE. EXPERIENCE HAS SHOWN THAT A PLEASING PICTURE +C . WILL BE PRODUCED IF NEW STREAMLINES ARE STARTED ONLY IN GRID +C . BOXES THAT PREVIOUSLY HAVE NOT HAD OTHER STREAMLINES PASS THROUGH +C . THEM. AS LONG AS A REASONABLY DENSE PATTERN OF AVAILABLE BOXES +C . IS INITIALLY PRESCRIBED, THE ORDER OF SCANNING THE GRID PTS. FOR +C . AVAILABLE BOXES IS IMMATERIAL +C +C FIND AN AVAILABLE BOX FOR STARTING A STREAMLINE +C + IF (KFLAG.NE.0) GO TO 90 + DO 70 J=JS,JEND1 + DO 60 I=IS,IEND1 + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , IONE ) .EQ. IZERO ) GO TO 80 + 60 CONTINUE + 70 CONTINUE +C +C MUST BE NO AVAILABLE BOXES FOR STARTING A STREAMLINE +C + GO TO 190 + 80 CONTINUE +C +C INITILIZE PARAMETERS FOR STARTING A STREAMLINE +C . TURN THE BOX OFF FOR STARTING A STREAMLINE +C . CHECK TO SEE IF THIS BOX HAS MISSING DATA (IMSG.NE.0). IF SO , +C . FIND A NEW STARTING BOX +C + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF ( IMSG.EQ.0) GO TO 85 + IF (U(I,J).EQ.UVMSG .OR. U(I,J+1).EQ.UVMSG .OR. + 1 U(I+1,J).EQ.UVMSG .OR. U(I+1,J+1).EQ.UVMSG) GO TO 50 +C + 85 ISAV = I + JSAV = J + KFLAG = 1 + PLMN1 = +1. + GO TO 100 + 90 CONTINUE +C +C COME TO HERE TO DRAW IN THE OPPOSITE DIRECTION +C + KFLAG = 0 + PLMN1 = -1. + I = ISAV + J = JSAV + 100 CONTINUE +C +C INITIATE THE DRAWING SEQUENCE +C . START ALL STREAMLINES IN THE CENTER OF A BOX +C + NBOX = 0 + ITER = 0 + IF (KFLAG.NE.0) ICHKB = ICHK+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + X = FLOAT(I)+0.5 + Y = FLOAT(J)+0.5 + XBASE = X + YBASE = Y + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( (KFLAG.EQ.0) .OR. (IAND( IUX , ITWO ) .NE. 0 ) ) GO TO 110 +C +C GRID BOX MUST BE ELIGIBLE FOR A DIRECTIONAL ARROW +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) + MFLAG = 1 + GO TO 160 +C + 110 CONTINUE +C +C PLOT LOOP +C . CHECK TO SEE IF THE STREAMLINE HAS ENTERED A NEW GRID BOX +C + IF (I.NE.IFIX(X) .OR. J.NE.IFIX(Y)) GO TO 120 +C +C MUST BE IN SAME BOX CALCULATE THE DISPLACEMENT COMPONENTS +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) +C +C UPDATE THE POSITION AND DRAW THE VECTOR +C + X = X+PLMN1*DELX + Y = Y+PLMN1*DELY + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,1) + ITER = ITER+1 +C +C CHECK STREAMLINE PROGRESS EVERY 'ITERP' OR SO ITERATIONS +C + IF (MOD(ITER,ITERP).NE.0) GO TO 115 + IF (ABS(X-XBASE).LT.DISPC .AND. ABS(Y-YBASE).LT.DISPC ) GO TO 50 + XBASE = X + YBASE = Y + GO TO 110 + 115 CONTINUE +C +C SHOULD THE CIRCULAR LISTS BE CHECKED FOR STREAMLINE CROSSOVER +C + IF ( (ITERC.LT.0) .OR. (MOD(ITER,ITERC).NE.0) ) GO TO 110 +C +C MUST WANT THE CIRCULAR LIST CHECKED +C + GO TO 130 + 120 CONTINUE +C +C MUST HAVE ENTERED A NEW GRID BOX CHECK FOR THE FOLLOWING : +C . (1) ARE THE NEW POINTS ON THE GRID +C . (2) CHECK FOR MISSING DATA IF MSG DATA FLAG (IMSG) HAS BEEN SET. +C . (3) IS THIS BOX ELIGIBLE FOR A DIRECTIONAL ARROW +C . (4) LOCATION OF THIS ENTRY VERSUS OTHER STREAMLINE ENTRIES +C + NBOX = NBOX+1 +C +C CHECK (1) +C + IF (IFIX(X).LT.IS .OR. IFIX(X).GT.IEND1) GO TO 50 + IF (IFIX(Y).LT.JS .OR. IFIX(Y).GT.JEND1) GO TO 50 +C +C CHECK (2) +C + IF ( IMSG.EQ.0) GO TO 125 + II = IFIX(X) + JJ = IFIX(Y) + IF (U(II,JJ).EQ.UVMSG .OR. U(II,JJ+1).EQ.UVMSG .OR. + 1 U(II+1,JJ).EQ.UVMSG .OR. U(II+1,JJ+1).EQ.UVMSG) GO TO 50 + 125 CONTINUE +C +C CHECK (3) +C + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , ITWO ) .NE. 0) GO TO 130 + MFLAG = 2 + GO TO 160 + 130 CONTINUE +C +C CHECK (4) +C + DO 140 LOC=1,LCHK + IF (ABS( X-XCHK(LOC) ).GT.CSTOP .OR. + 1 ABS( Y-YCHK(LOC) ).GT.CSTOP) GO TO 140 + LFLAG = 1 + IF (ICHKB.LE.ICHK .AND. LOC.GE.ICHKB .AND. LOC.LE.ICHK) LFLAG = 2 + IF (ICHKB.GE.ICHK .AND. (LOC.GE.ICHKB .OR. LOC.LE.ICHK)) LFLAG = 2 + IF (LFLAG.EQ.1) GO TO 50 + 140 CONTINUE + LCHK = MIN0(LCHK+1,NUMCHK) + ICHK = ICHK+1 + IF (ICHK.GT.NUMCHK) ICHK = 1 + XCHK(ICHK) = X + YCHK(ICHK) = Y + I = IFIX(X) + J = IFIX(Y) + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF (NBOX.LT.5) GO TO 150 + ICHKB = ICHKB+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + 150 CONTINUE + GO TO 110 +C + 160 CONTINUE +C +C THIS SECTION DRAWS A DIRECTIONAL ARROW BASED ON THE MOST RECENT DIS- +C . PLACEMENT COMPONENTS ,DELX AND DELY, RETURNED BY GNEWPT. IN EARLIE +C . VERSIONS THIS WAS A SEPARATE SUBROUTINE (CALLED DRWDAR). IN THAT +C . CASE ,HOWEVER, FX AND FY WERE DEFINED EXTERNAL SINCE THESE +C . FUNCTIONS WERE USED BY BOTH DRWSTR AND DRWDAR. IN ORDER TO +C . MAKE ALL DEFAULT TRANSFORMATIONS STATEMENT FUNCTIONS I HAVE +C . PUT DRWDAR HERE AND I WILL USE MFLAG TO RETURN TO THE CORRECT +C . LOCATION IN THE CODE. +C + IF ( (DELX.EQ.0.) .AND. (DELY.EQ.0.) ) GO TO 50 +C + CALL SBYTES( UX(I,J) ,IONE , ISKIP , 1 ,0 , 1 ) + D = ATAN2(-DELX,DELY) + D30 = D+0.5 + 170 YY = -AROWL*COS(D30)+Y + XX = +AROWL*SIN(D30)+X + CALL FL2INT (FX(XX,YY),FY(XX,YY),IFXX,IFYY) + CALL PLOTIT (IFXX,IFYY,1) + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + IF (D30.LT.D) GO TO 180 + D30 = D-0.5 + GO TO 170 + 180 IF (MFLAG.EQ.1) GO TO 110 + IF (MFLAG.EQ.2) GO TO 130 +C + 190 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE GNEWPT (UX,VY,IMAX,JPTSY) +C +C INTERPOLATION ROUTINE TO CALCULATE THE DISPLACEMANT COMPONENTS +C . THE PHILOSPHY HERE IS TO UTILIZE AS MANY POINTS AS POSSIBLE +C . (WITHIN REASON) IN ORDER TO OBTAIN A PLEASING AND ACCURATE PLOT. +C . INTERPOLATION SCHEMES DESIRED BY OTHER USERS MAY EASILY BE +C . SUBSTITUTED IF DESIRED. +C + DIMENSION UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C +C FDLI - DOUBLE LINEAR INTERPOLATION FORMULA +C FBESL - BESSEL 16 PT INTERPOLATION FORMULA ( MOST USED FORMULA ) +C FQUAD - QUADRATIC INTERPOLATION FORMULA +C + FDLI(Z,Z1,Z2,Z3,DX,DY) = (1.-DX)*((1.-DY)*Z +DY*Z1) + 1 + DX *((1.-DY)*Z2+DY*Z3) + FBESL(Z,ZP1,ZP2,ZM1,DZ)=Z+DZ*(ZP1-Z+0.25*(DZ-1.)*((ZP2-ZP1-Z+ZM1) + 1 +0.666667*(DZ-0.5)*(ZP2-3.*ZP1+3.*Z-ZM1))) + FQUAD(Z,ZP1,ZM1,DZ)=Z+0.5*DZ*(ZP1-ZM1+DZ*(ZP1-2.*Z+ZM1)) +C + DX = X-AINT(X) + DY = Y-AINT(Y) +C + IF( IMSG.NE.0.OR.IGFLG.NE.0) GO TO 20 +C + IM1 = I-1 + IP2 = I+2 +C +C DETERMINE WHICH INTERPOLATION FORMULA TO USE DEPENDING ON I,J LOCATION +C . THE FIRST CHECK IS FOR I,J IN THE GRID INTERIOR. +C + IF (J.GT.JS .AND. J.LT.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) + 1 GO TO 30 + IF (J.EQ.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) GO TO 40 + IF (J.EQ.JS) GO TO 20 +C + IF (ICYC1.EQ.1) GO TO 10 +C +C MUST NOT BE CYCLIC +C + IF (I.EQ.IS) GO TO 20 + IF (I.EQ.IEND1) GO TO 50 + GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC IN THE X DIRECTION +C + IF (I.EQ.IS .AND. J.LT.JEND1) GO TO 12 + IF (I.EQ.IEND1 .AND. J.LT.JEND1) GO TO 14 + IF (J.EQ.JEND1 .AND. I.EQ.IS) GO TO 16 + IF (J.EQ.JEND1 .AND. I.EQ.IEND1) GO TO 18 + GO TO 20 + 12 IM1 = IEND1 + GO TO 30 + 14 IP2 = IS+1 + GO TO 30 + 16 IM1 = IEND1 + GO TO 40 + 18 IP2 = IS+1 + GO TO 40 +C + 20 CONTINUE +C +C DOUBLE LINEAR INTERPOLATION FORMULA. THIS SCHEME WORKS AT ALL POINTS +C . BUT THE RESULTING STREAMLINES ARE NOT AS PLEASING AS THOSE DRAWN +C . BY FBESL OR FQUAD. CURRENTLY THIS IS USED AT THIS IS UTILIZED +C . ONLY AT CERTAIN BOUNDARY POINTS OR IF IGFLG IS NOT EQUAL TO ZERO. +C + DELX = FDLI (UX(I,J),UX(I,J+1),UX(I+1,J),UX(I+1,J+1),DX,DY) + DELY = FDLI (VY(I,J),VY(I,J+1),VY(I+1,J),VY(I+1,J+1),DX,DY) + RETURN + 30 CONTINUE +C +C USE A 16 POINT BESSEL INTERPOLATION SCHEME +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + UJP2 = FBESL (UX(I,J+2),UX(I+1,J+2),UX(IP2,J+2),UX(IM1,J+2),DX) + DELX = FBESL (UJ,UJP1,UJP2,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + VJP2 = FBESL (VY(I,J+2),VY(I+1,J+2),VY(IP2,J+2),VY(IM1,J+2),DX) + DELY = FBESL (VJ,VJP1,VJP2,VJM1,DY) + RETURN + 40 CONTINUE +C +C 12 POINT INTERPOLATION SCHEME APPLICABLE TO ONE ROW FROM TOP BOUNDARY +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + 50 CONTINUE +C +C 9 POINT INTERPOLATION SCHEME FOR USE IN THE NON-CYCLIC CASE +C . AT I=IEND1 ; JS.LT.J AND J.LE.JEND1 +C + UJP1 = FQUAD (UX(I,J+1),UX(I+1,J+1),UX(IM1,J+1),DX) + UJ = FQUAD (UX(I,J),UX(I+1,J),UX(IM1,J),DX) + UJM1 = FQUAD (UX(I,J-1),UX(I+1,J-1),UX(IM1,J-1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJP1 = FQUAD (VY(I,J+1),VY(I+1,J+1),VY(IM1,J+1),DX) + VJ = FQUAD (VY(I,J),VY(I+1,J),VY(IM1,J),DX) + VJM1 = FQUAD (VY(I,J-1),VY(I+1,J-1),VY(IM1,J-1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + END + SUBROUTINE EZSTRM(U,V,WORK,IMAX,JMAX) +C + DIMENSION U(IMAX,JMAX) ,V(IMAX,JMAX) ,WORK(1) +C + SAVE +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'EZSTRM', 'VERSION 01') +C + CALL STRMLN(U,V,WORK,IMAX,IMAX,JMAX,0,IER) + RETURN + END + SUBROUTINE CHKCYC (U,V,IMAX,JPTSY,IER) +C +C CHECK FOR CYCLIC CONDITION +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 +C + SAVE + DO 10 J=JS,JEND + IF (U(IS,J).NE.U(IEND,J)) GO TO 20 + IF (V(IS,J).NE.V(IEND,J)) GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC +C + RETURN + 20 CONTINUE +C +C MUST NOT BE CYCLIC +C . CHANGE THE PARAMETER AND SET IER = -1 +C + ICYC1 = 0 + IER = -1 + RETURN +C +C------------------------------------------------------------------ +C REVISION HISTORY +C +C OCTOBER 1979 FIRST ADDED TO ULIB +C +C OCTOBER 1980 ADDED BUGS SECTION +C +C JUNE 1984 REMOVED STATEMENT FUNCTIONS ANDF AND ORF, +C CONVERTED TO FORTRAN77 AND GKS. +C------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/sysint/README b/sys/gio/ncarutil/sysint/README new file mode 100644 index 00000000..38d7b6f8 --- /dev/null +++ b/sys/gio/ncarutil/sysint/README @@ -0,0 +1,2 @@ +SYSINT - This directory contains the System Interface Routines needed +for implementing the GKS based NCAR plotting utilities. diff --git a/sys/gio/ncarutil/sysint/fencode.x b/sys/gio/ncarutil/sysint/fencode.x new file mode 100644 index 00000000..1e2e37d5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/fencode.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <error.h> +include <ctype.h> + +define SZ_FORMAT 11 + +# FENCD -- Format a real variable and return as a spp character string. +# A packed format string is passed as an input argument to define how the +# number is to be encoded. The format of the format string is: +# format string = "(cW.D)" +# where c is one of [EFGI], and where W and D are the field width and +# number of decimal places or precision, respectively. + +procedure fencd (nchars, f_format, spp_outstr, rval) + +int nchars # desired number of output chars +char f_format[SZ_FORMAT] # SPP string containing format +char spp_outstr[nchars+1] # SPP string containing encoded number +real rval # value to be encoded + +char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1] +int ip, op, stridxs() +real x + +begin + # Encode format string for SPRINTF, format "%w.d". Start copying + # Fortran format at char 3, which should follow the EFGI char. + + spp_format[1] = '%' + op = 2 + + if (f_format[1] != '(') + call fatal (1, "Missing lparen in Ncar ENCODE format") + for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) { + spp_format[op] = f_format[ip] + op = op + 1 + } + + # Now add the SPP format character. EFG are the same for sprintf as + # as for Fortran. The integer format is 'd' for decimal in SPP. + + fmtchar = f_format[2] + if (IS_UPPER(fmtchar)) + fmtchar = TO_LOWER (fmtchar) + + switch (fmtchar) { + case 'e', 'f', 'g': + spp_format[op] = fmtchar + case 'i': + spp_format[op] = 'd' + default: + call fatal (1, "Unknown Ncar ENCODE format code") + } + op = op + 1 + spp_format[op] = EOS + x = rval + if (rval > 0) + x = -x + + # Now encode the user supplied variable and return it as a spp + # string. + + iferr { + call sprintf (outstr, MAX_DIGITS, spp_format) + call pargr (x) + } then + call erract (EA_FATAL) + + # Let's try adding a "+" prefix to positive numbers to set if that + # makes nicer plots. Sep86 - This was not a good idea - changed to + # a blank. + + op = stridxs ("-", outstr) + if (rval > 0 && op > 0) + outstr[op] = ' ' + + call strcpy (outstr, spp_outstr, SZ_LINE) +end diff --git a/sys/gio/ncarutil/sysint/fulib.x b/sys/gio/ncarutil/sysint/fulib.x new file mode 100644 index 00000000..1951f26c --- /dev/null +++ b/sys/gio/ncarutil/sysint/fulib.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# FULIB -- Print an error message processed by fortran routine uliber. + +procedure fulib (errcode, upkmsg, msglen) + +int errcode +char upkmsg[ARB] # unpacked string +int msglen # number of chars in string + +pointer sp, sppmsg + +begin + call smark (sp) + call salloc (sppmsg, SZ_LINE, TY_CHAR) + + # Construct error message string + call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n") + call pargi (errcode) + call pargstr (upkmsg) + + # Call error with the constructed message + iferr (call error (errcode, Memc[sppmsg])) + call erract (EA_WARN) + + call sfree (sp) +end diff --git a/sys/gio/ncarutil/sysint/gbytes.x b/sys/gio/ncarutil/sysint/gbytes.x new file mode 100644 index 00000000..b129ffbc --- /dev/null +++ b/sys/gio/ncarutil/sysint/gbytes.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GBYTES -- Locally implemented bit unpacker for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array which is a packed series of bits. +# [array BUFIN], and unpacks them into an array [array BUFOUT]. Received +# integer INDEX is the beginning bit in BUFIN where information is to be +# placed. INDEX is zero indexed. Received integer argument SIZE is the +# number of bits in each "information packet". Received argument SKIP is the +# number of bits to skip between bit packets. For more info, see page 4 of +# the NCAR "Implementaton details for the new metafile translator, version 1.0" + +procedure gbytes (bufin, bufout, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int pack +int offset +int bitupk() # Iraf function to unpack bits + +begin + for (pack = 1; pack <= count ; pack = pack+1) { + # Offset is a bit offset into the input buffer bufin. + # (offset is 1- indexed; INDEX is zero indexed) + + offset = (size + skip) * (pack - 1) + index + 1 + bufout(pack) = bitupk(bufin, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/ishift.x b/sys/gio/ncarutil/sysint/ishift.x new file mode 100644 index 00000000..580996c0 --- /dev/null +++ b/sys/gio/ncarutil/sysint/ishift.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines. + +int procedure ishift (in_word, n) + +int in_word, n +int new_word, bit, index, i +int bitupk() + +begin + if (n > NBITS_INT) + call error (0, "n > NBITS_INT in ishift") + if (n < 0) + # Right end-off shift + new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n)) + else { + # Left circular shift (rotate) + do i = 1, NBITS_INT { + index = n + i + if (index > NBITS_INT) + index = mod ((n + i), NBITS_INT) + bit = bitupk (in_word, i, 1) + call bitpak (bit, new_word, index, 1) + } + } + + return (new_word) +end + + +# IAND -- AND two integers. + +int procedure iand (a, b) + +int a, b +int and() + +begin + return (and (a, b)) +end + + +# IOR -- OR two integers. + +int procedure ior (a, b) + +int a, b +int or() + +begin + return (or (a, b)) +end diff --git a/sys/gio/ncarutil/sysint/mkpkg b/sys/gio/ncarutil/sysint/mkpkg new file mode 100644 index 00000000..f3ba6fb5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/mkpkg @@ -0,0 +1,16 @@ +# Make the system interface for libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + support.f + fencode.x <mach.h> <error.h> <ctype.h> + fulib.x <error.h> + ishift.x <mach.h> + gbytes.x + sbytes.x <mach.h> + spps.f + ; diff --git a/sys/gio/ncarutil/sysint/sbytes.x b/sys/gio/ncarutil/sysint/sbytes.x new file mode 100644 index 00000000..4d4094c3 --- /dev/null +++ b/sys/gio/ncarutil/sysint/sbytes.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# SBYTES -- Locally implemented bit packer for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array of "information packets" +# [array BUFIN], and packs them into a packed array [array BUFOUT] +# received integer argument INDEX points to the beginning bit in BUFOUT +# where information is to be placed. INDEX is zero indexed. +# received integer argument SIZE is the number of bits in each "information +# packet. received argument SKIP is the number of bits to skip between +# bit packets. For more info, see page 6 of the NCAR "Implementaton +# details for the new metafile translator, version 1.0" +# bufin is stuffed into bufout + +procedure sbytes (bufout, bufin, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int metacode_word_length +int pack +int offset + +data metacode_word_length / 16 / + +begin + if (metacode_word_length != NBITS_SHORT) + call error ( 0, " bad metacode word length in SBYTES") + + for (pack = 1; pack <= count; pack = pack + 1) { + # Offset is a bit offset into the output buffer bufout. + # (offset is 1- indexed; INDEX is zero indexed) + # see page 58 of IRAF system interface book + + offset = (size + skip) * (pack - 1) + index + 1 + call bitpak (bufin[pack], bufout, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/spps.f b/sys/gio/ncarutil/sysint/spps.f new file mode 100644 index 00000000..4a394d9e --- /dev/null +++ b/sys/gio/ncarutil/sysint/spps.f @@ -0,0 +1,1797 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C + FUNCTION CFUX (RX) +C +C Given an x coordinate RX in the fractional system, CFUX(RX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CFUX=WD(I)+(RX-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CFUX=10.**CFUX + RETURN + END + FUNCTION CFUY (RY) +C +C Given a y coordinate RY in the fractional system, CFUY(RY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CFUY=WD(I)+(RY-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CFUY=10.**CFUY + RETURN + END + FUNCTION CMFX (IX) +C +C Given an x coordinate IX in the metacode system, CMFX(IX) is an x +C coordinate in the fractional system. +C + CMFX=FLOAT(IX)/32767. + RETURN + END + FUNCTION CMFY (IY) +C +C Given a y coordinate IY in the metacode system, CMFY(IY) is a y +C coordinate in the fractional system. +C + CMFY=FLOAT(IY)/32767. + RETURN + END + FUNCTION CMUX (IX) +C +C Given an x coordinate IX in the metacode system, CMUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CMUX=WD(I)+(FLOAT(IX)/32767.-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CMUX=10.**CMUX + RETURN + END + FUNCTION CMUY (IY) +C +C Given a y coordinate IY in the metacode system, CMUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CMUY=WD(I)+(FLOAT(IY)/32767.-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CMUY=10.**CMUY + RETURN + END + FUNCTION CPFX (IX) +C +C Given an x coordinate IX in the plotter system, CPFX(IX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFX=FLOAT(IX-1)/(2.**MX-1.) + RETURN + END + FUNCTION CPFY (IY) +C +C Given a y coordinate IY in the plotter system, CPFY(IY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFY=FLOAT(IY-1)/(2.**MY-1.) + RETURN + END + FUNCTION CPUX (IX) +C +C Given an x coordinate IX in the plotter system, CPUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CPUX=WD(I)+(FLOAT(IX-1)/(2.**MX-1.)-VP(1))/(VP(2)-VP(1))* + + (WD(3-I)-WD(I)) + IF (LL.GE.3) CPUX=10.**CPUX + RETURN + END + FUNCTION CPUY (IY) +C +C Given a y coordinate IY in the plotter system, CPUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CPUY=WD(I)+(FLOAT(IY-1)/(2.**MY-1.)-VP(3))/(VP(4)-VP(3))* + + (WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CPUY=10.**CPUY + RETURN + END + FUNCTION CUFX (RX) +C +C Given an x coordinate RX in the user system, CUFX(RX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + CUFX=(RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ELSE + CUFX=(ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ENDIF + RETURN + END + FUNCTION CUFY (RY) +C +C Given a y coordinate RY in the user system, CUFY(RY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + CUFY=(RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ELSE + CUFY=(ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ENDIF + RETURN + END + FUNCTION KFMX (RX) +C +C Given an x coordinate RX in the fractional system, KFMX(RX) is an x +C coordinate in the metacode system. +C + KFMX=IFIX(RX*32767.) + RETURN + END + FUNCTION KFMY (RY) +C +C Given a y coordinate RY in the fractional system, KFMY(RY) is a y +C coordinate in the metacode system. +C + KFMY=IFIX(RY*32767.) + RETURN + END + FUNCTION KFPX (RX) +C +C Given an x coordinate RX in the fractional system, KFPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPX=1+IFIX(RX*(2.**MX-1.)) + RETURN + END + FUNCTION KFPY (RY) +C +C Given a y coordinate RY in the fractional system, KFPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPY=1+IFIX(RY*(2.**MX-1.)) + RETURN + END + FUNCTION KMPX (IX) +C +C Given an x coordinate IX in the metacode system, KMPX(IX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPX=1+IFIX((2.**MX-1.)*FLOAT(IX)/32767.) + RETURN + END + FUNCTION KMPY (IY) +C +C Given a y coordinate IY in the metacode system, KMPY(IY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPY=1+IFIX((2.**MY-1.)*FLOAT(IY)/32767.) + RETURN + END + FUNCTION KPMX (IX) +C +C Given an x coordinate IX in the plotter system, KPMX(IX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMX=IFIX(32767.*FLOAT(IX-1)/(2.**MX-1.)) + RETURN + END + FUNCTION KPMY (IY) +C +C Given a y coordinate IY in the plotter system, KPMY(IY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMY=IFIX(32767.*FLOAT(IY-1)/(2.**MY-1.)) + RETURN + END + FUNCTION KUMX (RX) +C +C Given an x coordinate RX in the user system, KUMX(RX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUMX=IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + 32767.) + ELSE + KUMX=IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*32767.) + ENDIF + RETURN + END + FUNCTION KUMY (RY) +C +C Given a y coordinate RY in the user system, KUMY(RY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUMY=IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + 32767.) + ELSE + KUMY=IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*32767.) + ENDIF + RETURN + END + FUNCTION KUPX (RX) +C +C Given an x coordinate RX in the user system, KUPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUPX=1+IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + (2.**MX-1.)) + ELSE + KUPX=1+IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*(2.**MX-1.)) + ENDIF + RETURN + END + FUNCTION KUPY (RY) +C +C Given a y coordinate RY in the user system, KUPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUPY=1+IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + (2.**MY-1.)) + ELSE + KUPY=1+IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*(2.**MY-1.)) + ENDIF + RETURN + END + SUBROUTINE CLSGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C + COMMON /IUTLCM/ IU(100) +C +C Deactivate the metacode workstation, close the workstation, and +C close GKS. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + CALL GCLKS +C + RETURN +C + END + SUBROUTINE CURVE (PX,PY,NP) +C + DIMENSION PX(NP),PY(NP) +C +C CURVE draws the curve defined by the points (PX(I),PY(I)), for I = 1 +C to NP. All coordinates are stated in the user coordinate system. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to draw the curve piecewise. +C + DIMENSION QX(10),QY(10) +C +C If NP is less than or equal to zero, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C If NP is exactly equal to 1, just draw a point. +C + IF (NP.EQ.1) THEN + CALL POINT (PX(1),PY(1)) +C +C Otherwise, draw the curve. +C + ELSE +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Save the current SET parameters. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If the mapping defined by the last SET call was non-reversed and +C linear in both x and y, a single polyline will suffice. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1) THEN + CALL GPL (NP,PX,PY) +C +C Otherwise, piece the line together out of smaller chunks, converting +C the coordinates for each chunk as directed by the last SET call. +C + ELSE + DO 102 IP=1,NP,9 + NQ=MIN0(10,NP-IP+1) + IF (NQ.GE.2) THEN + DO 101 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 101 CONTINUE + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) + CALL GPL (NQ,QX,QY) + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) + END IF + 102 CONTINUE + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE FL2INT (PX,PY,IX,IY) +C +C Given the user coordinates PX and PY of a point, FL2INT returns the +C metacode coordinates IX and IY of that point. +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Declare arrays in which to retrieve the variables defining the current +C window and viewport. +C + DIMENSION WD(4),VP(4) +C +C Get the variables defining the current window and viewport. +C + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) +C +C Compute IX. +C + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + IX=IFIX(((PX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))*32767.) + ELSE + IX=IFIX(((ALOG10(PX)-WD(I))/(WD(3-I)-WD(I))* + + (VP(2)-VP(1))+VP(1))*32767.) + ENDIF +C +C Compute IY. +C + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + IY=IFIX(((PY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))*32767.) + ELSE + IY=IFIX(((ALOG10(PY)-WD(I))/(WD(7-I)-WD(I))* + + (VP(4)-VP(3))+VP(3))*32767.) + ENDIF +C +C Done. +C + RETURN +C + END +C +C +NOAO - name conflict +C +C SUBROUTINE FLUSH + subroutine mcflsh +C +C - NOAO +C +C FLUSH currently does nothing except flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Done. +C + RETURN +C + END + SUBROUTINE FRAME +C +C FRAME is intended to advance to a new frame. The GKS version clears +C all open workstations. +C +C First, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C +NOAO - Initialize utilbd 'first' flag for next plot + call initut +C +C - NOAO +C Get the number of open workstations. If there are none, we're done. +C + CALL GQOPWK (0,IE,NO,ID) + IF (NO.EQ.0) RETURN +C +C Otherwise, clear the open workstations. +C + DO 101 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GCLRWK (ID,1) + 101 CONTINUE +C +C Done. +C + RETURN +C + END + SUBROUTINE FRSTPT (PX,PY) +C +C Given the user coordinates PX and PY of a point, FRSTPT generates a +C pen-up move to that point. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) +C +C Done. +C + RETURN +C + END + SUBROUTINE GETSET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C GETSET returns to its caller the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Define variables to receive the GKS viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Retrieve the number of the current GKS normalization transformation. +C + CALL GQCNTN (IE,NT) +C +C Retrieve the definition of that normalization transformation. +C + CALL GQNT (NT,IE,WD,VP) +C +C Pass the viewport definition to the caller. +C + VL=VP(1) + VR=VP(2) + VB=VP(3) + VT=VP(4) +C +C Pass the linear/log flag and a (possibly modified) window definition +C to the caller. +C + LF=LL +C + IF (LL.EQ.1.OR.LL.EQ.2) THEN + WL=WD(1) + WR=WD(2) + ELSE + WL=10.**WD(1) + WR=10.**WD(2) + END IF +C + IF (MI.GE.3) THEN + WW=WL + WL=WR + WR=WW + END IF +C + IF (LL.EQ.1.OR.LL.EQ.3) THEN + WB=WD(3) + WT=WD(4) + ELSE + WB=10.**WD(3) + WT=10.**WD(4) + END IF +C + IF (MI.EQ.2.OR.MI.GE.4) THEN + WW=WB + WB=WT + WT=WW + END IF +C + RETURN +C + END + SUBROUTINE GETSI (IX,IY) +C +C Return to the user the parameters which determine the assumed size of +C the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Set the user variables. + + IX=MX + IY=MY +C + RETURN +C + END + SUBROUTINE GETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine retrieves the current values of the utility state +C variables. VN is the character name of the variable and IV is +C its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/IU(100) +C +C Check for the linear-log scaling variable. +C + IF (VN(1:2).EQ.'LS') THEN + IV=IU(1) +C +C Check for the variable specifying the mirror-imaging of the axes. +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IV=IU(2) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IV=IU(3) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IV=IU(4) +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IV=IU(5) +C +C Check for the variable specifying the metacode unit. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IV=IU(6) +C +C Check for one of the variables specifying color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IV=IU(7) +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IV=IU(8) +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IV=IU(9) +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IV=IU(10) +C +C Check for the variable specifying the current color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IV=IU(11) +C +C Check for the variable specifying the maximum color index. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IV=IU(12) +C +C Check for the variable specifying the line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IV=IU(13) +C +C Check for the variable specifying the marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IV=IU(14) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('GETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF +C + RETURN +C + END + SUBROUTINE LINE (X1,Y1,X2,Y2) +C +C Draw a line connecting the point (X1,Y1) to the point (X2,Y2), in the +C user coordinate system. +C + CALL PLOTIF (CUFX(X1),CUFY(Y1),0) + CALL PLOTIF (CUFX(X2),CUFY(Y2),1) + RETURN + END + SUBROUTINE MXMY (IX,IY) +C +C Return to the user the coordinates of the current pen position, in the +C plotter coordinate system. +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system. +C + COMMON /PLTCM/ JX,JY +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Return to the user the plotter-system equivalents of the values in +C the metacode system. +C + IX=1+IFIX((2.**MX-1.)*FLOAT(JX)/32767.) + IY=1+IFIX((2.**MY-1.)*FLOAT(JY)/32767.) +C +C Done. +C + RETURN +C + END +C +C + NOAO - Following subroutine +C SUBROUTINE OPNGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C +C COMMON /IUTLCM/ IU(100) +C +C Force all required BLOCKDATA's to load. +C +C EXTERNAL GKSBD,G01BKD,UERRBD,UTILBD +C +C GKS buffer size (a dummy for NCAR GKS.) +C +C DATA ISZ /0/ +C +C Open GKS, define a workstation, and activate the workstation. +C +C CALL GOPKS (6,ISZ) +C CALL GOPWK (IU(6),2,1) +C CALL GACWK (IU(6)) +C +C RETURN +C +C + NOAO +C +C END + SUBROUTINE PLOTIF (FX,FY,IP) +C +C Move the pen to the point (FX,FY), in the fractional cooordinate +C system. If IP is zero, do a pen-up move. If IP is one, do a pen-down +C move. If IP is two, flush the buffer. +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - block data utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIF - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal fractional range. +C + GX=AMAX1(0.,AMIN1(1.,FX)) + GY=AMAX1(0.,AMIN1(1.,FY)) +C +C Set JX and JY for a possible call to MXMY. +C + JX=KFMX(GX) + JY=KFMY(GY) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=GX + QY(NQ)=GY +C +C If the point-coordinate buffer is full, dump the buffers; otherwise, +C return. +C + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE PLOTIT (IX,IY,IP) +C +C Move the pen to the point (IX,IY), in the metacode coordinate system. +C If IP is zero, do a pen-up move. If IP is one, do a pen-down move. +C If IP is two, flush the buffer. (For the sake of efficiency, the +C moves are buffered; "CALL PLOTIT (0,0,0)" will also flush the buffer.) +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - Blockdata utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIT - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal metacode range. +C + JX=MAX0(0,MIN0(32767,IX)) + JY=MAX0(0,MIN0(32767,IY)) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=FLOAT(JX)/32767. + QY(NQ)=FLOAT(JY)/32767. +C +C If all three arguments were zero, or if the point-coordinate buffer +C is full, dump the buffers; otherwise, return. +C + IF (IX.EQ.0.AND.IY.EQ.0.AND.IP.EQ.0) GO TO 101 + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE POINT (PX,PY) +C +C Draws a point at (PX,PY), defined in the user coordinate system. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE POINTS (PX,PY,NP,IC,IL) + DIMENSION PX(NP),PY(NP) +C +C Marks the points at positions in the user coordinate system defined +C by ((PX(I),PY(I)),I=1,NP). If IC is zero, each point is marked with +C a simple point. If IC is positive, each point is marked with the +C single character defined by the FORTRAN-77 function CHAR(IC). If IC +C is negative, each point is marked with a GKS polymarker of type -IC. +C If IL is non-zero, a curve is also drawn, connecting the points. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to mark the points a few at a time. +C + DIMENSION QX(10),QY(10) +C +C Define an array to hold the aspect source flags which may need to be +C retrieved from GKS. +C + DIMENSION LA(13) + CHARACTER*1 CHRTMP +C +C If the number of points is zero or negative, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C Otherwise, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Retrieve the parameters from the last SET call. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If a linear-linear, non-mirror-imaged, mapping is being done and the +C GKS polymarkers can be used, all the points can be marked with a +C single polymarker call and joined, if requested, by a single polyline +C call. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1.AND.IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSPMI (IN) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSMK (IN) + END IF + IF (IL.NE.0.AND.NP.GE.2) CALL GPL (NP,PX,PY) +C +C Otherwise, things get complicated. We have to do batches of nine +C points at a time. (Actually, we convert ten coordinates at a time, +C so that the curve joining the points, if any, won't have gaps in it.) +C + ELSE +C +C Initially, we have to reset either the polymarker index or the text +C alignment, depending on how we're marking the points. +C + IF (IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + END IF + ELSE + CALL GQTXAL (IE,IH,IV) + CALL GSTXAL (2,3) + END IF +C +C Loop through the points by nines. +C + DO 104 IP=1,NP,9 +C +C Fill the little point coordinate arrays with up to ten values, +C converting them from the user system to the fractional system. +C + NQ=MIN0(10,NP-IP+1) + MQ=MIN0(9,NQ) + DO 102 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 102 CONTINUE +C +C Change the SET call to allow the use of fractional coordinates. +C + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) +C +C Crank out either a polymarker or a set of characters. +C + IF (IC.LE.0) THEN + CALL GPM (MQ,QX,QY) + ELSE + DO 103 IQ=1,MQ + CHRTMP = CHAR(IC) + CALL GTX (QX(IQ),QY(IQ),CHRTMP) + 103 CONTINUE + END IF + IF (IL.NE.0.AND.NQ.GE.2) CALL GPL (NQ,QX,QY) +C +C Put the SET parameters back the way they were. +C + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C + 104 CONTINUE +C +C Finally, we put either the polymarker index or the text alignment +C back the way it was. +C + IF (IC.LE.0) THEN + IF (LA(4).EQ.0) THEN + CALL GSPMI (IN) + ELSE + CALL GSMK (IN) + END IF + ELSE + CALL GSTXAL (IH,IV) + END IF +C + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C +C Done. +C + RETURN +C + END + SUBROUTINE PWRIT (PX,PY,CH,NC,IS,IO,IC) + CHARACTER*(*) CH +C +C PWRIT is called to draw a character string in a specified position. +C It is just like WTSTR, but has one extra argument. NC is the number +C of characters to be written from the string CH. +C + CALL WTSTR (PX,PY,CH(1:NC),IS,IO,IC) +C +C Done. +C + RETURN +C + END + SUBROUTINE SET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C SET allows the user to change the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Set the GKS viewport for transformation 1. +C + CALL GSVP (1,VL,VR,VB,VT) +C +C Set the utility state variable controlling linear-log mapping. +C + LL=MAX0(1,MIN0(4,LF)) +C +C Set the GKS window for transformation 1. +C + IF (WL.LT.WR) THEN + MI=1 + QL=WL + QR=WR + ELSE + MI=3 + QL=WR + QR=WL + END IF +C + IF (WB.LT.WT) THEN + QB=WB + QT=WT + ELSE + MI=MI+1 + QB=WT + QT=WB + END IF +C + IF (LL.EQ.1) THEN + CALL GSWN (1,QL,QR,QB,QT) + ELSE IF (LL.EQ.2) THEN + CALL GSWN (1,QL,QR,ALOG10(QB),ALOG10(QT)) + ELSE IF (LL.EQ.3) THEN + CALL GSWN (1,ALOG10(QL),ALOG10(QR),QB,QT) + ELSE + CALL GSWN (1,ALOG10(QL),ALOG10(QR),ALOG10(QB),ALOG10(QT)) + END IF +C +C Select transformation 1 as the current one. +C + CALL GSELNT (1) +C + RETURN +C + END + SUBROUTINE SETI (IX,IY) +C +C Allows the user to set the parameters which determine the assumed size +C of the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Transfer the user's values into the common block. +C + MX=MAX0(1,MIN0(15,IX)) + MY=MAX0(1,MIN0(15,IY)) +C + RETURN +C + END + SUBROUTINE SETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine sets the values of various utility state variables. +C VN is the name of the variable and IV is its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/ IU(100) +C +C Define an array in which to get the GKS aspect source flags. +C + DIMENSION LF(13) +C +C Check for the linear-log scaling variable, which can take on these +C values: +C +C 1 = X linear, Y linear +C 2 = X linear, Y log +C 3 = X log , Y linear +C 4 = X log , Y log +C + IF (VN(1:2).EQ.'LS') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - LOG SCALE VALUE OUT OF RANGE',2,2) + END IF + IU(1)=IV +C +C Check for the mirror-imaging variable, which can take on these +C values: +C +C 1 = X normal , Y normal +C 2 = X normal , Y reversed +C 3 = X reversed, Y normal +C 4 = X reversed, Y reversed +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - MIRROR-IMAGING VALUE OUT OF RANGE',3,2) + END IF + IU(2)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the x direction. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - X RESOLUTION OUT OF RANGE',4,2) + END IF + IU(3)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the y direction. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - Y RESOLUTION OUT OF RANGE',5,2) + END IF + IU(4)=IV +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IF (IV.LT.2.OR.IV.GT.50) THEN + CALL SETER ('SETUSV - PEN-MOVE BUFFER SIZE OUT OF RANGE',6,2) + END IF + CALL PLOTIF (0.,0.,2) + IU(5)=IV +C +C Check for a metacode unit number. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IF (IV.LE.0) THEN + CALL SETER ('SETUSV - METACODE UNIT NUMBER ILLEGAL',7,2) + END IF +C +C For the moment (1/11/85), we have to deactivate and close the old +C workstation and open and activate a new one. This does allow the +C user to break up his metacode output. It does not necessarily allow +C for the resumption of output to a previously-written metacode file. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + IU(6)=IV + CALL GOPWK (IU(6),2,1) + CALL GACWK (IU(6)) +C +C If, in the future, it becomes possible to have more than one metacode +C workstation open at once, the following code can be used instead. +C +C CALL GDAWK (IU(6)) +C IU(6)=IV +C CALL GQOPWK (0,IE,NO,ID) +C IF (NO.NE.0) THEN +C DO 101 I=1,NO +C CALL GQOPWK (I,IE,NO,ID) +C IF (ID.EQ.IU(6)) GO TO 102 +C 101 CONTINUE +C END IF +C CALL GOPWK (IU(6),2,1) +C 102 CALL GAWK (IU(6)) +C +C Check for one of the variables setting color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF RED INTENSITY',8,2) + END IF + IU(7)=IV +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF GREEN INTENSITY',9,2) + END IF + IU(8)=IV +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF BLUE INTENSITY',10,2) + END IF + IU(9)=IV +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IF (IV.LT.0.OR.IV.GT.10000) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF INTENSITY',11,2) + END IF + IU(10)=IV +C +C Assign the intensity-controlling variables to local variables with +C simple, meaningful names. +C + IR=IU(7) + IG=IU(8) + IB=IU(9) + IN=IU(10) + II=IU(11) + IM=IU(12) +C +C Compute the floating-point red, green, and blue intensities. +C + FR=FLOAT(IR)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FG=FLOAT(IG)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FB=FLOAT(IB)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flags for all the color indices to "individual". +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C +C Pick a new color index and use it for polylines, polymarkers, text, +C and areas. +C + II=MOD(II,IM)+1 + IU(11)=II + CALL GSPLCI (II) + CALL GSPMCI (II) + CALL GSTXCI (II) + CALL GSFACI (II) +C +C Now, redefine the color for that color index on each open workstation. +C + CALL GQOPWK (0,IE,NO,ID) +C + DO 103 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GSCR (ID,II,FR,FG,FB) + 103 CONTINUE +C +C Check for variable resetting the color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IF (IV.LT.1.OR.IV.GT.IU(12)) THEN + CALL SETER ('SETUSV - ILLEGAL COLOR INDEX',12,2) + END IF + IU(11)=IV +C + CALL PLOTIF (0.,0.,2) +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C + CALL GSPLCI (IV) + CALL GSPMCI (IV) + CALL GSTXCI (IV) + CALL GSFACI (IV) +C +C Check for the variable limiting the values of color index used. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IF (IV.LT.1) THEN + CALL SETER ('SETUSV - ILLEGAL MAXIMUM COLOR INDEX',13,2) + END IF + IU(12)=IV +C +C Check for the variable setting the current line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL LINE WIDTH SCALE FACTOR',14,2) + END IF + IU(13)=IV +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flag for linewidth scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(2)=1 + CALL GSASF (LF) +C +C Redefine the line width scale factor. +C + CALL GSLWSC (FLOAT(IV)/1000.) +C +C Check for the variable setting the current marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL MARKER SIZE SCALE FACTOR',15,2) + END IF + IU(14)=IV +C +C Set aspect source flag for marker size scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(5)=1 + CALL GSASF (LF) +C +C Redefine the marker size scale factor. +C + CALL GSMKSC (FLOAT(IV)/1000.) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('SETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF + RETURN + END + SUBROUTINE VECTOR (PX,PY) +C +C Draw a vector (line segment) from the current pen position to the new +C pen position (PX,PY), in the user coordinate system, and then make +C (PX,PY) the current pen position. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) +C +C WTSTR is called to draw a character string in a specified position. +C +C PX and PY specify, in user coordinates, the position of a point +C relative to which a character string is to be positioned. +C +C CH is the character string to be written. +C +C IS is the desired size of the characters to be used, stated as a +C character width in the plotter coordinate system. The values 0, 1, +C 2, and 3 mean 8, 12, 16, and 24, respectively. +C +C IO is the desired orientation angle, in degrees counterclockwise from +C a horizontal vector pointing to the right. +C +C IC specifies the desired type of centering. A negative value puts +C (PX,PY) in the center of the left end of the character string, a zero +C puts (PX,PY) in the center of the whole string, and a positive value +C puts (PX,PY) in the center of the right end of the character string. +C + CHARACTER*(*) CH +C +C Define arrays in which to save the current viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Compute the coordinates of (PX,PY) in the fractional coordinate +C system (normalized device coordinates). +C + XN=CUFX(PX) + YN=CUFY(PY) +C +C Save the current window and, if necessary, redefine it so that we can +C use normalized device coordinates. +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Save current character height, text path, character up vector, and +C text alignment. +C + CALL GQCHH (IE,OS) + CALL GQTXP (IE,IP) + CALL GQCHUP (IE,UX,UY) + CALL GQTXAL (IE,IX,IY) +C +C Define the character height. (The final scale factor is derived from +C the default font.) +C + CALL GETUSV ('YF',MY) + YS=FLOAT(2**MY) + IF (IS.GE.0.AND.IS.LE.3) THEN + CS=FLOAT(8+4*IS+4*(IS/3))/YS + ELSE + CS=AMIN1(FLOAT(IS),YS)/YS + ENDIF +C + CS=CS*25.5/27. +C +C + NOAO - make character size readable with IRAF font + cs = cs * 2.0 +C +C - NOAO + + CALL GSCHH(CS) +C +C Define the text path. +C + CALL GSTXP (0) +C +C Define the character up vector. +C + JO=MOD(IO,360) + IF (JO.EQ.0) THEN + CALL GSCHUP (0.,1.) + ELSE IF (JO.EQ.90) THEN + CALL GSCHUP (-1.,0.) + ELSE IF (JO.EQ.180) THEN + CALL GSCHUP (0.,-1.) + ELSE IF (JO.EQ.270) THEN + CALL GSCHUP (1.,0.) + ELSE IF (JO.GT.0.AND.JO.LT.180) THEN + CALL GSCHUP (-1.,1./TAN(FLOAT(JO)*3.1415926/180.)) + ELSE + CALL GSCHUP (1.,-1./TAN(FLOAT(JO)*3.1415926/180.)) + ENDIF +C +C Define the text alignment. +C + CALL GSTXAL (IC+2,3) +C +C Plot the characters. +C + CALL GTX (XN,YN,CH) +C +C Restore the original text attributes. +C + CALL GSCHH (OS) + CALL GSTXP (IP) + CALL GSCHUP (UX,UY) + CALL GSTXAL (IX,IY) +C +C Restore the window definition. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX,PY) +C +C Done. +C + RETURN +C + END +c + NOAO - blockdata utilbd changed to run time initialization + subroutine utilbd +c BLOCKDATA UTILBD +C + logical first +C The common block IUTLCM contains integer utility variables which are +C user-settable by the routine SETUSV and user-retrievable by the +C routine GETUSV. +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables realizing the buffering +C scheme used by PLOTIT/F for pen moves. The dimension of QX and QY must +C be an even number greater than or equal to the value of IU(5). The +C dimension of IF must be half that of QX and QY. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C + COMMON /PLTCM/ JX,JY +C +C IU(1) contains the log scaling parameter, which may take on the +C following possible values: +C +C 1 = linear-linear +C 2 = log-linear +C 3 = linear-log +C 4 = log-log +C +c DATA IU(1) / 1 / + IU(1) = 1 +C +C IU(2) specifies the mirror-imaging of the x and y axes, as follows: +C +C 1 = x normal, y normal +C 2 = x normal, y reversed +C 3 = x reversed, y normal +C 4 = x reversed, y reversed +C +c +NOAO - logical parameter first inserted to avoid clobbering initialization + data first /.true./ + if (.not. first) return + first = .false. +c -NOAO +c DATA IU(2) / 1 / + IU(2) = 1 +C +C IU(3) specifies the assumed resolution of the plotter in the x +C direction. Plotter x coordinates are assumed to lie between 1 and +C 2**IU(3), inclusive. +C +c DATA IU(3) / 10 / + IU(3) = 10 +C +C IU(4) specifies the assumed resolution of the plotter in the y +C direction. Plotter y coordinates are assumed to lie between 1 and +C 2**IU(4), inclusive. +C +c DATA IU(4) / 10 / + IU(4) = 10 +C +C IU(5) specifies the size of the buffers used by PLOTIT/F. Its value +C must be greater than or equal to 2 and not greater than the dimension +C of the variables QX and QY. Using the value 2 effectively turns off +C the buffering. +C +c DATA IU(5) / 50 / + IU(5) = 50 +C +C IU(6) specifies the current metacode unit, which is machine-dependent. +C At NCAR, the value "1" currently (1/11/85) causes metacode to be +C written on the file "GMETA". Eventually, it will cause output to be +C written on unit number 1. At that point, the value, on the Cray at +C least, should be changed to "4H$PLT", so that output will come out on +C the old familiar dataset. +C +c DATA IU(6) / 1 / + IU(6) = 1 +C +C IU(7), IU(8), IU(9), and IU(10) specify color and intensity, in the +C following way (letting IR=IU(7), IG=IU(8), IB=IU(9), and IN=IU(10)): +C +C The red intensity is IR/(IR+IG+IB)*IN/10000. +C The green intensity is IG/(IR+IG+IB)*IN/10000. +C The blue intensity is IB/(IR+IG+IB)*IN/10000. +C +C The GKS calls to set these intensities are executed in response to a +C "CALL SETUSV ('IN',IN)", using the existing values of IR, IG, and IB. +C Thus, to completely determine the color and the intensity, the user +C must execute four calls, as follows: +C +C CALL SETUSV ('IR',IR) +C CALL SETUSV ('IG',IG) +C CALL SETUSV ('IB',IB) +C CALL SETUSV ('IN',IN) +C +C The default values create a white line at .8 x maximum intensity. +C +c DATA IU(7) / 1 / +c DATA IU(8) / 1 / +c DATA IU(9) / 1 / + IU(7) = 1 + IU(8) = 1 + IU(9) = 1 +C +c DATA IU(10) / 8000 / + IU(10) = 8000 +C +C IU(11) and IU(12) specify, respectively, the last color index used +C and the maximum number of color indices it is permissible to use. +C +c DATA IU(11) / 0 / +c DATA IU(12) / 1 / + IU(11) = 0 + IU(12) = 1 +C +C IU(13)/1000 specifies the current line width scale factor. +C +c DATA IU(13) / 1000 / + IU(13) = 1000 +C +C IU(14)/1000 specifies the current marker size scale factor. +C +c DATA IU(14) / 1000 / + IU(14) = 1000 +C +C IU(15) through IU(100) are currently undefined. +C +C Initialization for the routine PLOTIT/F: For values of I between 1 and +C NQ, (QX(I),QY(I)) is a point to which a pen move has been requested +C by a past call to PLOTIT/F. The coordinates are stated in the fractional +C coordinate system. For values of I between 1 and NF, IF(I) is the +C index, in QX and QY, of the coordinates of a point to which a pen-up +C move was requested. NQ and NF are never allowed to be less than one. +C +c DATA NQ,QX(1),QY(1),NF,IF(1) / 1 , 0. , 0. , 1 , 1 / + NQ = 1 + QX(1) = 0. + QY(1) = 0. + NF = 1 + IF(1) = 1 +C +C JX and JY are the coordinates, in the metacode system, of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C +c DATA JX,JY / 0 , 0 / + JX = 0 + JY = 0 +C +c -NOAO + return +c + entry initut + first = .true. + END diff --git a/sys/gio/ncarutil/sysint/support.f b/sys/gio/ncarutil/sysint/support.f new file mode 100644 index 00000000..84d11ba5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/support.f @@ -0,0 +1,581 @@ + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C +C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS +C TO BE CREATED. +C ASH SEE IOFFD. +C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE +C MAGNITUDE OF VALU IS TO BE CREATED. +C .1 .LE. ABS(VALU) .LE. 99999.49999... +C OR VALUE .EQ. 0.0. THE LABEL CREATED +C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING +C ON THE MAGNITUDE OF VALU. SEE IOUT. +C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT +C THE MAGNITUDE OF VALU IS TO BE CREATED. +C ASH IS USED AS THE NORMALIZATION FACTOR. +C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR +C VALU .EQ. 0.0. THE LABEL CREATED SHOULD +C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE +C MAGNITUDE OF ASH*VALU. SEE IOUT. +C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO +C LEADING BLANKS. SEE NC. +C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE +C 1 TO 5. +C + SAVE + CHARACTER*11 IFMT + CHARACTER*(*) IOUT +C +C IFMT MUST HOLD 11 CHARACTERS +C + VAL = VALU + IF (IOFFD .NE. 0) GO TO 103 + IF (VAL) 101,104,101 + 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000 + V = VAL + NS = MAX0(4,MIN0(6,LOG+2)) + ND = MIN0(3,MAX0(0,2-LOG)) +c IF (VAL.LT.0) NS = NS + 1 +c + NOAO - replacing ftn i/o for iraf implementation +c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')' + 102 continue + ifmt(1:6) = '(f . )' + ifmt(3:3) = char (ns + ichar ('0')) + ifmt(5:5) = char (nd + ichar ('0')) +c WRITE (IOUT,IFMT) V + call encode (ns, ifmt, iout, v) + NC = NS +c + NOAO +c The following statement was making 5 digit labels (+4800) come out +c truncated (+480) and it has been commented out. +c IF (LOG.GE.3) NC = NC - 1 +c - NOAO + RETURN + 103 NS = 4 + IF (VAL.LT.0.) NS=5 + IF (VAL.EQ.0.) NS=2 + ND = 0 + V = VAL*ASH + LOG = 100 + GO TO 102 + 104 iout(1:3) = '0.0' + nc = 3 +c 104 NS = 3 +c ND = 1 +c LOG = -100 +c V = 0. +c GO TO 102 +C +C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')') +C + END +C + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + + INTEGER SZFMT, SZBUF + PARAMETER (SZFMT=11) + PARAMETER (SZBUF=15) + + CHARACTER*(*) FTNFMT + CHARACTER*(*) FTNOUT + INTEGER*2 SPPFMT(SZFMT), SPPOUT(SZBUF) + +C UNPACK THE FORTRAN CHARACTER STRING, CALL FENCD TO ACTUALLY ENCODE THE +C OUTPUT STRING, THEN PACK THE OUTPUT STRING INTO A FORTRAN STRING FOR RETURN +C + CALL F77UPK (FTNFMT, SPPFMT, SZFMT) + CALL FENCD (NCHARS, SPPFMT, SPPOUT, RVAL) + CALL F77PAK (SPPOUT, FTNOUT, NCHARS) + + END +C +C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES +C FOLLOWS THIS PACKAGE DESCRIPTION. +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR +C HANDLING PACKAGE. +C +C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN +C THE SAME MANNER AS THEIR SIMILARLY NAMED +C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT +C FOR ROUTINE SETER, THE CALLING SEQUENCES +C OF THESE ROUTINES ARE THE SAME AS FOR +C THEIR PORT COUNTERPARTS. +C ERPRT77 ENTRY PORT ENTRY +C ------------- ---------- +C ENTSR ENTSRC +C RETSR RETSRC +C NERRO NERROR +C ERROF ERROFF +C SETER SETERR +C EPRIN EPRINT +C FDUM FDUMP +C +C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES. +C +C PRECISION NOT APPLICABLE +C +C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON +C FILES NCAR'S CRAY MACHINES. +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER, +C COLORADO BY FRED CLARE OF THE SCIENTIFIC +C COMPUTING DIVISION BY ADAPTING THE NON- +C PROPRIETARY, ERROR HANDLING ROUTINES +C FROM THE PORT LIBRARY OF BELL LABS. +C +C PORTABILITY FULLY PORTABLE +C +C REFERENCES SEE THE MANUAL +C PORT MATHEMATICAL SUBROUTINE LIBRARY +C ESPECIALLY "ERROR HANDLING" IN SECTION 2 +C OF THE INTRODUCTION, AND THE VARIOUS +C SUBROUTINE DESCRIPTIONS. +C ****************************************************************** +C +C SUBBROUTINE ENTSR(IROLD,IRNEW) +C +C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND +C SETS A NEW ONE. IT ALSO CHECKS THE ERROR +C STATE, AND IF THERE IS AN ACTIVE ERROR +C STATE A MESSAGE IS PRINTED. +C +C USAGE CALL ENTSR(IROLD,IRNEW) +C +C ARGUMENTS +C +C ON INPUT IRNEW +C VALUE SPECIFIED BY USER FOR ERROR +C RECOVERY +C = 0 LEAVES RECOVERY UNCHANGED +C = 1 GIVES RECOVERY +C = 2 TURNS RECOVERY OFF +C +C ON OUTPUT IROLD +C RECEIVES THE CURRENT VALUE OF THE ERROR +C RECOVERY MODE +C +C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE +C MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IRNEW. +C 2 - CALLED WHILE IN AN ERROR STATE. +C ****************************************************************** +C +C SUBROUTINE RETSR(IROLD) +C +C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN +C BY THE INPUT ARGUMENT. A TEST IS THEN MADE +C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH +C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN +C ERROR MESSAGE AND TERMINATES THE RUN. +C +C BY CONVENTION, RETSR IS USED UPON EXIT +C FROM A SUBROUTINE TO RESTORE THE PREVIOUS +C RECOVERY MODE STATUS STORED BY ROUTINE +C ENTSR IN IROLD. +C +C USAGE CALL RETSR(IROLD) +C +C ARGUMENTS +C +C ON INPUT IROLD +C = 1 SETS FOR RECOVERY +C = 2 SETS FOR NONRECOVERY +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE, +C THE MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IROLD. +C ****************************************************************** +C +C INTEGER FUNCTION NERRO(NERR) +C +C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY) +C OR ZERO IF THE PROGRAM IS NOT IN THE +C ERROR STATE. +C +C USAGE N = NERRO(NERR) +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NERR +C CURRENT VALUE OF THE ERROR NUMBER +C ****************************************************************** +C SUBROUTINE ERROF +C +C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE +C ERROR NUMBER TO ZERO +C +C USAGE CALL ERROF +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE SETER(MESSG,NERR,IOPT) +C +C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING +C ON THE OPTIONS STATED BELOW, PRINTS A +C MESSAGE AND PROVIDES A DUMP. +C +C +C USAGE CALL SETER(MESSG,NERR,IOPT) +C +C ARGUMENTS +C +C ON INPUT MESSG +C HOLLERITH STRING CONTAINING THE MESSAGE +C ASSOCIATED WITH THE ERROR +C +C NERR +C THE NUMBER TO ASSIGN TO THE ERROR +C +C IOPT +C = 1 FOR A RECOVERABLE ERROR +C = 2 FOR A FATAL ERROR +C +C IF IOPT = 1 AND THE USER IS IN ERROR +C RECOVERY MODE, SETERR SIMPLY REMEMBERS +C THE ERROR MESSAGE, SETS THE ERROR NUMBER +C TO NERR, AND RETURNS. +C +C IF IOPT = 1 AND THE USER IS NOT IN ERROR +C RECOVERY MODE, SETERR PRINTS THE ERROR +C MESSAGE AND TERMINATES THE RUN. +C +C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR +C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN. +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT +C TO ANY VALUE OTHER THAN 1 OR 2. +C ****************************************************************** +C +C SUBROUTINE EPRIN +C +C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE +C PROGRAM IS IN THE ERROR STATE; OTHERWISE +C NOTHING IS PRINTED. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE FDUM +C +C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES +C AS A PLACEHOLDER FOR A SYMBOLIC DUMP +C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO +C PROVIDE SUCH A ROUTINE. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** + SUBROUTINE ENTSR(IROLD,IRNEW) +C + LOGICAL TEMP + IF (IRNEW.LT.0 .OR. IRNEW.GT.2) + 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2) +C + TEMP = IRNEW.NE.0 + IROLD = I8SAV(2,IRNEW,TEMP) +C +C IF HAVE AN ERROR STATE, STOP EXECUTION. +C + IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER + 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2) +C + RETURN +C + END + SUBROUTINE RETSR(IROLD) +C + IF (IROLD.LT.1 .OR. IROLD.GT.2) + 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2) +C + ITEMP=I8SAV(2,IROLD,.TRUE.) +C +C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. +C + IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + END + INTEGER FUNCTION NERRO(NERR) +C + NERRO=I8SAV(1,0,.FALSE.) + NERR=NERRO + RETURN +C + END + SUBROUTINE ERROF +C + I=I8SAV(1,0,.TRUE.) + RETURN +C + END + SUBROUTINE SETER(MESSG,NERR,IOPT) +C + CHARACTER*(*) MESSG + COMMON /UERRF/IERF +C +C THE UNIT FOR ERROR MESSAGES IS I1MACH(4) +C +c + NOAO - blockdata uerrbd changed to runtime initialization subroutine +C FORCE LOAD OF BLOCKDATA +C +c EXTERNAL UERRBD + call uerrbd +c - NOAO + IF (IERF .EQ. 0) THEN + IERF = I1MACH(4) + ENDIF +C + NMESSG = LEN(MESSG) + IF (NMESSG.GE.1) GO TO 10 +C +C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9000) +c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.') + call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80) +c - NOAO + GO TO 60 +C + 10 CONTINUE + IF (NERR.NE.0) GO TO 20 +C +C CANNOT TURN THE ERROR STATE OFF USING SETER. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9001) +c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/ +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/) + call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80) + call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80) +c - NOAO + CALL E9RIN(MESSG,NERR,.TRUE.) + ITEMP=I8SAV(1,1,.TRUE.) + GO TO 50 +C +C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. +C + 20 CONTINUE + IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30 +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9002) +c9002 FORMAT(' ERROR 3 IN SETER -', +c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// +c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) + call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80) + call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80) +c - NOAO + CALL EPRIN + CALL E9RIN(MESSG,NERR,.TRUE.) + GO TO 50 +C +C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. +C + 30 CALL E9RIN(MESSG,NERR,.TRUE.) +C + IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 +C +C MUST HAVE IOPT = 1 OR 2. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9003) +c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'// +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) + call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80) + call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80) +c - NOAO + GO TO 50 +C +C TEST FOR RECOVERY. +C + 40 CONTINUE + IF (IOPT.EQ.2) GO TO 50 +C + IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + 50 CALL EPRIN + 60 CALL FDUM +c STOP +C + END + SUBROUTINE EPRIN +C + CHARACTER*1 MESSG +C + CALL E9RIN(MESSG,1,.FALSE.) + RETURN +C + END + SUBROUTINE E9RIN(MESSG,NERR,SAVE) +C +C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, +C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . +C + CHARACTER*(*) MESSG + CHARACTER*113 MESSGP + INTEGER NERRP + LOGICAL SAVE + COMMON /UERRF/IERF + SAVE MESSGP,NERRP +C +C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE +C +C +C START WITH NO PREVIOUS MESSAGE. +C + DATA MESSGP/'1'/ + DATA NERRP/0/ +C + IF (.NOT.SAVE) GO TO 20 +C +C SAVE THE MESSAGE. +C + NERRP=NERR + MESSGP = MESSG +C + GO TO 30 +C + 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30 +C +C PRINT THE MESSAGE. +C +c + NOAO - FTN write rewritten as call to uliber +c WRITE(IERF,9000) NERRP,MESSGP +c9000 FORMAT(' ERROR ',I4,' IN ',A113) + call uliber (nerrp, messgp, 113) +C + 30 RETURN +C + END + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) +C +C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C +C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C + LOGICAL SET + INTEGER LERROR, LRECOV + SAVE LERROR,LRECOV +C +C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. +C + DATA LERROR/0/ , LRECOV/2/ + IF (ISW .EQ. 1) THEN + I8SAV = LERROR + IF (SET) LERROR = IVALUE + ELSE IF (ISW .EQ. 2) THEN + I8SAV = LRECOV + IF (SET) LRECOV = IVALUE + ENDIF + RETURN + END + SUBROUTINE FDUM +C +C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED +C + RETURN + END +C + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) +C +C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH +C INFORMATION ABOUT THE CIRCUMSTANCES OF A +C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING +C TAPE FOR LATER PROCESSING. +C +C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE +C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH +C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT +C MONITORS USE OF NCAR ROUTINES WITH LOCAL +C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL +C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE +C DELETED FROM ALL NSSL ROUTINES. +C + CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION +C + RETURN + END +c + NOAO - Blockdata uerrbd rewritten as a runtime initialization subroutine +c BLOCKDATA UERRBD + subroutine uerrbd +c + COMMON /UERRF/IERF +C DEFAULT ERROR UNIT +c DATA IERF/0/ + IERF= 0 + END +c -NOAO + subroutine uliber (errcode, pkerrmsg, msglen) + + character*80 pkerrmsg + integer errcode, msglen + integer*2 sppmsg(81) + integer SZLINE + parameter (SZLINE=80) + +c unpack the fortran character string, call fulib to output the string. +c + call f77upk (pkerrmsg, sppmsg, SZLINE) + call fulib (errcode, sppmsg, msglen) + + end diff --git a/sys/gio/ncarutil/tests/README b/sys/gio/ncarutil/tests/README new file mode 100644 index 00000000..d74bb65f --- /dev/null +++ b/sys/gio/ncarutil/tests/README @@ -0,0 +1,2 @@ +This directory contains test routines for the NCAR utilities. The files +ending with "t.f" are the NCAR supplied fortran test routines. diff --git a/sys/gio/ncarutil/tests/auto10t.f b/sys/gio/ncarutil/tests/auto10t.f new file mode 100644 index 00000000..26109f4f --- /dev/null +++ b/sys/gio/ncarutil/tests/auto10t.f @@ -0,0 +1,262 @@ + SUBROUTINE XMPL10 +C +C Define the data arrays. +C + REAL XDRA(1201),YDRA(1201) +C +C Fill the data arrays. The independent variable represents time during +C the year (a hypothetical year with equal-length months) and is set up +C so that the minor ticks can be lengthened to delimit the months; the +C major ticks, though shortened to invisibility, will determine where +C the labels go. +C + DO 101 I=1,1201 + XDRA(I)=FLOAT(I-51) + YDRA(I)=COSH(FLOAT(I-601)/202.) + 101 CONTINUE +C +C Change the labels on the bottom and left axes. +C + CALL ANOTAT ('MONTHS OF THE YEAR$','ROMAN NUMERALS$',0,0,0,0) +C +C Fix the minimum and maximum values on both axes and prevent AUTOGRAPH +C from using rounded values at the ends of the axes. +C + CALL AGSETF ('X/MIN.',-50.) + CALL AGSETF ('X/MAX.',1150.) + CALL AGSETI ('X/NICE.',0) +C + CALL AGSETF ('Y/MIN.',1.) + CALL AGSETF ('Y/MAX.',10.) + CALL AGSETI ('Y/NICE.',0) +C +C Specify the spacing between major tick marks on all axes. Note that +C the AUTOGRAPH dummy routine AGCHNL is supplanted (below) by one which +C supplies dates for the bottom axis and Roman numerals for the left +C axis in place of the numeric labels one would otherwise get. +C + CALL AGSETI (' LEFT/MAJOR/TYPE.',1) + CALL AGSETI (' RIGHT/MAJOR/TYPE.',1) + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETI (' TOP/MAJOR/TYPE.',1) +C + CALL AGSETF (' LEFT/MAJOR/BASE.', 1.) + CALL AGSETF (' RIGHT/MAJOR/BASE.', 1.) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',100.) + CALL AGSETF (' TOP/MAJOR/BASE.',100.) +C +C Suppress minor ticks on the left and right axes. +C + CALL AGSETI (' LEFT/MINOR/SPACING.',0) + CALL AGSETI (' RIGHT/MINOR/SPACING.',0) +C +C On the bottom and top axes, put one minor tick between each pair of +C major ticks, shorten the major ticks to invisibility, and lengthen +C the minor ticks. The net effect is to make the minor ticks delimit +C the beginning and end of each month, while the major ticks, though +C invisible, cause the names of the months to be where we want them. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',1) + CALL AGSETI (' TOP/MINOR/SPACING.',1) +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD. ',0.) + CALL AGSETF ('BOTTOM/MINOR/INWARD. ',.015) + CALL AGSETF (' TOP/MAJOR/INWARD. ',0.) + CALL AGSETF (' TOP/MINOR/INWARD. ',.015) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,1201,'EXAMPLE 10 (MODIFIED NUMERIC LABELS)$') +C +c STOP +C + END + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Define the names of the months for use on the bottom axis. +C + CHARACTER*3 MONS(12) + DATA MONS / 'JAN','FEB','MAR','APR','MAY','JUN', + + 'JUL','AUG','SEP','OCT','NOV','DEC'/ +C +C Modify the numeric labels on the left axis. +C + IF (IAXS.EQ.1) THEN + CALL AGCORN (IFIX(VILS),CHRM,NCIM) + IPXM=0 + NCIE=0 +C +C Modify the numeric labels on the bottom axis. +C + ELSE IF (IAXS.EQ.3) THEN + IMON=IFIX(VILS+.5)/100+1 + CHRM(1:3)=MONS(IMON) + NCIM=3 + IPXM=0 + NCIE=0 + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE AGCORN (NTGR,BCRN,NCRN) +C + CHARACTER*(*) BCRN +C +C This routine receives an integer in NTGR and returns its Roman-numeral +C equivalent - NCRN characters - in the character variable BCRN. It +C only works for integers within a limited range and it does some rather +C unorthodox things (like using zero and minus). +C +C ICH1, ICH5, and IC10 are character variables used for the single-unit, +C five-unit, and ten-unit symbols at a given level. +C + CHARACTER*1 ICH1,ICH5,IC10 +C +C Treat numbers outside the range (-4000,+4000) as infinites. +C + IF (IABS(NTGR).GE.4000) THEN + IF (NTGR.GT.0) THEN + NCRN=5 + BCRN(1:5)='(INF)' + ELSE + NCRN=6 + BCRN(1:6)='(-INF)' + END IF + RETURN + END IF +C +C Use the symbol '0' for the zero. The Romans never had it so good. +C + IF (NTGR.EQ.0) THEN + NCRN=1 + BCRN(1:1)='0' + RETURN + END IF +C +C Zero the character counter. +C + NCRN=0 +C +C Handle negative integers by prefixing a minus sign. +C + IF (NTGR.LT.0) THEN + NCRN=NCRN+1 + BCRN(NCRN:NCRN)='-' + END IF +C +C Initialize some constants. We'll check for thousands first. +C + IMOD=10000 + IDIV=1000 + ICH1='M' +C +C Find out how many thousands (hundreds, tens, units) there are and jump +C to the proper code block for each case. +C + 101 INTG=MOD(IABS(NTGR),IMOD)/IDIV +C + GO TO (107,104,104,104,102,103,103,103,103,106) , INTG+1 +C +C Four - add ICH1 followed by ICH5. +C + 102 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 +C +C Five through eight - add ICH5, followed by INTG-5 ICH1's. +C + 103 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH5 +C + INTG=INTG-5 + IF (INTG.LE.0) GO TO 107 +C +C One through three - add that many ICH1's. +C + 104 DO 105 I=1,INTG + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + 105 CONTINUE +C + GO TO 107 +C +C Nine - add ICH1, followed by IC10. +C + 106 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=IC10 +C +C If we're done, exit. +C + 107 IF (IDIV.EQ.1) RETURN +C +C Otherwise, tool up for the next digit and loop back. +C + IMOD=IMOD/10 + IDIV=IDIV/10 + IC10=ICH1 +C + IF (IDIV.EQ.100) THEN + ICH5='D' + ICH1='C' + ELSE IF (IDIV.EQ.10) THEN + ICH5='L' + ICH1='X' + ELSE + ICH5='V' + ICH1='I' + END IF +C + GO TO 101 +C + END diff --git a/sys/gio/ncarutil/tests/autograph.x b/sys/gio/ncarutil/tests/autograph.x new file mode 100644 index 00000000..3c2ccb14 --- /dev/null +++ b/sys/gio/ncarutil/tests/autograph.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> +include <ctype.h> + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_autograph() + +char device[SZ_FNAME], command[SZ_LINE] +int ierror, wkid, junk, cmd +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tautog (ierror) + if (ierror == 0) + call eprintf ("Test successful\n") + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/autographt.f b/sys/gio/ncarutil/tests/autographt.f new file mode 100644 index 00000000..25b14518 --- /dev/null +++ b/sys/gio/ncarutil/tests/autographt.f @@ -0,0 +1,186 @@ + SUBROUTINE TAUTOG (IERROR) +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C AUTOGRAPH AND TO TEST AUTOGRAPH ON A +C SIMPLE PROBLEM +C +C USAGE CALL TAUTOG (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN ERROR PARAMETER +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C AUTOGRAPH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C +C IN ADDITION, FOUR (4) LABELLED FRAMES +C CONTAINING THE TWO-DIMENSIONAL PLOTS ARE +C PRODUCED ON THE MACHINE GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY AUTOGRAPH +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN IN APRIL, 1979 AND +C CONVERTED TO FORTRAN 77 AND GKS IN FEBRUARY +C 1985. +C +C ALGORITHM TAUTOG COMPUTES DATA FOR AUTOGRAPH SUBROUTINES +C +C EZY, EZXY, EZMY, AND EZMXY, +C +C AND CALLS EACH OF THESE ROUTINES TO PRODUCE +C ONE PLOT EACH. +C +C ON THREE OF THE PLOTS, TAUTOG USES THE +C AUTOGRAPH CONTROL PARAMETER ROUTINES +C AGSETF, AGSETI, AND AGSETP TO SPECIFY +C Y-AXIS LABELS OR INTRODUCE LOG SCALING. +C +C PORTABILITY FORTRAN 77 +C + REAL X(21) ,Y1D(21) ,Y2D(21,5) +C +C X CONTAINS THE ABSCISSA VALUES FOR THE PLOTS PRODUCED BY EZXY AND +C EZMXY, Y1D CONTAINS THE ORDINATE VALUES FOR THE PLOTS PRODUCED BY +C EZXY AND EZY, AND Y2D CONTAINS THE ORDINATE VALUES FOR THE PLOTS +C PRODUCED BY EZMY AND EZMXY. +C +C +C +C +C FILL Y1D ARRAY FOR ENTRY EZY +C + DO 10 I=1,21 + Y1D(I) = EXP(-.1*FLOAT(I))*COS(FLOAT(I)*.5) + 10 CONTINUE +C +C ENTRY EZY PLOTS THE CONTENTS OF Y1D AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZY ENTRY OF AUTOGRAPH +C + CALL EZY (Y1D(1),21,'DEMONSTRATING EZY ENTRY OF AUTOGRAPH$') +C + +C +C +C +C FILL X AND Y1D ARRAYS FOR ENTRY EZXY +C + DO 20 I=1,21 + X(I) = FLOAT(I-1)*.314 + Y1D(I) = X(I)+COS(X(I))*2.0 + 20 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X+COS(X)*2 +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X+COS(X)*2$') +C +C ENTRY EZXY PLOTS CONTENTS OF X-ARRAY VS. Y1D-ARRAY +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZXY ENTRY OF AUTOGRAPH +C + CALL EZXY (X,Y1D,21,'DEMONSTRATING EZXY ENTRY IN AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR ENTRY EZMY +C + DO 40 I=1,21 + T = .5*FLOAT(I-1) + DO 30 J=1,5 + Y2D(I,J) = EXP(-.5*T)*COS(T)/FLOAT(J) + 30 CONTINUE + 40 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C EXP(-X/2)*COS(X)*SCALE +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','EXP(-X/2)*COS(X)*SCALE$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C GRAPH DRAWN IS TO BE LOGARITHMIC IN THE X-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',1) +C +C ENTRY EZMY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMY ENTRY OF AUTOGRAPH +C + CALL EZMY (Y2D,21,5,10,'DEMONSTRATING EZMY ENTRY OF AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR EZMXY +C + DO 60 I=1,21 + DO 50 J=1,5 + Y2D(I,J) = X(I)**J+COS(X(I)) + 50 CONTINUE + 60 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X**J+COS(X) +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X**J+COS(X)$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE GRAPH +C IS TO BE LINEAR IN THE X-AXIS AND LOGARITHMIC IN THE Y-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',0) + CALL AGSETI('Y/LOGARITHMIC.',1) +C +C ENTRY EZMXY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF A SINGLE +C X ARRAY (OR MANY X ARRAYS) +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH +C + CALL EZMXY (X,Y2D,21,5,21, + + 'DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH$') +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c1001 FORMAT (' AUTOGRAPH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conran.x b/sys/gio/ncarutil/tests/conran.x new file mode 100644 index 00000000..11a4ab0d --- /dev/null +++ b/sys/gio/ncarutil/tests/conran.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# T_CONRAN -- test NCAR contour routine CONRAN. + +procedure t_conran () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconan (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else { + call printf ("Test was not successful. ierror = %d\n") + call pargi (error_code) + } + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrant.f b/sys/gio/ncarutil/tests/conrant.f new file mode 100644 index 00000000..a144de35 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrant.f @@ -0,0 +1,97 @@ + SUBROUTINE TCONAN (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAN, THE STANDARD ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C THIS SAME SUBROUTINE CAN BE USED TO PRODUCE +C DEMO PLOTS OF THE SMOOTH VERSION OF CONRAN +C BY LOADING DASHSMTH INSTEAD OF DASHCHAR. +C +C USAGE CALL TCONAN (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAN LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAN +C FILES CONTERP +C CONCOM +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAN TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C COMMON /RANINT/ IRANMJ, IRANMN, IRANTX +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAN +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ + call conbdn +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAN',29, 0) +C + CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCR) +C + RETURN + END diff --git a/sys/gio/ncarutil/tests/conraq.x b/sys/gio/ncarutil/tests/conraq.x new file mode 100644 index 00000000..d0480e97 --- /dev/null +++ b/sys/gio/ncarutil/tests/conraq.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# T_CONRAQ -- test NCAR contour routine CONRAQ. + +procedure t_conraq () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconaq (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conraqt.f b/sys/gio/ncarutil/tests/conraqt.f new file mode 100644 index 00000000..dbf211aa --- /dev/null +++ b/sys/gio/ncarutil/tests/conraqt.f @@ -0,0 +1,139 @@ + SUBROUTINE TCONAQ (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAQ, THE QUICK ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAQ (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE. +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAQ LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAQ TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAQ +C FILES CONTERP +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAQ TERMINATED +C NORMALLY. +C + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAQ +C + DIMENSION WK(221),IWK(744) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAQ',29) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAQ TO CONTOUR DATA +C + CALL CONRAQ(XD,YD,ZD,NDP,WK,IWK) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAQ WILL NOT DO THIS +C +cCALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAQ TEST SUCCESSFUL, SEE PLOT TO VERIFY', +c 1' PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conras.x b/sys/gio/ncarutil/tests/conras.x new file mode 100644 index 00000000..d2b48dc2 --- /dev/null +++ b/sys/gio/ncarutil/tests/conras.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# T_CONRAS -- test NCAR contour routine CONRAS. + +procedure t_conras () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconas (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrast.f b/sys/gio/ncarutil/tests/conrast.f new file mode 100644 index 00000000..c4f3ab12 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrast.f @@ -0,0 +1,147 @@ + SUBROUTINE TCONAS (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAS, THE SUPER ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAS LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAS TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAS +C FILES CONTERP +C CONCOM +C DASHSUPR +C +C SPECIALIST FOR INFORMATION ABOUT THIS ROUTINE OR THE +C ULIB CONRAS PACKAGE, CONTACT THE SPECIALIST +C NAMED IN THE ULIB CONRAS PACKAGE. +C +C LANGUAGE FORTRAN +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAS TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI STANDARD +C +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAS +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAS',29,0) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAS TO CONTOUR DATA +C + CALL CONRAS(XD,YD,ZD,NDP,WK,IWK,SCR) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAS WILL NOT DO THIS +C +c CALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAS TEST SUCCESSFUL, SEE PLOT TO VERIFY ', +c 1'PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conrcqckt.f b/sys/gio/ncarutil/tests/conrcqckt.f new file mode 100644 index 00000000..d9d2f827 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcqckt.f @@ -0,0 +1,114 @@ + SUBROUTINE TCNQCK (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECQCK AND TO TEST CONRECQCK ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNQCK (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECQCK TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNQCK CALLS SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.4267/, TY/.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' CONRECQCK TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C--------------------------------------------------------------------- +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsmtht.f b/sys/gio/ncarutil/tests/conrcsmtht.f new file mode 100644 index 00000000..735d109a --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsmtht.f @@ -0,0 +1,122 @@ + SUBROUTINE TCNSMT (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSMTH AND TO TEST CONRECSMTH ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSMT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSMTH TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSMT CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +c DATA TX/0.42676/, TY/0.97656/ + TX = 0.42676 + TY = 0.97656 +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMAIZATION TRANS NUMBER TO WRITE TITLES +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' CONRECSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C +C--------------------------------------------------------------------- +C +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsprt.f b/sys/gio/ncarutil/tests/conrcsprt.f new file mode 100644 index 00000000..484d1ccc --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsprt.f @@ -0,0 +1,110 @@ + SUBROUTINE TCNSUP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSUPR AND TO TEST CONRECSUPR ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSUP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSUPR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSUP CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4219/, TY/0.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. ALSO THE LABELLING OF THE HIGHS AND LOWS IS SUPRESSED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,-1,0) + CALL NEWFM +C + WRITE (6,1001) + RETURN +C + 1001 FORMAT (' CONRECSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conrec.x b/sys/gio/ncarutil/tests/conrec.x new file mode 100644 index 00000000..2d9adfe5 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# T_CONREC -- test NCAR contour routine CONREC. + +procedure t_conrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrect.f b/sys/gio/ncarutil/tests/conrect.f new file mode 100644 index 00000000..401aad9b --- /dev/null +++ b/sys/gio/ncarutil/tests/conrect.f @@ -0,0 +1,118 @@ + SUBROUTINE TCONRE (nplot, IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONREC AND TO TEST CONREC ON A SINGLE +C PROBLEM +C +C USAGE CALL TCONRE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONREC TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCONRE CALL SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY FORTRAN77 +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +C DATA TX/.3955/, TY/.9765/ + data tx/.4267/, ty/.97/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION NUMBER 0 +C + CALL GSELNT ( 0 ) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR or CONREC + if (nplot .eq. 1) then + CALL WTSTR ( TX, TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC',2,0,0 ) + CALL EZCNTR (Z,21,25) + endif +c -noao +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR of CONREC + if (nplot .eq. 2) then + CALL WTSTR ( TX ,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC',2,0,0 ) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) + endif +c -noao +c CALL NEWFM +C +C WRITE (6,1001) + RETURN +C +C1001 FORMAT (' CONREC TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashchar.x b/sys/gio/ncarutil/tests/dashchar.x new file mode 100644 index 00000000..77430f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchar.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHCHAR + +procedure t_dashchar() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashc (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashchart.f b/sys/gio/ncarutil/tests/dashchart.f new file mode 100644 index 00000000..fa583b84 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchart.f @@ -0,0 +1,145 @@ + SUBROUTINE TDASHC (IERROR) +C +C LATEST REVISION MAY 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHCHAR +C AND TO TEST DASHCHAR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHCHAR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHCHAR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHC UTILIZES THE SOFTWARE DASHCHAR +C SUBROUTINES DASHDB, DASHDC, FRSTD, VECTD, +C LINED AND CURVED TO DRAW FIVE CURVES ON ONE +C PICTURE USING FIVE DIFFERENT DASHCHAR +C PATTERNS. EACH CURVE IS CENTERED ABOUT +C SOLID AXIS LINES AND LABELLED WITH THE +C CHARACTER REPRESENTATION OF THE DASHCHAR +C PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY-IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHCHAR PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHCHAR') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c + noao: no need for clearing terminal +c CALL NEWFM +c - noao +C + IERROR = 0 +C WRITE (6,1001) +C + RETURN +C +C +C1001 FORMAT (' DASHCHAR TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashlinet.f b/sys/gio/ncarutil/tests/dashlinet.f new file mode 100644 index 00000000..c857428c --- /dev/null +++ b/sys/gio/ncarutil/tests/dashlinet.f @@ -0,0 +1,138 @@ + SUBROUTINE TDASHL (IERROR) +C +C LATEST REVISION APRIL 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHLINE +C AND TO TEST DASHLINE ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHL (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHLINE TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHLINE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHL UTILIZES THE SOFTWARE DASHLINE +C SUBROUTINES DASHDB, FRSTD, VECTD, LINED AND +C CURVED TO DRAW FIVE CURVES ON ONE PICTURE +C USING FIVE DIFFERENT DASHLINE PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE BINARY REPRESENTATION OF THE +C DASHLINE PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C COORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) ,IPAT(5) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED +C SUPPORT ROUTINES) ARE USED. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C +C ARRAY IPAT CONTAINS 5 DIFFERENT 16-BIT DASH PATTERNS. THE PATTERNS +C CONSTRUCTED WITH BOOLEAN OPERATIONS AS ABOVE. +C THE BINARY REPRESENTATIONS OF THE PATTERNS ARE +C 0001110001111111 +C 1111000011110000 +C 1111110011111100 +C 1111111100000000 +C 1111111111111100 +C + IPAT(1) = IOR (ISHIFT ( 3647,1), 1) + IPAT(2) = ISHIFT (30840,1) + IPAT(3) = ISHIFT (32382,1) + IPAT(4) = ISHIFT (32640,1) + IPAT(5) = ISHIFT (32766,1) +C + DO 70 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) + CALL DASHDB (IPAT(K)) +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 10 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 10 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE BINARY REPRESENTATION OF +C THE DASHLINE PATTERN +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.09 + GO TO ( 20, 30, 40, 50, 60),K + 20 CALL GTX (.1,ORY,'IPAT=0001110001111111') + GO TO 70 + 30 CALL GTX (.1,ORY,'IPAT=1111000011110000') + GO TO 70 + 40 CALL GTX (.1,ORY,'IPAT=1111110011111100') + GO TO 70 + 50 CALL GTX (.1,ORY,'IPAT=1111111100000000') + GO TO 70 + 60 CALL GTX (.1,ORY,'IPAT=1111111111111100') +C + 70 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHLINE') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHLINE TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsmth.x b/sys/gio/ncarutil/tests/dashsmth.x new file mode 100644 index 00000000..4bca9807 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmth.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHSMTH + +procedure t_dashsmth() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashsmtht.f b/sys/gio/ncarutil/tests/dashsmtht.f new file mode 100644 index 00000000..147d5139 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmtht.f @@ -0,0 +1,144 @@ + SUBROUTINE TDASHS (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSMTH +C AND TO TEST DASHSMTH ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSMTH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSMTH +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHS UTILIZES THE SOFTWARE DASHSMTH +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSMTH PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSMTH') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c 1001 FORMAT (' DASHSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsuprt.f b/sys/gio/ncarutil/tests/dashsuprt.f new file mode 100644 index 00000000..f35c9c8b --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsuprt.f @@ -0,0 +1,151 @@ + SUBROUTINE TDASHP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSUPR +C AND TO TEST DASHSUPR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSUPR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSUPR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHP UTILIZES THE SOFTWARE DASHSUPR +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSUPR PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C RESET INITIALIZES THE MODEL PICTURE ARRAY AND SHOULD BE CALLED WITH +C EACH NEW FRAME AND BEFORE THE OTHER SUBROUTINES OF THE DASHSUPR +C PACKAGE. +C + CALL RESET +C +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED PLOT PACKAGE +C SUPPORT ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSUPR') + CALL GTX (.5,.013,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezconrec.x b/sys/gio/ncarutil/tests/ezconrec.x new file mode 100644 index 00000000..afb0775c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezconrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# T_EZCONREC -- test NCAR contour routine EZCNTR. + +procedure t_ezconrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/ezhafton.x b/sys/gio/ncarutil/tests/ezhafton.x new file mode 100644 index 00000000..e1cbbc2c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +procedure t_ezhafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call zhafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezhaftont.f b/sys/gio/ncarutil/tests/ezhaftont.f new file mode 100644 index 00000000..b3fcee3b --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhaftont.f @@ -0,0 +1,123 @@ + SUBROUTINE ZHAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C EZHAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL ZHAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C + CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) + CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C +c CALL GSELNT (0) +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) +c CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezisosrf.x b/sys/gio/ncarutil/tests/ezisosrf.x new file mode 100644 index 00000000..21257526 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezisosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine EZISOSRF + +procedure t_ezisos() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapg.x b/sys/gio/ncarutil/tests/ezmapg.x new file mode 100644 index 00000000..d2f7dce1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapg.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine SUPMAP of the EZMAPG utility. + +procedure t_ezmapg() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsupma (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapgt.f b/sys/gio/ncarutil/tests/ezmapgt.f new file mode 100644 index 00000000..fab53ce0 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapgt.f @@ -0,0 +1,318 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c CALL NEWFM + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -nooa + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C +C WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao +C +C +c IF (IERROR .EQ. 0) WRITE (6,1002) +c IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C +c1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) +c1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +c1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezmapt.f b/sys/gio/ncarutil/tests/ezmapt.f new file mode 100644 index 00000000..330fe6e2 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapt.f @@ -0,0 +1,300 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = 0 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW + CALL FRAME +C +C + IF (IERROR .EQ. 0) WRITE (6,1002) + IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C + 1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) + 1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') + 1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezsurface.x b/sys/gio/ncarutil/tests/ezsurface.x new file mode 100644 index 00000000..75abf061 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezsurface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine EZSRF. + +procedure t_ezsurface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (1, error_code) + if (error_code == 0) + call printf ("Test of EZSRF successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezvelvect.x b/sys/gio/ncarutil/tests/ezvelvect.x new file mode 100644 index 00000000..aeb5a5ab --- /dev/null +++ b/sys/gio/ncarutil/tests/ezvelvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routines EZVELVEC + +procedure t_ezvelvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezytst.x b/sys/gio/ncarutil/tests/ezytst.x new file mode 100644 index 00000000..b3ac1cb1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezytst.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> +include <ctype.h> + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +task ezytst = t_ezytst + +procedure t_ezytst() + +char device[SZ_FNAME], title[SZ_LINE] +int wkid, i +real y_vector[512] +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + # Construct vector to be plotted + do i = 1, 512 + y_vector[i] = i + + call strcpy ("TIMING TEST: 512 POINT VECTOR$", title, SZ_LINE) + call ezy (y_vector(1), 512, 'Timing Test: 512 Point Vector$') + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/hafton.x b/sys/gio/ncarutil/tests/hafton.x new file mode 100644 index 00000000..63795b22 --- /dev/null +++ b/sys/gio/ncarutil/tests/hafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +procedure t_hafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call thafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/haftont.f b/sys/gio/ncarutil/tests/haftont.f new file mode 100644 index 00000000..b4cfe017 --- /dev/null +++ b/sys/gio/ncarutil/tests/haftont.f @@ -0,0 +1,123 @@ + SUBROUTINE THAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C HAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL THAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C +c CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) +c CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C + CALL GSELNT (0) + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) + CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrf.x b/sys/gio/ncarutil/tests/isosrf.x new file mode 100644 index 00000000..1216db50 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine ISOSRFHR + +procedure t_isosrf() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/isosrfhrt.f b/sys/gio/ncarutil/tests/isosrfhrt.f new file mode 100644 index 00000000..1d8fb249 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrfhrt.f @@ -0,0 +1,165 @@ + SUBROUTINE TISOHR (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ISOSRFHR PACKAGE +C +C USAGE CALL TISOHR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES +C =1 OTHERWISE +C +C I/O THIS ROUTINE REQUIRES UNIT IUNIT FOR SCRATCH +C PURPOSES. USERS SHOULD PUT THE UNITS LABELLED +C COMMON (SEE BELOW) IN THE CALLING PROGRAM, +C AND ALSO SET THE VALUE OF THE COMMON VARIABLE +C IUNIT IN THE CALLING PROGRAM. +C +C IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES THE MESSAGE +C ISOSRFHR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C ALSO, A SAMPLE PLOT IS +C PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. ONE MUST EXAMINE THIS PLOT +C TO DETERMINE IF THE ROUTINES HAVE +C EXECUTED CORRECTLY. +C +C COMMON BLOCKS UNITS +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRFHR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM THIS SUBROUTINE USES THE ROUTINES IN +C THE PACKAGE ISOSRFHR TO DRAW A PERSPECTIVE +C DRAWING OF TWO INTERLOCKING DOUGHNUTS +C +C PORTABILITY ANSI STANDARD +C +C + DIMENSION EYE(3) ,S(4) ,IS2(4,200) , + 1 ST1(81,51,2) ,IOBJS(81,51) + COMMON /UNITS/ IUNIT +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA IX/448/, IY/990/ +C +C +C DEFINE THE EYE POSITION +C + DATA EYE(1), EYE(2), EYE(3) / 200., 250., 250. / +C +C DEFINE THE OVERALL DIMENSION OF THE BOX CONTAINING THE OBJECTS +C + DATA NU, NV, NW / 51, 81, 51 / +C +C SPECIFY THE DIMENSIONS OF THE MODEL OF THE IMAGE PLANE +C + DATA LX, NX, NY / 4, 180, 180 / +C +C SPECIFY CRT COORDINATES OF THE AREA WHERE THE PICTURE +C IS TO BE DRAWN +C + DATA S(1),S(2),S(3),S(4)/ 10.,1010.,10.,1010./ + DATA MV / 81 / +C +C SPECIFY THE LARGE AND SMALL RADII FOR THE INDIVIDUAL DOUGHNUTS +C + DATA RBIG1,RBIG2,RSML1,RSML2/ 20., 20., 6., 6. / +C + SAVE +C +C CALL THE INITIALIZATION ROUTINE +C + CALL INIT3D (EYE,NU,NV,NW,ST1,LX,NY,IS2,IUNIT,S) +C +C INITIALIZE THE ERRROR FLAG +C + IERROR = 1 +C +C CREATE AND PLOT DATA FOR TWO INTERLOCKING DOUGHNUTS +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 70 IBKWDS=1,NU + I = NU+1-IBKWDS +C +C CREATE THE I-TH CROSS SECTION IN THE U DIRECTION OF THE +C THREE-DIMENSIONAL ARRAY AND STORE IN IOBJS AS ZEROS AND ONES +C + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + TEMP = AMIN1(FIMID**2+FJP1**2+FKP1**2-RSML1**2, + 1 FKMID**2+FIP2**2+FJP2**2-RSML2**2) + IF (TEMP .LE. 0.) IOBJS(J,K) = 1 + IF (TEMP .GT. 0.) IOBJS(J,K) = 0 + 10 CONTINUE + 20 CONTINUE +C +C SET PROPER WORDS TO 1 FOR DRAWING AXES +C + IF (I .NE. 1) GO TO 50 + DO 30 K=1,NW + IOBJS(1,K) = 1 + 30 CONTINUE + DO 40 J=1,NV + IOBJS(J,1) = 1 + 40 CONTINUE + GO TO 60 + 50 CONTINUE + IOBJS(1,1) = 1 + 60 CONTINUE +C +C CALL THE DRAW AND REMEMBER ROUTINE FOR THIS SLAB +C + CALL DANDR (NV,NW,ST1,LX,NX,NY,IS2,IUNIT,S,IOBJS,MV) + 70 CONTINUE +C +C TITLE THE PLOT +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = PAU2FX(IX) + YC = PAU2FY(IY) + CALL WTSTR(XC,YC,'DEMONSTRATION PLOT FOR ISOSRFHR',2,0,0) + CALL GSELNT(ICN) +C +C ADVANCE THE PLOTTING DEVICE +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRFHR TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrft.f b/sys/gio/ncarutil/tests/isosrft.f new file mode 100644 index 00000000..1e99e02e --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrft.f @@ -0,0 +1,137 @@ + SUBROUTINE TISOSR (nplot, IERROR) +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ISOSRF AND TO TEST ISOSRF ON A SINGLE PROBLEM +C +C USAGE CALL TISOSR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C ISOSRF TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE SAMPLE +C PLOTS ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF FROM ULIB LIBRARY +C FILES +C +C LANGUAGE STANDARD FORTRAN77 +C +C HISTORY WRITTEN BY MEMBERS OF THE +C SCIENTIFIC COMPUTING DIVISION OF NCAR, +C BOULDER COLORADO +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS EZISOS AND ISOSRF TO DRAW ISO- +C VALUED SURFACE PLOTS OF THE FUNCTION. +C +C PORTABILITY ANSI STANDARD +C +C + SAVE + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + REAL IX,IY + DATA IX/.44/, IY/.95/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C LABEL THE PLOT TO BE DRAWN BY EZISOS +C + if (nplot .eq. 1) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY EZISOS OF ISOSRF', + 1 2,0,0) +C +C TEST EZISOS +C + CALL EZISOS (T,NU,NV,NW,EYE,SLAB,TISO) + endif +C +C LABEL THE PLOT TO BE DRAWN BY ISOSRF +C + if (nplot .eq. 2) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY ISOSRF OF ISOSRF', + 1 2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU=NU/2 + MV=NV/2 + MW=NW/2 + MUVWP2=MAX0(MU,MV,MW)+2 + CALL ISOSRF(T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) + endif +c CALL FRAME +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRF TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/mkpkg b/sys/gio/ncarutil/tests/mkpkg new file mode 100644 index 00000000..79beff4f --- /dev/null +++ b/sys/gio/ncarutil/tests/mkpkg @@ -0,0 +1,65 @@ +# Make the x_ncartest.e executable for testing the NCAR utilities. + #conraq.x <error.h> <gset.h> + #conraqt.f + #conras.x <error.h> <gset.h> + #conrast.f + #conrcqckt.f + #conrcsmtht.f + #conrcsprt.f + #dashchar.x + #dashchart.f + #dashlinet.f + #dashsuprt.f + #ezmapg.x <error.h> <gset.h> + #ezmapgt.f + #ezmapt.f + #isosrfhrt.f + +$update libpkg.a +$omake x_ncartest.x +$link x_ncartest.o libpkg.a -lncar -lgks -o /tmp2/newncar/x_ncartest.e +$exit + +libpkg.a: + auto10t.f + autograph.x <ctype.h> <error.h> <gset.h> + autographt.f + conran.x <error.h> <gset.h> + conrant.f + conrec.x <error.h> <gset.h> + conrect.f + dashsmth.x + dashsmtht.f + ezconrec.x <error.h> <gset.h> + ezhafton.x <error.h> <gset.h> + ezhaftont.f + ezisosrf.x <error.h> <gset.h> + ezsurface.x <error.h> <gset.h> + ezvelvect.x <error.h> <gset.h> + ezytst.x <ctype.h> <error.h> <gset.h> + hafton.x <error.h> <gset.h> + haftont.f + isosrf.x <error.h> <gset.h> + isosrft.f + oldauto.x <ctype.h> <error.h> <gset.h> + oldautot.f + preal.x + pwrity.x + pwrityt.f + pwrzit.f + pwrzs.x + pwrzst.f + pwrztt.f + srfacet.f + srftest.x + srftestd.x + strmln.x <error.h> <gset.h> + strmlnt.f + surface.x <error.h> <gset.h> + threed.x <error.h> <gset.h> + threed2.x <error.h> <gset.h> + threed2t.f + threedt.f + velvctt.f + velvect.x <error.h> <gset.h> + ; diff --git a/sys/gio/ncarutil/tests/oldauto.x b/sys/gio/ncarutil/tests/oldauto.x new file mode 100644 index 00000000..90287803 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldauto.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> +include <ctype.h> + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_oldauto() + +char device[SZ_FNAME], command[SZ_LINE] +int error_code, wkid +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call exmpl1 + call exmpl2 + call exmpl3 + call exmpl4 + call exmpl5 + call exmpl6 + call exmpl7 + call exmpl8 + # call exmpl9 + call xmpl11 + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/oldautot.f b/sys/gio/ncarutil/tests/oldautot.f new file mode 100644 index 00000000..168d5f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldautot.f @@ -0,0 +1,833 @@ + SUBROUTINE EXMPL1 +C +C Define the data array. +C + REAL YDRA(1001) +C +C Fill the data array. +C + DO 101 I=1,1001 + X=FLOAT(I)/20. + YDRA(I)=10.*(X-1.)*(X-11.)*(X-21.)*(X-31.)*(X-41.)*(X-51.) + + +2.E7*(FRAN()-.5) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZY. +C + CALL EZY (YDRA,1001,'EXAMPLE 1 (EZY)$') +C +c STOP +C + END + FUNCTION FRAN() +C +C Random-number generator. +C + DATA X / 2.7182818 / + SAVE X + X=AMOD(9821.*X+.211327,1.) + FRAN=X + RETURN + END + SUBROUTINE BNDARY +C +C Routine to draw the plotter-frame edge. +C + CALL PLOTIT ( 0, 0,0) + CALL PLOTIT (32767, 0,1) + CALL PLOTIT (32767,32767,1) + CALL PLOTIT ( 0,32767,1) + CALL PLOTIT ( 0, 0,1) + RETURN + END +c + SUBROUTINE EXMPL2 +C +C Define the data arrays. +C + REAL XDRA(4001),YDRA(4001) +C +C Fill the data arrays. +C + DO 101 I=1,4001 + THETA=.0015707963267949*FLOAT(I-1) + RHO=SIN(2.*THETA)+.05*SIN(64.*THETA) + XDRA(I)=RHO*COS(THETA) + YDRA(I)=RHO*SIN(THETA) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,4001,'EXAMPLE 2 (EZXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL3 +C +C Define the data array. +C + REAL YDRA(100,2) +C +C Fill the data array. +C + DO 101 I=1,100 + YDRA(I,1)=COS(3.14159265358979*FLOAT(I)/25.)*FLOAT(I)**2 + YDRA(I,2)=COS(3.14159265358979*FLOAT(I)/25.)*10.**(.04*FLOAT(I)) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMY. +C + CALL EZMY (YDRA,100,2,100,'EXAMPLE 3 (EZMY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL4 +C +C Define the data arrays. +C + REAL XDRA(201),YDRA(201,10) +C +C Fill the data arrays. +C + DO 102 I=1,201 + XDRA(I)=-1.+.02*FLOAT(I-1) + IF (I.GT.101) XDRA(I)=2.-XDRA(I) + DO 101 J=1,10 + YDRA(I,J)=FLOAT(J)*SQRT(1.000000000001-XDRA(I)**2)/10. + IF (I.GT.101) YDRA(I,J)=-YDRA(I,J) + 101 CONTINUE + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,201,10,201,'EXAMPLE 4 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL5 +C +C Define the data arrays. +C + REAL XDRA(401,6),YDRA(401,6) +C +C Compute required constants. +C + PI=3.14159265358979 + PID200=PI/200. + PITTWO=2.*PI + PIT2D3=2.*PI/3. + PIT4D3=4.*PI/3. + RADOSC=SQRT(3.)/3. + RADOLC=SQRT(3.)/2. + BSSCLL=ATAN(SQRT(12.)/6.) + BSSCUL=ATAN(SQRT(143.)/7.) + BSLCLL=ATAN(SQRT(143.)/17.) + BSLCUL=ATAN(SQRT(2.0)) +C +C Fill the data arrays. +C + DO 101 I=1,401 + THETA=PID200*FLOAT(I-1) + XDRA(I,1)= -.5+RADOSC*COS(THETA) + YDRA(I,1)= RADOSC*SIN(THETA) + IF (ABS(THETA ).GE.BSSCLL.AND. + + ABS(THETA ).LE.BSSCUL) XDRA(I,1)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSSCLL.AND. + + ABS(THETA-PITTWO).LE.BSSCUL) XDRA(I,1)=1.E36 + XDRA(I,2)= .5+RADOSC*COS(THETA) + YDRA(I,2)= RADOSC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSSCLL.AND. + + ABS(THETA-PIT2D3).LE.BSSCUL) XDRA(I,2)=1.E36 + XDRA(I,3)= RADOSC*COS(THETA) + YDRA(I,3)=RADOLC+RADOSC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSSCLL.AND. + + ABS(THETA-PIT4D3).LE.BSSCUL) XDRA(I,3)=1.E36 + XDRA(I,4)= -.5+RADOLC*COS(THETA) + YDRA(I,4)= RADOLC*SIN(THETA) + IF (ABS(THETA ).GE.BSLCLL.AND. + + ABS(THETA ).LE.BSLCUL) XDRA(I,4)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSLCLL.AND. + + ABS(THETA-PITTWO).LE.BSLCUL) XDRA(I,4)=1.E36 + XDRA(I,5)= .5+RADOLC*COS(THETA) + YDRA(I,5)= RADOLC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSLCLL.AND. + + ABS(THETA-PIT2D3).LE.BSLCUL) XDRA(I,5)=1.E36 + XDRA(I,6)= RADOLC*COS(THETA) + YDRA(I,6)=RADOLC+RADOLC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSLCLL.AND. + + ABS(THETA-PIT4D3).LE.BSLCUL) XDRA(I,6)=1.E36 + 101 CONTINUE +C +C Specify subscripting of XDRA and YDRA. +C + CALL AGSETI ('ROW.',2) +C +C Make sure grid shape is such that one unit in x = one unit in y. +C + CALL AGSETF ('GRID/SHAPE.',2.) +C +C Turn off background, then turn labels back on. +C + CALL AGSETF ('BACKGROUND.',4.) + CALL AGSETI ('LABEL/CONTROL.',2) +C +C Turn off left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LABEL/SUPPRESSION FLAG.',1) +C +C Change text of bottom label. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PURITY, BODY, AND FLAVOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,401,6,401,'EXAMPLE 5 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL6 +C +C Define the data arrays. +C + REAL XDRA(501),YDRA(501) +C + CHARACTER*35 GLAB + CHARACTER*23 BACK(4) + CHARACTER*12 LNLG(4) + character*1 tmp +C Define the graph-window parameter array. +C + REAL GWND (4,4) +C + DATA (GWND(I,1),I=1,4) / 0.0 , 0.5 , 0.5 , 1.0 / + DATA (GWND(I,2),I=1,4) / 0.5 , 1.0 , 0.5 , 1.0 / + DATA (GWND(I,3),I=1,4) / 0.0 , 0.5 , 0.0 , 0.5 / + DATA (GWND(I,4),I=1,4) / 0.5 , 1.0 , 0.0 , 0.5 / +C +C Define variables used in setting up informational labels on the graph. +C +C + DATA BACK(1) / '(PERIMETER BACKGROUND)$' / + DATA BACK(2) / '(GRID BACKGROUND)$ ' / + DATA BACK(3) / '(HALF-AXIS BACKGROUND)$' / + DATA BACK(4) / '(NO BACKGROUND)$ ' / +C + DATA LNLG(1) / 'LINEAR$' / + DATA LNLG(2) / 'LOGARITHMIC$' / +C +C Fill the data arrays. +C + DO 101 I=1,501 + THETA=.031415926535898*FLOAT(I-1) + XDRA(I)=500.+.9*FLOAT(I-1)*COS(THETA) + YDRA(I)=500.+.9*FLOAT(I-1)*SIN(THETA) + 101 CONTINUE +C +C +C Do four graphs on the same frame, using different backgrounds. +C + DO 102 IGRF = 1,4 +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Position the graph window. +C + CALL AGSETP ('GRAPH WINDOW.',GWND(1,IGRF),4) +C +C Declare the background type. +C + CALL AGSETI ('BACKGROUND TYPE.',IGRF) +C +C Setting the background type may have turned the informational labels +C off. In that case, turn them back on. +C + IF (IGRF.EQ.4) CALL AGSETI ('LABEL/CONTROL.',2) +C +C Set up parameters determining the linear/log nature of the axes. +C + ILLX=(IGRF-1)/2 + ILLY=MOD(IGRF-1,2) +C +C Declare the linear/log nature of the graph. +C + CALL AGSETI ('X/LOGARITHMIC.',ILLX) + CALL AGSETI ('Y/LOGARITHMIC.',ILLY) +C +C Change the x- and y-axis labels to reflect the linear/log nature of +C the graph. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLX+1)) +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLY+1)) +C +C Set up the label for the top of the graph. +C +c WRITE (GLAB,1001) IGRF,BACK(IGRF) + glab(1:35) = 'EXAMPLE 6- ' + glab(11:11) = char (igrf + ichar ('0')) + glab(13:35) = back (igrf) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,501,GLAB) +C + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C + CALL FRAME +C +c STOP +C +C Format for encode. +C +c1001 FORMAT ('EXAMPLE 6-',I1,' ',A23) + END +c + SUBROUTINE EXMPL7 +C +C Define the data arrays and the dash-pattern array. +C + REAL XDRA(101),YDRA(101,9) + CHARACTER*28 DSHP(9) +C +C Declare the type of the dash-pattern-name generator. +C + CHARACTER*16 AGDSHN +C +C Fill the data arrays and the dash pattern array. +C + DO 101 I=1,101 + XDRA(I)=-90.+1.8*FLOAT(I-1) + 101 CONTINUE +C + DO 103 J=1,9 +c WRITE (DSHP(J),1001) J + dshp(j) = '$$$$$$$$$$$$$$$$$$$$$ J = ' + dshp(j)(27:27) = char (j + ichar ('0')) + FJ=J + DO 102 I=1,101 + YDRA(I,J)=3.*FJ-(FJ/2700.)*XDRA(I)**2 + 102 CONTINUE + 103 CONTINUE +C +C Turn on windowing. (Some curves run outside the curve window.) +C + CALL AGSETI ('WINDOWING.',1) +C +C Move the edges of the curve window (grid). +C + CALL AGSETF ('GRID/LEFT.' ,.10) + CALL AGSETF ('GRID/RIGHT.' ,.90) + CALL AGSETF ('GRID/BOTTOM.',.10) + CALL AGSETF ('GRID/TOP.' ,.85) +C +C Set the x and y minimum and maximum. +C + CALL AGSETF ('X/MINIMUM.',-90.) + CALL AGSETF ('X/MAXIMUM.',+90.) + CALL AGSETF ('Y/MINIMUM.', 0.) + CALL AGSETF ('Y/MAXIMUM.', 18.) +C +C Set left axis parameters. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',1) + CALL AGSETF ('LEFT/MAJOR/BASE.',3.) + CALL AGSETI ('LEFT/MINOR/SPACING.',2) +C +C Set right axis parameters. +C + CALL AGSETI ('RIGHT/FUNCTION.',1) + CALL AGSETF ('RIGHT/NUMERIC/TYPE.',1.E36) +C +C Set bottom axis parameters. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',15.) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',2) +C +C Set top axis parameters. +C + CALL AGSETI ('TOP/FUNCTION.',1) + CALL AGSETF ('TOP/NUMERIC/TYPE.',1.E36) +C +C Set up the dash patterns to be used. +C + CALL AGSETI ('DASH/SELECTOR.',9) + CALL AGSETI ('DASH/LENGTH.',28) + DO 104 I=1,9 + CALL AGSETC (AGDSHN(I),DSHP(I)) + 104 CONTINUE +C +C Set up the left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','HEIGHT (KILOMETERS)$') +C +C Set up the right label. +C + CALL AGSETC ('LABEL/NAME.','R') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PRESSURE (TONS/SQUARE FURLONG)$') +C +C Set up the bottom labels. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','LATITUDE (DEGREES)$') +C + CALL AGSETC ('LABEL/NAME.','SP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.000001) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','SP$') +C + CALL AGSETC ('LABEL/NAME.','NP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.999999) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','NP$') +C +C Set up the top label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',80) + CALL AGSETC ('LINE/TEXT.','DISTANCE FROM EQUATOR (MILES)$') + CALL AGSETI ('LINE/NUMBER.',90) + CALL AGSETC ('LINE/TEXT.',' $') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','LINES OF CONSTANT INCRUDESCENCE$') + CALL AGSETI ('LINE/NUMBER.',110) + CALL AGSETC ('LINE/TEXT.','EXAMPLE 7 (EZMXY)$') +C +C Set up centered (box 6) label. +C + CALL AGSETC ('LABEL/NAME.','EQUATOR') + CALL AGSETI ('LABEL/ANGLE.',90) + CALL AGSETI ('LINE/NUMBER.',0) + CALL AGSETC ('LINE/TEXT.','EQUATOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,101,9,101,0) +C +c STOP +C +C Format for encode above. +C +c1001 FORMAT ('$$$$$$$$$$$$$$$$$$$$$''J''=''',I1,'''') +C + END +c + SUBROUTINE EXMPL8 +C +C Define the data arrays. +C + REAL XDRA(101),YDRA(4,101) +C +C Fill the data arrays. +C + DO 101 I=1,101 + XDRA(I)=-3.14159265358979+.062831853071796*FLOAT(I-1) + 101 CONTINUE +C + DO 103 I=1,4 + FLTI=I + BASE=2.*FLTI-1. + DO 102 J=1,101 + YDRA(I,J)=BASE+.75*SIN(-3.14159265358979+.062831853071796* + + FLTI*FLOAT(J-1)) + 102 CONTINUE + 103 CONTINUE +C +C Change the line-end character to a period. +C + CALL AGSETC ('LINE/END.','.') +C +C Specify labels for x and y axes. +C + CALL ANOTAT ('SINE FUNCTIONS OF T.','T.',0,0,0,0) +C +C Use a half-axis background. +C + CALL AGSETI ('BACKGROUND.',3) +C +C Move x axis to the zero point on the y axis. +C + CALL AGSETF ('BOTTOM/INTERSECTION/USER.',0.) +C +C Specify base value for spacing of major ticks on x axis. +C + CALL AGSETF ('BOTTOM/MAJOR/BASE.',1.) +C +C Run major ticks on x axis to edge of curve window. +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD.',1.) + CALL AGSETF ('BOTTOM/MAJOR/OUTWARD.',1.) +C +C Position x axis minor ticks. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',9) +C +C Run the y axis backward. +C + CALL AGSETI ('Y/ORDER.',1) +C +C Run plots full-scale in y. +C + CALL AGSETI ('Y/NICE.',0) +C +C Have AUTOGRAPH scale x and y data the same. +C + CALL AGSETF ('GRID/SHAPE.',.01) +C +C Use the alphabetic set of dashed-line patterns. +C + CALL AGSETI ('DASH/SELECTOR.',-1) +C +C Tell AUTOGRAPH how the data arrays are dimensioned. +C + CALL AGSETI ('ROW.',-1) +C +C Reverse the roles of the x and y arrays. +C + CALL AGSETI ('INVERT.',1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the curves. +C + CALL EZMXY (XDRA,YDRA,4,4,101,'EXAMPLE 8.') +C +c STOP +C + END +c +C SUBROUTINE EXMPL9 +CC +CC Define the data arrays. +CC +C DIMENSION XDAT(400),YDAT(400) +CC +CC Fill the data arrays. +CC +C DO 101 I=1,400 +C XDAT(I)=(FLOAT(I)-1.)/399. +C 101 CONTINUE +CC +C CALL GENDAT (YDAT( 1),200,200,1,3,3,+.01,+10.) +C CALL GENDAT (YDAT(201),200,200,1,3,3,-10.,-.01) +CC +CC The y data ranges over both positive and negative values. It is +CC desired that both ranges be represented on the same graph and that +CC each be shown logarithmically, ignoring values in the range -.01 to +CC +.01, in which we're not interested. First we map each y datum into +CC its absolute value (.01 if the absolute value is too small). Then we +CC take the base-10 logarithm, add 2.0001 (so as to be sure of getting a +CC positive number), and re-attach the original sign. We can plot the +CC resulting y data on a linear y axis. +CC +C DO 102 I=1,400 +C YDAT(I)=SIGN(ALOG10(AMAX1(ABS(YDAT(I)),.01))+2.0001,YDAT(I)) +C 102 CONTINUE +CC +CC In order that the labels on the y axis should show the original values +CC of the y data, we change the user-system-to-label-system mapping on +CC both y axes and force major ticks to be spaced logarithmically in the +CC label system (which will be defined by the subroutine AGUTOL in such +CC a way as to re-create numbers in the original range). +CC +C CALL AGSETI ('LEFT/FUNCTION.',1) +C CALL AGSETI ('LEFT/MAJOR/TYPE.',2) +CC +C CALL AGSETI ('RIGHT/FUNCTION.',1) +C CALL AGSETI ('RIGHT/MAJOR/TYPE.',2) +CC +CC Change the label on the left axis to reflect what's going on. +CC +C CALL AGSETC ('LABEL/NAME.','L') +C CALL AGSETI ('LINE/NUMBER.',100) +C CALL AGSETC ('LINE/TEXT.','LOG SCALING, POSITIVE AND NEGATIVE$') +CC +CC Draw a boundary around the edge of the plotter frame. +CC +Cc CALL BNDARY +CC +CC Draw the curve. +CC +C CALL EZXY (XDAT,YDAT,400,'EXAMPLE 9$') +CC +Cc STOP +CC +C END +Cc +C SUBROUTINE GENDAT (DATA,IDIM,M,N,MLOW,MHGH,DLOW,DHGH) +CC +CC This is a routine to generate test data for two-dimensional graphics +CC routines. Given an array "DATA", dimensioned "IDIM x 1", it fills +CC the sub-array ((DATA(I,J),I=1,M),J=1,N) with a two-dimensional field +CC of data having approximately "MLOW" lows and "MHGH" highs, a minimum +CC value of exactly "DLOW" and a maximum value of exactly "DHGH". +CC +CC "MLOW" and "MHGH" are each forced to be greater than or equal to 1 +CC and less than or equal to 25. +CC +CC The function used is a sum of exponentials. +CC +C DIMENSION DATA(IDIM,1),CCNT(3,50) +CC +C FOVM=9./FLOAT(M) +C FOVN=9./FLOAT(N) +CC +C NLOW=MAX0(1,MIN0(25,MLOW)) +C NHGH=MAX0(1,MIN0(25,MHGH)) +C NCNT=NLOW+NHGH +CC +C DO 101 K=1,NCNT +C CCNT(1,K)=1.+(FLOAT(M)-1.)*FRAN() +C CCNT(2,K)=1.+(FLOAT(N)-1.)*FRAN() +C IF (K.LE.NLOW) THEN +C CCNT(3,K)=-1. +C ELSE +C CCNT(3,K)=+1. +C END IF +C 101 CONTINUE +CC +C DMIN=+1.E36 +C DMAX=-1.E36 +C DO 104 J=1,N +C DO 103 I=1,M +C DATA(I,J)=.5*(DLOW+DHGH) +C DO 102 K=1,NCNT +C DATA(I,J)=DATA(I,J) + .5 * (DHGH-DLOW) * CCNT(3,K) * +C + EXP( - ( ( FOVM*(FLOAT(I)-CCNT(1,K)) )**2 + +C + ( FOVN*(FLOAT(J)-CCNT(2,K)) )**2 ) ) +C 102 CONTINUE +C DMIN=AMIN1(DMIN,DATA(I,J)) +C DMAX=AMAX1(DMAX,DATA(I,J)) +C 103 CONTINUE +C 104 CONTINUE +CC +C DO 106 J=1,N +C DO 105 I=1,M +C DATA(I,J)=(DATA(I,J)-DMIN)/(DMAX-DMIN)*(DHGH-DLOW)+DLOW +C 105 CONTINUE +C 106 CONTINUE +CC +C RETURN +CC +C END +Cc +C SUBROUTINE XMPL10 +C RETURN +C END +Cc + SUBROUTINE XMPL11 +C +C Create a sort of histogram. +C + REAL XDRA(249),YDRA(249),WORK(204),IWRK(204) +C +C Fill the data arrays. First, we define the histogram outline. This +C will be used in the call to FILL which fills in the area under the +C histogram. +C + XDRA(1)=0. + YDRA(1)=0. +C + DO 101 I=2,100,2 + XDRA(I )=XDRA(I-1) + YDRA(I )=EXP(-16.*(FLOAT(I/2)/50.-.51)**2)+.1*FRAN() + XDRA(I+1)=XDRA(I-1)+.02 + YDRA(I+1)=YDRA(I) + 101 CONTINUE +C + XDRA(102)=1. + YDRA(102)=0. +C +C Then, we define lines separating the vertical boxes from each other. +C + NDRA=102 +C + DO 102 I=3,99,2 + XDRA(NDRA+1)=1.E36 + YDRA(NDRA+1)=1.E36 + XDRA(NDRA+2)=XDRA(I) + YDRA(NDRA+2)=0. + XDRA(NDRA+3)=XDRA(I) + YDRA(NDRA+3)=AMIN1(YDRA(I),YDRA(I+1)) + NDRA=NDRA+3 + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,249,'EXAMPLE 11 (HISTOGRAM)$') +C +C Use the XLIB routine FILL to fill the area defined by the data. Note +C that FILL is not a part of the AUTOGRAPH package. +C +c CALL FILLOP ('AN',45) +c CALL FILLOP ('SP',128) +c CALL FILL (XDRA,YDRA,102,WORK,204,IWRK,204) +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C + END +c + SUBROUTINE EXMPLF +C +C Define the data array. +C + DIMENSION XYCD(226) +C +C Fill the data array. +C +c READ 1001 , XYCD +C + DO 101 I=1,226 + IF (XYCD(I).EQ.1.E36) GO TO 101 + XYCD(I)=2.**((XYCD(I)-15.)/2.5) + 101 CONTINUE +C +C Specify log/log plot. +C + CALL DISPLA (0,0,4) +C +C Bump the line-maximum parameter past 42. +C + CALL AGSETI ('LINE/MAXIMUM.',50) +C +C Specify x- and y-axis labels, grid background. +C + CALL ANOTAT ('LOGARITHMIC, BASE 2, EXPONENTIAL LABELING$', + + 'LOGARITHMIC, BASE 2, NO-EXPONENT LABELING$',2,0,0,0) +C +C Specify the graph label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','FINAL EXAMPLE$') +C +C Specify x-axis ticks and labels. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',3) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',2.) + CALL AGSETI ('BOTTOM/NUMERIC/TYPE.',2) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',4) +c CALL AGSETI ('BOTTOM/MINOR/PATTERN.',125252B) +C +C Specify y-axis ticks and labels. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',3) + CALL AGSETF ('LEFT/MAJOR/BASE.',2.) + CALL AGSETI ('LEFT/NUMERIC/TYPE.',3) + CALL AGSETI ('LEFT/MINOR/SPACING.',4) +c CALL AGSETI ('LEFT/MINOR/PATTERN.',125252B) +C +C Compute secondary control parameters. +C + CALL AGSTUP (XYCD(1),1,0,113,2,XYCD(2),1,0,113,2) +C +C Draw the background. +C + CALL AGBACK +C +C Draw the curve twice to make it darker. +C + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C +C Format. +C +c1001 FORMAT (14E5.0) +C + END +C 1.8 2.1 2.7 1.6 4.2 1.5 5.7 1.9 6.3 2.9 6.5 4.7 6.0 6.7 +C 5.6 8.6 5.4 10.7 5.6 13.1 4.8 11.2 3.7 9.7 1E36 1E36 7.0 8.2 +C 7.7 10.6 8.2 12.6 8.2 14.3 8.0 15.3 7.7 15.6 7.5 15.1 7.4 14.0 +C 7.6 12.3 7.7 10.7 7.9 8.9 8.2 7.3 8.5 4.6 8.5 7.3 8.6 9.3 +C 8.8 10.2 9.1 10.5 9.4 10.1 9.6 9.1 9.9 7.8 10.3 6.9 11.1 7.0 +C 11.7 7.8 12.0 8.6 12.3 10.0 12.5 11.5 12.4 12.7 12.2 13.0 11.9 12.6 +C 11.7 11.7 11.6 10.5 11.7 9.3 12.0 8.6 12.5 8.6 13.0 9.0 13.8 10.1 +C 14.3 11.1 1E36 1E36 18.5 23.4 18.2 23.5 17.8 23.2 17.2 22.6 16.8 21.8 +C 16.0 20.2 15.8 19.5 16.0 19.3 16.6 19.6 17.8 20.6 17.3 19.1 16.9 17.3 +C 16.6 16.0 16.6 14.5 16.8 13.7 17.1 13.1 17.8 13.2 18.4 14.0 19.2 15.5 +C 19.8 16.8 20.3 18.0 20.9 20.1 21.1 18.9 21.1 17.4 21.1 18.9 21.2 19.7 +C 1.5 20.5 21.8 20.8 22.0 20.4 22.1 19.6 22.3 18.7 22.6 18.4 23.1 18.9 +C 23.6 20.0 24.1 21.7 24.7 22.9 25.3 23.9 24.7 22.9 24.4 21.6 24.4 20.6 +C 24.7 20.2 25.2 20.7 25.6 21.5 26.0 22.9 26.4 24.5 26.7 25.9 26.8 27.9 +C 26.6 30.0 26.4 30.3 26.2 30.0 25.7 28.0 25.5 26.1 25.3 24.9 25.3 23.9 +C 25.4 22.9 25.9 22.5 26.6 22.4 27.4 23.1 28.2 24.0 29.0 25.0 30.1 26.4 +C 1E36 1E36 diff --git a/sys/gio/ncarutil/tests/preal.x b/sys/gio/ncarutil/tests/preal.x new file mode 100644 index 00000000..79d33218 --- /dev/null +++ b/sys/gio/ncarutil/tests/preal.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure preal (tval, rval) + +char tval[ARB] +real rval + +begin + call eprintf ("%s %.4f\n") + call pargstr (tval) + call pargr (rval) +end diff --git a/sys/gio/ncarutil/tests/pwrity.x b/sys/gio/ncarutil/tests/pwrity.x new file mode 100644 index 00000000..3b5c1437 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrity.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRITY + +procedure t_pwrity() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwry (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrityt.f b/sys/gio/ncarutil/tests/pwrityt.f new file mode 100644 index 00000000..5b033933 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrityt.f @@ -0,0 +1,90 @@ + SUBROUTINE TPWRY (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ENTRY PWRITY OF PWRITY AND +C TO TEST PWRITY ON A SIMPLE PROBLEM +C +C USAGE CALL TPWRY (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRITY TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN TO UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING +C CHARACTER STRING PLOTS IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. IN ORDER TO +C DETERMINE WHETHER THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRITY +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRY CALLS PWRITY TO PLOT VARIOUS CHARACTER +C STRINGS USING DIFFERENT PARAMETERS. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C INITIALIZE THE ERROR PARAMETER. +C + IERROR = 0 +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL GSVP (1, 0.0, 1.0, 0.0, 1.0) + CALL GSWN (1, 1.0, 1024.0, 1.0, 1024.0) + CALL GSELNT (1) + CALL SETUSV ('LS',1) +C +C LABEL FRAME +C + CALL PWRITY(512.0,950.0, + 1 'DEMONSTRATION PLOT FOR PWRITY', + 2 29,2,0,0) +C +C TEST PWRITY FOR DIFFERENT SIZE CHARACTERS. +C + CALL PWRITY (10.0,900.0,'SIZE TEST',9,0,0,-1) + CALL PWRITY (10.0,850.0,'SIZE TEST',9,1,0,-1) + CALL PWRITY (10.0,775.0,'SIZE TEST',9,2,0,-1) + CALL PWRITY (10.0,675.0,'SIZE TEST',9,3,0,-1) + CALL PWRITY (10.0,525.0,'SIZE TEST',9,4,0,-1) + CALL PWRITY (10.0,375.0,'SIZE TEST',9,5,0,-1) +C +C TEST PWRITY FOR DIFFERENT CHARACTER ORIENTATIONS. +C + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,0*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,1*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,2*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,3*90,-1) +C +C TEST CENTERING OPTIONS FOR PWRITY. +C + CALL PWRITY (512.0,160.0,'CENTR TEST',10,2,0,0) + CALL PWRITY (512.0,85.0,'CENTR TEST',10,2,0,-1) + CALL PWRITY (512.0,235.0,'CENTR TEST',10,2,0,1) +c +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' PWRITY TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzit.f b/sys/gio/ncarutil/tests/pwrzit.f new file mode 100644 index 00000000..7c96e926 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzit.f @@ -0,0 +1,132 @@ + SUBROUTINE TPWRZI (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZI IN CONJUNCTION WITH ISOSRF +C +C USAGE CALL TPWRZI (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZI TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZI, ISOSRF +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE THEN CALLS ISOSRF TO DRAW AN +C ISO-VALUED SURFACE PLOT OF THE FUNCTION, +C THEN PWRZI IS CALLED THREE TIMES TO +C LABEL THE FRONT, SIDE, AND BACK OF THE +C PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZI',2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU = NU/2 + MV = NV/2 + MW = NW/2 + MUVWP2 = MAX0(MU,MV,MW)+2 + CALL ISOSRF (T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO, + 1 IFLAG) + ISIZE = 35 + CALL PWRZI (5.,16.,.5,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZI (11.,7.5,.5,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZI (5.,1.,5.,' BACK BACK BACK BACK BACK',25,ISIZE,-1,3,0) + CALL SETUSV ('XF',10) + CALL SETUSV ('YF',10) + CALL NEWFM + IERROR = 0 +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' PWRZI TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzs.x b/sys/gio/ncarutil/tests/pwrzs.x new file mode 100644 index 00000000..f2eeec96 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzs.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRZS + +procedure t_przs() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwrzs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrzst.f b/sys/gio/ncarutil/tests/pwrzst.f new file mode 100644 index 00000000..4067ed86 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzst.f @@ -0,0 +1,127 @@ + SUBROUTINE TPWRZS (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZS IN CONJUNCTION WITH SRFACE. +C +C USAGE CALL TPWRZS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST WAS SUCCESSFUL, THE MESSAGE +C +C PWRZS TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZS, SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF TWO VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A TWO DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS SRFACE TO DRAW A SURFACE +C REPRESENTATION OF THE ARRAY VALUES, AND THEN +C PWRZS IS CALLED THREE TIMES TO LABEL THE +C FRONT, SIDE, AND BACK OF THE PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION Z(20,30) ,X(20) ,Y(30) ,MM(20,30,2), + 1 S(6) +C +C LOAD THE SRFACE COMMON BLOCK, NEEDED TO SURPRESS NEWFM CALL +C + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT , + 2 NCLA ,THETA ,HSKIRT ,CHI , + 3 CLO ,CINC ,ISPVAL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND +C TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C +C SPECIFY GRID LOOP INDICES, AND LINE OF SIGHT +C + DATA M/20/, N/30/ + DATA S/4.,5.,3.,0.,0.,0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C DEFINE FUNCTION VALUES AND STORE IN Z +C + DO 10 I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + 10 CONTINUE + DO 20 J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + 20 CONTINUE + DO 40 J=1,N + DO 30 I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + 30 CONTINUE + 40 CONTINUE +C +C SET SRFACE PARAMETERS TO SURPRESS FRAME CALL AND DRAW CONTOURS + call srfabd +C + IFR = 0 + IDRZ = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZS',2,0,0) +C +C DRAW SURFACE PLOT +C + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +C +C PUT PWRZS LABELS ON PICTURE +C + ISIZE = 35 + CALL PWRZS (0.,1.1,0.,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZS (1.1,0.,0.,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZS (0.,-1.1,.2,' BACK BACK BACK BACK BACK',25,ISIZE,-1, + 1 3,0) +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C +C RESTORE SRFACE PARAMETERS TO DEFAULT +C + IFR = 1 + IDRZ = 0 +C + RETURN +C +C +c1001 FORMAT (' PWRZS TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrztt.f b/sys/gio/ncarutil/tests/pwrztt.f new file mode 100644 index 00000000..dcf43638 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrztt.f @@ -0,0 +1,116 @@ + SUBROUTINE TPWRZT (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZT IN CONJUNCTION WITH THREED. +C +C USAGE CALL TPWRZT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZT TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C CHARACTER PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZT, THREED +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRZT CALLS SUBROUTINES SET3 AND LINE3 FROM +C THE ULIB THREED PACKAGE TO ESTABLISH THE +C THREE SPACE-TO-TWO SPACE TRANSFORMATION +C AND TO DRAW AXIS LINES. TPWRZT NEXT CALLS +C SUBROUTINE PWRZT FROM THE ULIB THREED +C PACKAGE TO LABEL THE AXES FOR A THREE SPACE +C PLOT. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C EYE CONTAINS THE (U,V,Z) COORDINATE OF THE EYE POSITION +C + REAL EYE(3) + DATA EYE(1), EYE(2), EYE(3) /3.5, 3.0, 5.0/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C SUBROUTINE SET3 ESTABLISHES THE MAPPING OF THREE SPACE COORDINATES +C ONTO THE GRAPHICS DEVICE COORDINATE SYSTEM. +C + CALL SET3 (.1,.9,.1,.9,0.,1.,0.,1.,0.,1.,EYE) +C +C THE FOLLOWING THREE CALLS TO LINE3 DRAW THE THREE SPACE AXES +C + CALL LINE3 (0.,0.,0.,0.,0.,1.) + CALL LINE3 (0.,0.,0.,0.,1.,0.) + CALL LINE3 (0.,0.,0.,1.,0.,0.) +C +C SUBROUTINE PWRZ IS USED TO LABEL EACH OF THE AXES AND THE PLOT +C ON INPUT TO PWRZ, +C THE FIRST THREE PARAMETERS AND ICNT DETERMINE THE POSITION OF THE +C CHARACTER STRING. +C ISIZE DETERMINES THE CHARACTER SIZE. +C LINE AND ITOP DETERMINE THE DIRECTION AND PLANE OF THE CHARACTERS. +C +C + ICNT = 0 + ISIZE = 30 + LINE = 2 + ITOP = 3 + CALL PWRZT (0.,.5,.1,'V-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = -1 + ITOP = 3 + CALL PWRZT (.5,0.,.1,'U-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 3 + ITOP = -2 + CALL PWRZT (0.,.1,.5,'Z-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 2 + ITOP = -1 + ISIZE = 30 + ICNT = -1 + CALL PWRZT (.5,.2,0.,'DEMONSTRATION OF PWRZT WITH THREED', + 1 34,ISIZE,LINE,ITOP,ICNT) +C +C A CALL TO NEWFM INDICATES THAT THE PICTURE IS COMPLETE +C + CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +C +C +c1001 FORMAT (' PWRZT TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srf.com b/sys/gio/ncarutil/tests/srf.com new file mode 100644 index 00000000..d1b4288c --- /dev/null +++ b/sys/gio/ncarutil/tests/srf.com @@ -0,0 +1,4 @@ +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval diff --git a/sys/gio/ncarutil/tests/srfacet.f b/sys/gio/ncarutil/tests/srfacet.f new file mode 100644 index 00000000..4e5bad00 --- /dev/null +++ b/sys/gio/ncarutil/tests/srfacet.f @@ -0,0 +1,150 @@ + SUBROUTINE TSRFAC (nplot, IERROR) +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SRFACE AND TO TEST SRFACE ON A SINGLE +C PROBLEM +C +C USAGE CALL TSRFAC (IERROR) +C +C ARGUMENTS +c +noao: additional input parameter +c nplot +c = 1, EZSRF is demonstrated +c = 2, SRFACE is demonstrated +c +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C SRFACE TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, TWO FRAMES CONTAINING THE +C SURFACE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE +C IF THE TEST WAS SUCCESSFUL, IT IS +C NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY FIRST WRITTEN IN APRIL 1979, CONVERTED TO +C FORTRAN 77 AND GKS IN MARCH 1984. +C +C ALGORITHM THE FUNCTION +C +C Z(X,Y) = .25*(X + Y + 1./((X-.1)**2+Y**2+.09) +C - 1./((X+.1)**2+Y**2+.09)) +C +C IS EVALUATED FOR +C X = -1. TO 1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO 1.2 IN INCREMENTS OF .1. +C TSRFAC CALLS SUBROUTINES EZSRFC AND SRFACE +C ONCE. EACH CALL PRODUCES A SURFACE PLOT +C OF THE ARRAY Z. +C +C PORTABILITY ANSI FORTRAN 77 +C +C XX CONTAINS THE X-DIRECTION COORDINATE VALUES FOR Z(X,Y), YY CONTAINS +C THE Y-DIRECTION COORDINATE VALUES FOR Z(X,Y), Z CONTAINS THE FUNCTION +C VALUES, S CONTAINS VALUES FOR THE LINE OF SIGHT FOR ENTRY SRFACE, +C WORK IS A WORK ARRAY, ANGH CONTAINS THE ANGLE IN DEGREES IN THE X-Y +C PLANE TO THE LINE OF SIGHT, ANGV CONTAINS THE ANGLE IN DEGREES FROM +C THE X-Y PLANE TO THE LINE OF SIGHT. +C + REAL XX(21) ,YY(25) ,Z(21,25) ,S(6) , + 1 WORK(1096) +C + DATA S(1), S(2), S(3), S(4), S(5), S(6)/ + 1 -8.0, -6.0, 3.0, 0.0, 0.0, 0.0/ +C + DATA ANGH/45./, ANGV/15./ +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0. TO 1., THE VALUES CX AND CY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA CX/.405/, CY/.97/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL XX AND YY COORDINATE ARRAYS AND Z FUNCTION VALUE ARRAY +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + XX(I) = X + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + YY(J) = Y + Z(I,J) = (X+Y+1./((X-.1)**2+Y**2+.09)- + 1 1./((X+.1)**2+Y**2+.09))*.25 + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C EZSRFC DEMO +C +C LABEL THE PLOT FOR ENTRY EZSRFC +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 1) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR EZSRFC ENTRY OF SRFACE') + CALL EZSRFC (Z,21,25,ANGH,ANGV,WORK) + endif +C +C +C SRFACE DEMO +C +C LABEL THE PLOT FOR ENTRY SRFACE +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 2) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR SRFACE ENTRY OF SRFACE') + CALL SRFACE (XX,YY,Z,WORK,21,21,25,S,0.) + endif +C +c WRITE (6,1001) +C + RETURN +C +C1001 FORMAT (' SRFACE TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srftest.x b/sys/gio/ncarutil/tests/srftest.x new file mode 100644 index 00000000..cf1496b7 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftest.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure srf_test() + +char temp[SZ_LINE] +real z[20,30], x[20], y[30], s[6] +int mm[20,30,2] +real tx, ty +int i, j, m, n, isize +real xt, yt, dum + +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval + +begin + # Some initialization that was originally in data statements: + tx = 0.4375 + ty = 0.9667 + m = 20 + n = 30 + s[1] = 4.0 + s[2] = 5.0 + s[3] = 3.0 + s[4] = 0.0 + s[5] = 0.0 + s[6] = 0.0 + + # Define function values and store in z + DO I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + + DO J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + + DO J=1,N { + DO I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + } + + # Initialize block data before changing parameters. + call srfabd + + IFR = 0 + IDRZ = 1 + + CALL GSELNT (0) + call f77pak ("DEMONSTRATION PLOT FOR PWRZS", temp, SZ_LINE) + CALL WTSTR (TX,TY,temp,2,0,0) + + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +# +# PUT PWRZS LABELS ON PICTURE +# + ISIZE = 35 + call f77pak ("FRONT", temp, SZ_LINE) + CALL PWRZS (0.,1.1,0.,temp,5,ISIZE,-1,3,0) + call f77pak ("SIDE", temp, SZ_LINE) + CALL PWRZS (1.1,0.,0.,temp,4,ISIZE,2,-1,0) + call f77pak (" BACK BACK BACK BACK BACK", temp, SZ_LINE) + CALL PWRZS (0.,-1.1,.2,temp,25,ISIZE,-1,3,0) +# +# RESTORE SRFACE PARAMETERS TO DEFAULT +# + IFR = 1 + IDRZ = 0 +end diff --git a/sys/gio/ncarutil/tests/srftestd.x b/sys/gio/ncarutil/tests/srftestd.x new file mode 100644 index 00000000..8c22ff92 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftestd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task srftest = t_srftest + +define DUMMY 6 + +# Rewrite of pwrzs.t.f in spp to check things out. + +procedure t_srftest() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call srf_test() + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmln.x b/sys/gio/ncarutil/tests/strmln.x new file mode 100644 index 00000000..2835d211 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmln.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine STRMLN + +procedure t_strmln() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tstrml (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmlnt.f b/sys/gio/ncarutil/tests/strmlnt.f new file mode 100644 index 00000000..f2b40c69 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmlnt.f @@ -0,0 +1,101 @@ + SUBROUTINE TSTRML (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ROUTINE STRMLN. +C +C USAGE CALL TSTRML (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE STRMLN. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C STRMLN THE MESSAGE +C STRMLN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM ROUTINE TSTRML CALLS ROUTINE STRMLN TO +C PRODUCE A PLOT REPRESENTING THE FLOW AND +C MAGNITUDE OF A VECTOR FIELD. +C +C PORTABILITY FORTRAN77 +C +C +C + REAL U(21,25) ,V(21,25) ,WRK(1050) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.5/,TY/.9765/ +C +C SET DIMENSIONS +C + DATA NH,NV/21,25/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY HORIZONTAL AND VERTICAL VECTOR COMPONENTS U AND V ON +C THE RECTANGULAR GRID +C + TPIMX = 2.*3.14/FLOAT(NH) + TPJMX = 2.*3.14/FLOAT(NV) + DO 20 J=1,NV + DO 10 I=1,NH + U(I,J) = SIN(TPIMX*(FLOAT(I)-1.)) + V(I,J) = SIN(TPJMX*(FLOAT(J)-1.)) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL WTSTR FOR STRMLN PLOT TITLE +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR ROUTINE STRMLN',2, + 1 0,0) +C +C DEFINE NORMALIZATION TRANSFORMATION 1, AND SET UP LOG SCALING +C + CALL GSVP ( 1, 0.1, 0.9, 0.1, 0.9 ) + CALL GSWN ( 1, 1.0, 21., 1.0, 25. ) + CALL SETUSV ( 'LS' , 1 ) +C +C SELECT NORMALIZATION TRANSFORMATION 1 +C + CALL GSELNT (1) +C +C DRAW PERIMETER +C +c CALL PERIM(1,0,1,0) +C +C CALL STRMLN FOR VECTOR FIELD STREAMLINES PLOT +C + CALL STRMLN (U,V,WRK,NH,NH,NV,0,IER) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' STRMLN TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/surface.x b/sys/gio/ncarutil/tests/surface.x new file mode 100644 index 00000000..07b25e9a --- /dev/null +++ b/sys/gio/ncarutil/tests/surface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routines SRFACE. + +procedure t_surface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (2, error_code) + if (error_code == 0) + call printf ("Test of SRFACE successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed.x b/sys/gio/ncarutil/tests/threed.x new file mode 100644 index 00000000..a22d51da --- /dev/null +++ b/sys/gio/ncarutil/tests/threed.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine THREED + +procedure t_threed() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tthree (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2.x b/sys/gio/ncarutil/tests/threed2.x new file mode 100644 index 00000000..224fd2c3 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routine THREED with extra test program tst3d2 + +procedure t_threed2() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tst3d2 () + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2t.f b/sys/gio/ncarutil/tests/threed2t.f new file mode 100644 index 00000000..baaa8f78 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2t.f @@ -0,0 +1,26 @@ + subroutine tst3d2 () + real eye(3) + dimension u(50), v(50), w(50) + data eye /5., -10., 4./ + isiz = 36 + xs = 90. / 1024. + xe = 1010. / 1024. + ys = 90. / 1024. + ye = 1010. / 1024. + call tick43 (24, 16, 24, 16, 24, 16) +c call set3 (90, 1010, 90, 1010, 0., 2., -1., 1., 0., 1., eye) + call set3 (xs, xe, ys, ye, 0., 2., -1., 1., 0., 1., eye) + do 1 i = 1, 50 + u(i) = float(i) * .04 + v(i) = sin (u(i) * 6.) * float (80 - i) / 80. + w(i) = .5 + sin (u(i) *3.141592) * .5 + 1 continue + call perim3 (2,5,1,5,1,0.) + call perim3 (2,5,1,5,2,-1.) + call perim3 (2,5,2,5,3,0.) + call pwrzt (2.1, -1., 0., 3hU->, 3, isiz, 1,3,-1) + call pwrzt (0., 1.1, 0., 3hV->, 3, isiz, 2,3,0) + call pwrzt (0., -1., 1.1, 2hW , 2, isiz, 3, -1, 0) + call fence3 (u, v, w, 50, 3, 0.) + end + diff --git a/sys/gio/ncarutil/tests/threedt.f b/sys/gio/ncarutil/tests/threedt.f new file mode 100644 index 00000000..0cb6532d --- /dev/null +++ b/sys/gio/ncarutil/tests/threedt.f @@ -0,0 +1,129 @@ + SUBROUTINE TTHREE (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ROUTINE THREED. +C +C USAGE CALL TTHREE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE THREED. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C THREED THE MESSAGE +C THREED TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C CONVERTED TO GKS AND FORTRAN 77 JULY 1984 +C +C ALGORITHM ROUTINE TTHREE CALLS SET3 TO ESTABLISH A +C MAPPING BETWEEN THE PLOTTER ADDRESSES AND +C THE USER'S VOLUME, AND TO INDICATE THE +C COORDINATES OF THE EYE POSITION FROM +C WHICH THE LINES TO BE DRAWN ARE VIEWED. +C NEXT, THE VOLUME PERIMETERS AND ASSOCIATED +C TICK MARKS ARE DRAWN BY CALLS TO PERIM3. +C THEN THE LINES ARE DRAWN. THESE ARE +C CERTAIN LATITUDES AND LONGITUDES OF A +C SPHERE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C + REAL EYE(3),X(31),Y(31),Z(31) +C +C SPECIFY ARGUMENT VALUES TO BE USED BY ROUTINE SET3. ON AN +C ABSTRACT PLOTTER WITH AN ADDRESS RANGE OF 0. TO 1. IN EACH +C COORDINATE DIRECTION, THE VALUES RXA, RXB, RYA, AND RYB +C DEFINE THE PORTION OF THE ADDRESS SPACE TO BE USED IN MAKING +C THE PLOT. UC, UD, VC, VD, WC, WD DEFINE A VOLUME IN USER +C COORDINATES WHICH IS TO BE MAPPED ONTO THE PORTION OF THE +C VIEWING SURFACE AS SPECIFIED BY RXA, RXB, RYA, AND RYB. +C + DATA RXA/0.097656/, RXB/0.90236/, RYA/0.097656/, RYB/0.90236/ + DATA UC/-1./, UD/1./, VC/-1./, VD/1./, WC/-1./, WD/1./ + DATA EYE(1),EYE(2),EYE(3)/10.,6.,3./ + DATA TX/0.4374/, TY/0.9570/ +C +C DEFINE PI + DATA PI/3.1415926535898/ +C +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL SET3 TO ESTABLISH A MAPPING BETWEEN THE PLOTTER ADDRESSES +C AND THE USER'S VOLUME, AND TO INDICATE THE COORDINATES OF THE +C EYE POSITION FROM WHICH THE LINES TO BE DRAWN ARE VIEWED. +C + CALL SET3(RXA,RXB,RYA,RYB,UC,UD,VC,VD,WC,WD,EYE) +C +C CALL PERIM3 TO DRAW PERIMETER LINES AND TICK MARKS +C + CALL PERIM3(2,5,1,10,1,-1.) + CALL PERIM3(4,2,1,1,2,-1.) + CALL PERIM3(2,10,4,5,3,-1.) +C +C DEFINE AND DRAW LATITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 10 J=1,18 + THETA = FLOAT(J)*PI/9. + CT = COS(THETA) + ST = SIN(THETA) + DO 20 K=1,31 + PHI = FLOAT(K-16)*PI/30. + Z(K) = SIN(PHI) + CP = COS(PHI) + X(K) = CT*CP + Y(K) = ST*CP + 20 CONTINUE + CALL CURVE3(X,Y,Z,31) + 10 CONTINUE +C +C DEFINE AND DRAW LONGITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 30 K=1,5 + PHI = FLOAT(K-3)*PI/6. + SP = SIN(PHI) + CP = COS(PHI) + DO 40 J=1,31 + TUETA = FLOAT(J-1)*PI/15. + X(J) = COS(TUETA)*CP + Y(J) = SIN(TUETA)*CP + Z(J) = SP + 40 CONTINUE + CALL CURVE3(X,Y,Z,31) + 30 CONTINUE +C +C CALL WTSTR FOR THREED PLOT TITLE +C + CALL WTSTR(TX,TY,'DEMONSTRATION PLOT FOR ROUTINE THREED',2,0,0) + call pwrzt (1.,0.,-1.,'DEMONSTRATION PLOT FOR ROUTINE THREED', 37, + * 2, 2, 3, 0) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE(6,1001) + RETURN +C +c1001 FORMAT(' THREED TEST SUCCESSFUL', 24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') + END diff --git a/sys/gio/ncarutil/tests/velvctt.f b/sys/gio/ncarutil/tests/velvctt.f new file mode 100644 index 00000000..36e22d28 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvctt.f @@ -0,0 +1,126 @@ + SUBROUTINE TVELVC (nplot, IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SUBROUTINES VELVCT AND EZVEC. +C +C USAGE CALL TVELVC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINES VELVCT AND EZVEC +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINES +C VELVCT AND EZVEC THE MESSAGE +C VELVCT TEST SUCCESSFUL . . . SEE PLOTS TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C +C ALGORITHM ROUTINE TVELVC CALLS ROUTINES EZVEC AND +C VELVCT ONCE. EACH CALL PRODUCES A PLOT +C REPRESENTING A VECTOR FIELD. THE VECTOR +C FIELD IS OBTAINED FROM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09), +C BY USING THE DIRECTION OF THE Z GRADIENT +C VECTORS AND THE LOGARITHM OF THE ABSOLUTE +C VALUE OF THE COMPONENTS. +C +C +C +C + DIMENSION U(21,25) ,V(21,25) +C +C SPECIFY COORDS FOR PLOT TITLES +C + DATA IX/94/,IY/1000/ +C +C SPECIFY SOME OF THE ARGUMENTS IN VELVCT CALLING SEQUENCE +C + DATA FLO/0./,HI/0./,NSET/0/,LENGTH/0/,ISPV/0/,SPV/0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY VELOCITY FIELD FUNCTIONS U AND V +C + M = 21 + N = 25 + DO 20 I=1,M + X = .1*FLOAT(I-11) + DO 10 J=1,N + Y = .1*FLOAT(J-13) + DZDX = 1.-2.*(X-.10)/((X-.10)**2+Y**2+.09)**2+ + 1 2.*(X+.10)/((X+.10)**2+Y**2+.09)**2 + DZDY = 1.-2.*Y/((X-.10)**2+Y**2+.09)**2+ + 1 2.*Y/((X+.10)**2+Y**2+.09)**2 + UVMAG = ALOG(SQRT(DZDX*DZDX+DZDY*DZDY)) + UVDIR = ATAN2(DZDY,DZDX) + U(I,J) = UVMAG*COS(UVDIR) + V(I,J) = UVMAG*SIN(UVDIR) + 10 CONTINUE + 20 CONTINUE +C +C CALL WTSTR FOR EZVEC PLOT TITLE +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 1) then + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y,'DEMONSTRATION PLOT FOR ENTRY EZVEC OF VELVCT', + 1 2,0,-1) + CALL GSELNT(ICN) +C +C CALL EZVEC FOR VELOCITY FIELD PLOT +C + CALL EZVEC (U,V,M,N) + endif +c -noao +C +C CALL VELVCT FOR VELOCITY FIELD PLOT +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 2) then + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C CALL WTSTR FOR VELVCT PLOT TITLE +C + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y, + 1 'DEMONSTRATION PLOT FOR ENTRY VELVCT OF VELVCT',2, + 2 0,-1) + CALL GSELNT(ICN) + endif +c -noao +c +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' VELVCT TEST SUCCESSFUL',24X, +c 1 'SEE PLOTS TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/velvect.x b/sys/gio/ncarutil/tests/velvect.x new file mode 100644 index 00000000..d09f1c08 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include <error.h> +include <gset.h> + +# Test NCAR routines VELVEC + +procedure t_velvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/x_ncartest.x b/sys/gio/ncarutil/tests/x_ncartest.x new file mode 100644 index 00000000..cc8b727f --- /dev/null +++ b/sys/gio/ncarutil/tests/x_ncartest.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# These tasks temporarily deleted: conraq = t_conraq, conras = t_conras, + #ezmapg = t_ezmapg, + +task conran = t_conran, + autograph = t_autograph, + oldauto = t_oldauto, + dashsmth = t_dashsmth, + pwrzs = t_przs, + srface = t_surface, + ezsrface = t_ezsurface, + conrec = t_conrec, + ezconrec = t_ezconrec, + hafton = t_hafton, + isosrf = t_isosrf, + ezisosrf = t_ezisos, + ezhafton = t_ezhafton, + pwrity = t_pwrity, + threed = t_threed, + threed2 = t_threed2, + velvec = t_velvect, + ezvelvec = t_ezvelvect, + strmln = t_strmln diff --git a/sys/gio/ncarutil/threbd.f b/sys/gio/ncarutil/threbd.f new file mode 100644 index 00000000..5dbce5e0 --- /dev/null +++ b/sys/gio/ncarutil/threbd.f @@ -0,0 +1,56 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data threbd changed to run time initialization + subroutine threbd +c BLOCKDATA THREBD + COMMON /TEMPR/ RZERO + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN, + 1 YMAX ,BIGD ,R0 ,NLX, + 2 NBY ,NRX ,NTY + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV, + 1 TMAGW ,TMINW + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c DATA RZERO/0./ + RZERO = 0. +c +c DATA NLX,NBY,NRX,NTY/10,10,1010,1010/ + NLX = 10 + NBY = 10 + NRX = 1010 + NTY = 1010 +c +c DATA TMAGU,TMINU,TMAGV,TMINV,TMAGW,TMINW/12.,8.,12.,8.,12.,8./ + TMAGU = 12. + TMINU = 8. + TMAGV = 12. + TMINV = 8. + TMAGW = 12. + TMINW = 8. +c +c DATA ITHRMJ,ITHRMN,ITHRTX/ 1,1,1/ + ITHRMJ = 2 + ITHRMN = 1 + ITHRTX = 1 +c +c -noao + END diff --git a/sys/gio/ncarutil/threed.f b/sys/gio/ncarutil/threed.f new file mode 100644 index 00000000..3b5061f4 --- /dev/null +++ b/sys/gio/ncarutil/threed.f @@ -0,0 +1,826 @@ + SUBROUTINE SET3 (XA,XB,YA,YB,ULO,UHI,VLO,VHI,WLO,WHI,EYE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C THREE-DIMENSIONAL LINE DRAWING PACKAGE +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE THREED IS A PACKAGE OF SUBROUTINES THAT +C PROVIDES LINE DRAWING CAPABILITIES IN +C THREE-SPACE. +C +C USAGE EACH ENTRY POINT IN THIS PACKAGE IS +C DESCRIBED BELOW. +C +C SET3 (XA,XB,YA,YB,UC,UD,VC,VD,WC,WD,EYE) +C +C XA, XB, YA, YB DEFINE THE PORTION OF THE +C PLOTTING SURFACE INTO WHICH THE USER'S +C PLOT WILL BE PLACED. THESE VALUES SHOULD +C BE IN THE RANGE 0. TO 1. FOR EXAMPLE, IF +C ONE WANTS THE PLOT TO OCCUPY THE MAXIMUM +C PLOTTING SURFACE, SET XA=0., YA=0., XB=1., +C YB=1.; IF ONE WANTS THE PLOT TO APPEAR IN +C THE LOWER LEFT CORNER OF THE PLOTTING +C SURFACE, SET XA=0., YA=0., XB=.5, YB=.5 . +C +C UC, UD, VC, VD, WC, AND WD DEFINE A +C VOLUME IN USER-COORDINATE SPACE WHICH +C WILL BE TRANSFORMED ONTO THE PLOTTING +C SURFACE DEFINED BY XA, XB, YA, YB. +C +C EYE IS AN ARRAY, 3 WORDS LONG, CONTAINING THE +C U, V, AND W COORDINATES OF THE EYE POSITION. +C ALL LINES IN THE PLOT ARE DRAWN AS VIEWED +C FROM THE EYE. EYE IS SPECIFIED IN USER +C COORDINATES AND SHOULD BE OUTSIDE THE BOX +C DEFINED BY UC, UD, VC, VC, WC, AND WD. +C +C CURVE3 (U,V,W,N) +C +C DRAWS A CURVE THROUGH N POINTS. THE +C POINTS ARE DEFINED BY THE LINEAR ARRAYS +C U, V, AND W WHICH ARE DIMENSIONED N OR +C GREATER. +C +C LINE3 (UA,VA,WA,UB,VB,WB) +C +C DRAWS A LINE CONNECTING THE COORDINATES +C (UA,VA,WA) AND (UB,VB,WB). +C +C FRST3 (U,V,W) +C +C POSITIONS THE PEN TO (U,V,W). +C +C VECT3 (U,V,W) +C +C DRAWS A LINE BETWEEN THE CURRENT PEN +C POSITION AND THE POINT (U,V,W). THE +C CURRENT PEN POSITION BECOMES (U,V,W). +C NOTE THAT A CURVE CAN BE DRAWN BY USING +C A FRST3 CALL FOLLOWED BY A SEQUENCE OF +C VECT3 CALLS. +C +C POINT3 (U,V,W) +C +C PLOTS A POINT AT (U,V,W) . +C +C PERIM3 (MAGR1,MINR1,MAGR2,MINR2,IWHICH,VAR) +C +C DRAWS A PERIMETER WITH TICK MARKS. +C +C IWHICH DESIGNATES THE NORMAL VECTOR TO THE +C PERIMETER DRAWN (1=U, 2=V, 3=W). +C +C VAR IS THE VALUE ON THE AXIS SPECIFIED BY +C INWHICH WHERE THE PERIMETER IS TO BE DRAWN. +C +C MAGR1 AND MAGR2 SPECIFY THE +C NUMBER OF MAJOR TICK MARKS TO BE DRAWN IN +C THE TWO COORDINATE DIRECTIONS. +C +C MINR1 AND MINR2 SPECIFY THE NUMBER +C OF MINOR TICKS BETWEEN EACH MAJOR TICK. +C +C MAGR1, MAGR2, MINR1 AND MINR2 +C ARE SPECIFIED BY THE NUMBER +C OF DIVISIONS(HOLES), NOT THE NUMBER OF +C TICKS. SO IF MAGR1=1, THERE WOULD BE NO +C MAJOR DIVISIONS. +C +C TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) +C +C TICK43 ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN SUBROUTINE PERIM3. +C MAGU, MAGV, MAGW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MAJOR +C DIVISION TICK MARKS ON THE U, V, AND W +C AXES. MINU, MINV, MINW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MINOR +C DIVISION TICK MARKS ON THE U, V, AND +C W AXES. +C +C FENCE3 (U,V,W,N,IOREN,BOT) +C +C THIS ENTRY IS USED TO DRAW A LINE IN THREE- +C SPACE AS WELL AS A "FENCE" BETWEEN THE +C LINE AND A PLANE NORMAL TO ONE OF THE +C COORDINATE AXES. +C +C THE ARGUMENTS U, V, W AND N +C ARE THE SAME AS FOR CURVE, DESCRIBED ABOVE. +C +C IOREN SPECIFIES THE DIRECTION IN WHICH THE +C FENCE LINES ARE TO BE DRAWN (1 INDICATES +C PARALLEL TO THE U-AXIS, 2 INDICATES PARALLEL +C TO THE V-AXIS, AND 3 INDICATES PARALLEL TO +C TO THE W-AXIS.) +C +C BOT SPECIFIES WHERE THE BOTTOM OF THE FENCE +C IS TO BE DRAWN. +C IF THE FENCE LINES ARE TO BE DRAWN PARALLEL +C TO THE W-AXIS, AND BOT=2., THEN THE BOTTOM +C OF THE FENCE WOULD BE THE PLANE W=2. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTES . FOR DRAWING CHARACTERS IN CONJUNCTION +C WITH THREED, USE THE COMPANION ROUTINE +C PWRZT. +C +C ENTRY POINTS FENCE3, TRN32T, FRST3, VECT3, LIN3, +C POINT3, CURVE3, PSYM3, PERIM3, LINE3W, +C DRAWT, TICK43, TICK3, THREBD +C +C COMMON BLOCKS TEMPR, SET31, PWRZ1T, TCK31, PRM31, THRINT +C +C REQUIRED LIBRARY PWRZ AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O PLOTS LINES. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ACCURACY + OR -.5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C +C + SAVE +C + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C ARITHMETIC STATEMENT FUNCTION FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata threbd rewritten as run time initialization. +C +C EXTERNAL THREBD + call threbd +C -NOAO +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','SET3','VERSION 1') +C +C SET UP FRAME SIZE +C + NLX = XA*1023.+1. + NRX = XB*1023.+1. + NBY = YA*1023.+1. + NTY = YB*1023.+1. +C +C CONSTANTS FOR PWRZT +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELATIVE SIZE FEATURE IN USE. THIS SECTION OF CODE IS NEVER +C EXECUTED UNLESS RZERO IS SET POSITIVE IN THE CALLING PROGRAM +C VIA COMMON BLOCK TEMPR. RZERO IS THE DISTANCE BETWEEN THE +C OBSERVER AND THE POINT LOOKED AT (CENTER OF THE BOX BY DEFAULT) +C WHEN THE INPUT BOX IS TO FILL THE SCREEN WHEN VIEWED FROM THE +C DIRECTION WHICH MAKES THE BOX BIGGEST. RZERO IS THUS TO +C BE USED TO DETERMINE THE SHAPE OF THE OBJECT. THIS SECTION +C OF CODE IS TO BE USED WHEN IT IS DESIRED TO KEEP THE VIEWED +C OBJECT IN RELATIVE PERSPECTIVE ACROSS FRAMES--E.G. IN MAKING +C MOVIES. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32T (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32T (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32T (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32T (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C TRN32T ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C +C + SAVE +C + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 +C +C STORE THE PARAMETERS OF THE SET CALL +C FOR USE WITH THE TRANSLATION CALL +C + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D + AL = ACOS(COSAL) + BE = ACOS(COSBE) + GA = ACOS(COSGA) + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = X1+X3*(FACT*UU-X0) + YT = Y1+Y3*(FACT*VV-Y0) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE FRST3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FRST3','VERSION 1') + XDUM = 5. + CALL TRN32T (U,V,W,X,Y,XDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + RETURN + END + SUBROUTINE VECT3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','VECT3','VERSION 1') + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + IIX = 32*IFIX(X) + IIY = 32*IFIX(Y) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE LINE3 (UA,VA,WA,UB,VB,WB) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','LINE3','VERSION 1') + CALL TRN32T (UA,VA,WA,XA,YA,XDUM,2) + CALL TRN32T (UB,VB,WB,XB,YB,XDUM,2) + IIX = 32*IFIX(XB) + IIY = 32*IFIX(YB) + CALL PLOTIT (32*IFIX(XA),32*IFIX(YA),0) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE POINT3 (U,V,W) + SAVE + DIMENSION VWPRT(4),WNDW(4) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','POINT3','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND CURRENT LOG SCALING +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV ('LS',IOLLS) +C +C DEFINE NOMALIZATION TRANS TO BE USED WITH POLYMARKER +C + CALL SET(0.0, 1.0, 0.0, 1.0, 1.0, 1024.0, 1.0, 1024.0, 1) +C +C SET MARKER TYPE TO 1 +C + CALL GSMK (1) + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + PX = X + PY = Y + CALL GPM (1,PX,PY) +C +C RESTORE ORIGINAL TRANS 1 AND SELECT TRANS NUMBER NTORIG +C RESTORE LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE CURVE3 (U,V,W,N) + SAVE + DIMENSION U(N) ,V(N) ,W(N) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','CURVE3','VERSION 1') + CALL TRN32T (U(1),V(1),W(1),X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + NN = N + IF (NN .LT. 2) RETURN + DO 10 I=2,NN + UU = U(I) + VV = V(I) + WW = W(I) + CALL TRN32T (UU,VV,WW,X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),1) + 10 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PSYM3 (U,V,W,ICHAR,SIZE,IDIR,ITOP,IUP) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PSYM3','VERSION 1') + IF (IUP .EQ. 2) CALL VECT3 (U,V,W) + CALL PWRZ (U,V,W,ICHAR,1,SIZE,IDIR,ITOP,0) + RETURN + END + SUBROUTINE PERIM3 (MAGR1,MINI1,MAGR2,MINI2,IWHICH,VAR) + SAVE + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /PRM31/ Q ,L + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THRINT COMMON BLOCK IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX + DIMENSION LASF(13) +C + TICK(T) = AMAX1(UUMAX-UUMIN,VVMAX-VVMIN,WWMAX-WWMIN)*T/1024. +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PERIM3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + MGR1 = MAGR1 + MN1 = MINI1-1 + MGR2 = MAGR2 + MN2 = MINI2-1 + MN1P1 = MAX0(MN1+1,1) + MN2P1 = MAX0(MN2+1,1) + L = MIN0(3,MAX0(1,IWHICH)) + Q = VAR +C +C PICK BOUNDS +C + GO TO ( 10, 30, 40),L + 10 XMIN = VVMIN + XMAX = VVMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + 20 YMIN = WWMIN + YMAX = WWMAX + DELYL = TICK(TMAGW) + DELYS = TICK(TMINW) + GO TO 50 + 30 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + GO TO 20 + 40 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + YMIN = VVMIN + YMAX = VVMAX + DELYL = TICK(TMAGV) + DELYS = TICK(TMINV) +C +C PERIM +C + 50 CALL LINE3W (XMIN,YMIN,XMAX,YMIN) + CALL LINE3W (XMAX,YMIN,XMAX,YMAX) + CALL LINE3W (XMAX,YMAX,XMIN,YMAX) + CALL LINE3W (XMIN,YMAX,XMIN,YMIN) + IF (MGR1 .LT. 1) GO TO 90 + DX = (XMAX-XMIN)/AMAX0(MGR1*(MN1P1),1) + DO 80 I=1,MGR1 +C +C MINORS FIRST +C + IF (MN1 .LE. 0) GO TO 70 +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + DO 60 J=1,MN1 + X = XMIN+FLOAT(MN1P1*(I-1)+J)*DX + CALL LINE3W (X,YMIN,X,YMIN+DELYS) + CALL LINE3W (X,YMAX,X,YMAX-DELYS) + 60 CONTINUE + 70 IF (I .GE. MGR1) GO TO 90 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + X = XMIN+FLOAT(MN1P1*I)*DX +C +C MAJORS +C + CALL LINE3W (X,YMIN,X,YMIN+DELYL) + CALL LINE3W (X,YMAX,X,YMAX-DELYL) + 80 CONTINUE + 90 IF (MGR2 .LT. 1) GO TO 130 + DY = (YMAX-YMIN)/AMAX0(MGR2*(MN2P1),1) + DO 120 J=1,MGR2 + IF (MN2 .LE. 0) GO TO 110 + DO 100 I=1,MN2 + Y = YMIN+FLOAT(MN2P1*(J-1)+I)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXS,Y) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + CALL LINE3W (XMAX,Y,XMAX-DELXS,Y) + 100 CONTINUE + 110 IF (J .GE. MGR2) GO TO 130 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + Y = YMIN+FLOAT(MN2P1*J)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXL,Y) + CALL LINE3W (XMAX,Y,XMAX-DELXL,Y) + 120 CONTINUE +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + 130 LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) + RETURN + END + SUBROUTINE LINE3W (XA,YA,XB,YB) + SAVE + COMMON /PRM31/ Q ,L + GO TO ( 10, 30, 40),L + 10 UA = Q + UB = Q + VA = XA + VB = XB + 20 WA = YA + WB = YB + GO TO 50 + 30 UA = XA + UB = XB + VA = Q + VB = Q + GO TO 20 + 40 UA = XA + UB = XB + VA = YA + VB = YB + WA = Q + WB = Q + 50 CALL LINE3 (UA,VA,WA,UB,VB,WB) + RETURN + END + SUBROUTINE DRAWT (IXA,IYA,IXB,IYB) + SAVE + CALL PLOTIT(32*IXA,32*IYA,0) + IIX = 32*IXB + IIY = 32*IYB + CALL PLOTIT(IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(IIX,IIY,0) + RETURN + END + SUBROUTINE TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) + SAVE + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK43','VERSION 1') + TMAGU = MAGU + TMINU = MINU + TMAGV = MAGV + TMINV = MINV + TMAGW = MAGW + TMINW = MINW + RETURN + END + SUBROUTINE TICK3 (MAG,MIN) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK3','VERSION 1') + CALL TICK43 (MAG,MIN,MAG,MIN,MAG,MIN) + RETURN + END + SUBROUTINE FENCE3 (U,V,W,N,IOR,BOT) + SAVE + REAL U(N) ,V(N) ,W(N) + DIMENSION LASF(13) +C +C COMMON BLOCK THRINT IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FENCE3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + M = N + BASE = BOT + L = MAX0(1,MIN0(3,IOR)) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + GO TO ( 10, 40, 70),L + 10 CALL FRST3 (BASE,V(1),W(1)) + DO 20 I=2,M + VV = V(I) + WW = W(I) + CALL VECT3 (BASE,VV,WW) + 20 CONTINUE + DO 30 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,BASE,VV,WW) + 30 CONTINUE + GO TO 100 + 40 CALL FRST3 (U(1),BASE,W(1)) + DO 50 I=2,M + UU = U(I) + WW = W(I) + CALL VECT3 (UU,BASE,WW) + 50 CONTINUE + DO 60 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,BASE,WW) + 60 CONTINUE + GO TO 100 + 70 CALL FRST3 (U(1),V(1),BASE) + DO 80 I=2,M + UU = U(I) + VV = V(I) + CALL VECT3 (UU,VV,BASE) + 80 CONTINUE + DO 90 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,VV,BASE) + 90 CONTINUE +C +C SET LINE INTENSITY TO HIGH +C + 100 CALL GSPLCI (ITHRMJ) + CALL CURVE3 (U,V,W,M) +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) +C + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C FEBURARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C JUNE 1979 UPDATED FILE TO INCLUDE BLOCK DATA PWRZBD AND +C CORRECT A COMMENTED OUT STATEMENT IN CURVE3. +C MARCH 1980 REMOVED THE PWRZ AND PWRITZ ENTRIES. THESE +C CAPABILITIES WERE REPLACED WITH THE NEW ULIB FILE +C PWRZT. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- +C + END + SUBROUTINE PWRZ (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C WRITE (6,1001) +C WRITE (6,1002) +C STOP +C +C1001 FORMAT (1H1//////////) +C1002 FORMAT (' *****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRZ IS NO LONGER *'/ +C 4 ' * SUPPORTED. THE CAPABILITIES OF *'/ +C 5 ' * THIS OLD ENTRY ARE NOW AVAILABLE *'/ +C 6 ' * IN THE NEW PORTABLE VERSIONS *'/ +C 7 ' * *'/ +C 8 ' * PWRZS FOR USE WITH SRFACE *'/ +C 9 ' * PWRZI FOR USE WITH ISOSRF *'/ +C + ' * PWRZT FOR USE WITH THREED *'/ +C 1 ' * *'/ +C 2 ' * FOR USAGE OF THESE ROUTINES, SEE *'/ +C 3 ' * THE DOCUMENTATION FOR THE DESIRED *'/ +C 4 ' * ROUTINE. *'/ +C 5 ' * *'/ +C 6 ' * *'/ +C 7 ' *****************************************') +C + END diff --git a/sys/gio/ncarutil/veldat.f b/sys/gio/ncarutil/veldat.f new file mode 100644 index 00000000..9baef78d --- /dev/null +++ b/sys/gio/ncarutil/veldat.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data veldat changed to run time initialization +c BLOCK DATA VELDAT + subroutine veldat +C +C THIS 'ROUTINE' DEFINES THE DEFAULT VALUES OF THE VELVCT PARAMETERS. +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB, + + IOFFD ,IOFFM ,ISX ,ISY, + + RMN ,RMX ,SIDE ,SIZE, + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +c DATA EXT / 0.25 / +c DATA ICTRFG / 1 / +c DATA ILAB / 0 / +c DATA IOFFD / 0 / +c DATA IOFFM / 0 / +c DATA RMN / 160.00 / +c DATA RMX / 6400.00 / +c DATA SIDE / 0.90 / +c DATA SIZE / 256.00 / +c DATA XLT / 0.05 / +c DATA YBT / 0.05 / +c DATA ZMX / 0.00 / +c DATA INCX / 1 / +c DATA INCY / 1 / +c +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + + EXT = 0.25 + ICTRFG = 1 + ILAB = 0 + IOFFD = 0 + IOFFM = 0 + RMN = 160.00 + RMX = 6400.00 + SIDE = 0.90 + SIZE = 256.00 + XLT = 0.05 + YBT = 0.05 + ZMX = 0.00 + INCX = 1 + INCY = 1 +C +c - noao + END diff --git a/sys/gio/ncarutil/velvct.f b/sys/gio/ncarutil/velvct.f new file mode 100644 index 00000000..fd8f46c7 --- /dev/null +++ b/sys/gio/ncarutil/velvct.f @@ -0,0 +1,821 @@ + SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +C DIMENSION OF U(LU,N),V(LV,N),SPV(2) +C ARGUMENTS +C +C LATEST REVISION JULY 1984 +C +C PURPOSE VELVCT DRAWS A REPRESENTATION OF A TWO- +C DIMENSIONAL VELOCITY FIELD BY DRAWING ARROWS +C FROM EACH DATA LOCATION. THE LENGTH OF THE +C ARROW IS PROPORTIONAL TO THE STRENGTH OF THE +C FIELD AT THAT LOCATION AND THE DIRECTION OF +C THE ARROW INDICATES THE DIRECTION OF THE FLOW +C AT THAT LOCATION. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZVEC (U,V,M,N) +C +C ASSUMPTIONS - +C +C --THE WHOLE ARRAY IS PROCESSED. +C --THE SCALE FACTOR IS CHOSEN INTERNALLY. +C --THE PERIMETER IS DRAWN. +C --FRAME IS CALLED AFTER PLOTTING. +C --THERE ARE NO SPECIAL VALUES. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL VELVCT (U,LU,V,LV,M,N,FLO,HI, +C NSET,LENGTH,ISPV,SPV) +C +C ARGUMENTS +C +C ON INPUT U,V +C +C THE (ORIGINS OF THE) TWO-DIMENSIONAL ARRAYS +C CONTAINING THE VELOCITY FIELD TO BE PLOTTED. +C THE VECTOR AT THE POINT (I,J) HAS MAGNITUDE +C SQRT(U(I,J)**2+V(I,J)**2) AND DIRECTION +C ATAN2(V(I,J),U(I,J)). OTHER REPRESENTATIONS, +C SUCH AS (R,THETA), CAN BE PLOTTED BY +C CHANGING STATEMENT FUNCTIONS IN THIS ROUTINE. +C +C LU +C +C THE FIRST DIMENSION OF U IN THE CALLING +C PROGRAM. +C +C LV +C +C THE FIRST DIMENSION OF V IN THE CALLING +C PROGRAM. +C +C M +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING THE ENTIRE ARRAY, +C LU = LV = M. +C +C N +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C +C THE MINIMUM VECTOR MAGNITUDE TO BE SHOWN. +C +C HI +C +C THE MAXIMUM VECTOR MAGNITUDE TO BE SHOWN. (A +C VALUE LESS THAN OR EQUAL TO ZERO CAUSES THE +C MAXIMUM VALUE OF SQRT(U**2+V**2) TO BE USED.) +C +C NSET +C +C FLAG TO CONTROL SCALING - +C +C IF NSET IS ZERO, VELVCT ESTABLISHES THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW A +C BORDER. +C +C IF NSET IS GREATER THAN ZERO, VELVCT ASSUMES +C THAT THE USER HAS ESTABLISHED THE WINDOW +C AND VIEWPORT IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS GENERATED +C BY VELVCT. PERIM IS NOT CALLED. +C +C IF NSET IS LESS THAN ZERO, VELVCT +C PLACES THE CONTOUR PLOT +C WITHIN THE LIMITS OF THE USER'S CURRENT +C WINDOW AND VIEWPORT. PERIM IS NOT CALLED. +C +C LENGTH +C +C THE LENGTH, IN PLOTTER ADDRESS UNITS (PAUS), +C OF A VECTOR HAVING MAGNITUDE HI +C (OR, IF HI=0, THE LENGTH IN PAUS +C OF THE LONGEST VECTOR). IF LENGTH=0, A +C VALUE IS CHOSEN SUCH THAT THE LONGEST VECTOR +C COULD JUST REACH TO THE TAIL OF THE NEXT +C VECTOR. IF THE HORIZONTAL AND VERTICAL +C RESOLUTIONS OF THE PLOTTER ARE DIFFERENT, +C LENGTH SHOULD BE NON-ZERO AND SPECIFIED AS A +C HORIZONTAL DISTANCE. +C +C ISPV +C +C FLAG TO CONTROL THE SPECIAL VALUE FEATURE. +C +C 0 MEANS THAT THE FEATURE IS NOT IN USE. +C +C 1 MEANS THAT IF THE VALUE OF +C U(I,J)=SPV(1) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 2 MEANS THAT IF THE VALUE OF +C V(I,J)=SPV(2) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 3 MEANS THAT IF EITHER U(I,J)=SPV(1) OR +C V(I,J)=SPV(2) THEN THE VECTOR WILL NOT +C BE PLOTTED. +C +C 4 MEANS THAT IF U(I,J)=SPV(1) +C AND V(I,J)=SPV(2), THE VECTOR +C WILL NOT BE PLOTTED. +C +C SPV +C +C AN ARRAY OF LENGTH 2 WHICH GIVES THE VALUE +C IN THE U ARRAY AND THE VALUE IN THE V ARRAY +C WHICH DENOTE MISSING VALUES. +C THIS ARGUMENT IS IGNORED IF ISPV=0. +C +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED. +C +C NOTE THE ENDPOINTS OF EACH ARROW DRAWN ARE (FX(X,Y), +C FY(X,Y)) AND (MXF(X,Y,U,V,SFX,SFY,MX,MY), +C MYF(X,Y,U,V,SFX,SFY,MX,MY)) WHERE X=I, Y=J, +C U=U(I,J), V=V(I,J), AND SFX AND SFY ARE SCALE +C FACTORS. HERE I IS THE X-INDEX AND J IS THE +C Y-INDEX. (MX,MY) IS THE LOCATION OF THE TAIL. +C THUS THE ACTUAL LENGTH OF THE ARROW IS +C SQRT(DX**2+DY**2) AND THE DIRECTION IS +C ATAN2(DX,DY), WHERE DX=MX-MXF(...) AND +C DY=MY-MYF(...). +C +C ENTRY POINTS VELVCT,EZVECT,DRWVEC,VELVEC,VELDAT +C +C COMMON BLOCKS VEC1,VEC2 +C +C I/O PLOTS THE VECTOR FIELD. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C REQUIRED LIBRARY GRIDAL AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C REVISED IN MAY, 1975, TO INCLUDE MXF AND MYF. +C REVISED IN MARCH, 1981, TO FIX CERTAIN ERRORS; +C TO USE FL2INT AND PLOTIT INSTEAD OF MXMY, +C FRSTPT, AND VECTOR; AND TO MAKE THE ARROWHEADS +C NARROWER. CONVERTED TO FORTRAN77 AND GKS +C IN JULY 1984. +C +C ALGORITHM EACH VECTOR IS EXAMINED, POSSIBLY TRANSFORMED, +C THEN PLOTTED. +C +C PORTABILITY FORTRAN77 +C +C --------------------------------------------------------------------- +C +C SPECIAL NOTE - +C +C USING THIS ROUTINE TO PUT VECTORS ON AN ARBITRARY BACKGROUND DRAWN BY +C SUPMAP IS A BIT TRICKY. THE ARITHMETIC STATEMENT FUNCTIONS FX AND FY +C ARE EASY TO REPLACE. THE PROBLEM ARISES IN REPLACING MXF AND MYF. +C THE FOLLOWING EXAMPLE MAY BE HELPFUL. (SUPMAP IS AN ENTRY POINT IN +C THE EZMAP PACKAGE.) +C +C SUPPOSE THAT WE HAVE TWO ARRAYS, CLON(36,9) AND CLAT(36,9), WHICH +C CONTAIN THE E-W AND N-S COMPONENTS OF A WIND FLOW FIELD ON THE SURFACE +C OF THE EARTH. CLON(I,J) IS THE MAGNITUDE OF THE EASTERLY FLOW. +C CLAT(I,J) IS THE MAGNITUDE OF THE NORTHERLY FLOW AT A LONGITUDE (I-1) +C *10 DEGREES EAST OF GREENWICH AND A LATITUDE (J-1)*10 DEGREES NORTH OF +C THE EQUATOR. SUPMAP IS TO BE USED TO DRAW A POLAR PROJECTION OF THE +C EARTH AND VELVCT IS TO BE USED TO SUPERIMPOSE VECTORS REPRESENTING THE +C FLOW FIELD ON IT. THE FOLLOWING STEPS WOULD BE NECESSARY: +C +C 1. CALL SUPMAP (1,90.,0.,-90.,90.,90.,90.,90.,-4,10,0,1,IER) +C TO DRAW THE MAP. +C +C 2. CALL VELVCT (CLON,36,CLAT,36,36,9,0.,0.,1,50,0,0.) TO PUT +C VECTORS ON IT. NOTICE THAT NSET HAS THE VALUE 1 TO TELL +C VELVCT THAT SUPMAP HAS DONE THE REQUIRED SET CALL. +C +C 3. IN ORDER TO ENSURE THAT STEP 2 WILL WORK PROPERLY, DELETE +C THE ARITHMETIC STATEMENT FUNCTIONS FX, FY, MXF, AND MYF +C FROM VELVCT AND INCLUDE THE FOLLOWING FUNCTIONS. +C +C FUNCTION FX(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FX=X +C RETURN +C END +C +C FUNCTION FY(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FY=Y +C RETURN +C END +C +C FUNCTION MXF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C U=((X2-X1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MXF=MX+IFIX(SFX*U) +C RETURN +C END +C +C FUNCTION MYF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C V=((Y2-Y1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MYF=MY+IFIX(SFY*V) +C RETURN +C END +C +C THE BASIC NOTION BEHIND THE CODING OF THE MXF AND MYF FUNCTIONS IS AS +C FOLLOWS. SINCE UU AND VV ARE THE LONGITUDINAL AND LATITUDINAL COMPONENTS, +C RESPECTIVELY, OF A VELOCITY VECTOR HAVING UNITS OF DISTANCE OVER TIME, +C 1.E-6*UU/COS(LATITUDE) AND 1.E-6*VV REPRESENT THE CHANGE IN LONGITUDE +C AND LATITUDE, RESPECTIVELY, OF A PARTICLE MOVING WITH THE FLOW FIELD +C FOR A VERY SHORT PERIOD OF TIME. THE ROUTINE MAPTRN IS USED TO FIND +C THE POSITION OF THE PARTICLE'S PROJECTION AT THE BEGINNING AND END OF +C THAT TINY TIME SLICE AND, THEREFORE, THE DIRECTION IN WHICH TO DRAW +C THE ARROW REPRESENTING THE VELOCITY VECTOR SO THAT IT WILL BE TANGENT +C TO A PROJECTED FLOW LINE OF THE FIELD AT THAT POINT. THE VALUES U +C AND V ARE COMPUTED SO AS TO GIVE THE ARROW THE LENGTH IMPLIED BY UU +C AND VV. (THE CODE ENSURES THAT SQRT(U**2+V**2) IS EQUAL TO +C SQRT(UU**2+VV**2).) THE LENGTH OF THE ARROW REPRESENTS THE MAGNITUDE +C OF THE VELOCITY VECTOR, UNAFFECTED BY PERSPECTIVE. THE SCALING SET +C UP BY VELVCT WILL THEREFORE BE APPROPRIATE FOR THE ARROWS DRAWN. +C +C THIS METHOD IS RATHER HEURISTIC AND HAS THREE INHERENT PROBLEMS. +C FIRST, THE CONSTANT 1.E-6 MAY NEED TO BE MADE LARGER OR SMALLER, +C DEPENDING ON THE MAGNITUDE OF YOUR U/V DATA. SECOND, THE NORTH AND +C SOUTH POLES MUST BE AVOIDED. AT EITHER POLE, CFCT GOES TO ZERO, +C GIVING A DIVISION BY ZERO; IN A SMALL REGION NEAR THE POLE, THE +C METHOD MAY TRY TO USE MAPTRN WITH A LATITUDE OUTSIDE THE RANGE +C (-90,+90). THIRD, THE PROJECTION MUST BE SET UP SO AS TO AVOID +C HAVING VECTOR BASEPOINTS AT THE EXACT EDGE OF THE MAP. VECTORS +C THERE WILL BE OF THE CORRECT LENGTH, BUT THEY MAY BE DRAWN IN THE +C WRONG DIRECTION (WHEN THE PROJECTED PARTICLE TRACK DETERMINING THE +C DIRECTION CROSSES THE EDGE AND REAPPEARS ELSEWHERE ON THE MAP). +C WITH A LITTLE CARE, THE DESIRED RESULTS MAY BE OBTAINED. +C --------------------------------------------------------------------- +C +C DECLARATIONS - +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +C ARGUMENT DIMENSIONS. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) + CHARACTER*10 LABEL + REAL WIND(4), VIEW(4), IAR(4) +C +C --------------------------------------------------------------------- +C +C INTERNAL PARAMETERS OF VELVCT ARE AS FOLLOWS. THE DEFAULT VALUES OF +C THESE PARAMETERS ARE DECLARED IN THE BLOCK DATA ROUTINE VELDAT. +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C BIG R1MACH(2) CONSTANT USED TO INITIALIZE +C POSSIBLE SEARCH FOR HI. +C +C EXT 0.25 THE LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M AND +C N WHEN NSET IS LESS THAN OR +C EQUAL TO ZERO, EXCEPT WHEN +C MIN(M,N)/MAX(M,N) IS LESS THAN +C EXT, IN WHICH CASE A SQUARE +C GRAPH IS PLOTTED. +C +C ICTRFG 1 FLAG TO CONTROL THE POSITION OF +C THE ARROW RELATIVE TO A BASE +C POINT AT (MX,MY). +C +C ZERO - CENTER AT (MX,MY) +C +C POSITIVE - TAIL AT (MX,MY) +C +C NEGATIVE - HEAD AT (MX,MY) +C +C ILAB 0 FLAG TO CONTROL THE DRAWING OF +C LINE LABELS. +C +C ZERO - DO NOT DRAW THE LABELS +C +C NON-ZERO - DRAW THE LABELS +C +C INCX 1 X-COORDINATE STEP SIZE FOR LESS +C DENSE ARRAYS. +C +C INCY 1 Y-COORDINATE STEP SIZE. +C +C IOFFD 0 FLAG TO CONTROL NORMALIZATION +C OF LABEL NUMBERS. +C +C ZERO - INCLUDE A DECIMAL POINT +C WHEN POSSIBLE +C +C NON-ZERO - NORMALIZE ALL LABEL +C NUMBERS BY ASH +C +C IOFFM 0 FLAG TO CONTROL PLOTTING OF +C THE MESSAGE BELOW THE PLOT. +C +C ZERO - PLOT THE MESSAGE +C +C NON-ZERO - DO NOT PLOT IT +C +C RMN 160. ARROW SIZE BELOW WHICH THE +C HEAD NO LONGER SHRINKS, ON A +C 2**15 X 2**15 GRID. +C +C RMX 6400. ARROW SIZE ABOVE WHICH THE +C HEAD NO LONGER GROWS LARGER, +C ON A 2**15 X 2**15 GRID. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF PLOT. +C (SEE ALSO EXT.) +C +C SIZE 256. WIDTH OF THE CHARACTERS IN +C VECTOR LABELS, ON A 2**15 X +C 2**15 GRID. +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0 IS THE LEFT EDGE OF THE +C FRAME, 1 THE RIGHT EDGE.) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT (0 IS +C THE BOTTOM OF THE FRAME, 1 THE +C TOP OF THE FRAME.) +C +C --------------------------------------------------------------------- +C +C INTERNAL FUNCTIONS WHICH MAY BE MODIFIED FOR DATA TRANSFORMATION - +C +C SCALE COMPUTES A SCALE FACTOR USED IN THE +C DETERMINATION OF THE LENGTH OF THE +C VECTOR TO BE DRAWN. +C +C DIST COMPUTES THE LENGTH OF A VECTOR. +C +C FX RETURNS THE X INDEX AS THE +C X-COORDINATE OF THE VECTOR BASE. +C +C MXF RETURNS THE X-COORDINATE OF THE VECTOR +C HEAD. +C +C FY RETURNS THE Y INDEX AS THE +C Y-COORDINATE OF THE VECTOR BASE. +C +C MYF RETURNS THE Y-COORDINATE OF THE VECTOR +C HEAD. +C +C VLAB THE VALUE FOR THE VECTOR LABEL WHEN +C ILAB IS NON-ZERO. +C + SAVE + DIST(XX,YY) = SQRT(XX*XX+YY*YY) + FX(XX,YY) = XX + FY(XX,YY) = YY + MXF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MXX+IFIX(SFXX*UU) + MYF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MYY+IFIX(SFYY*VV) + SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = LENN/HAA + SCALEY(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3, + 2 XX4,YY3,YY4,LENN) + VLAB(UU,VV,II,JJ) = DIST(UU,VV) +C +C FORCE THE BLOCK DATA ROUTINE, WHICH SETS DEFAULT VARIABLES, TO LOAD. +C +NOAO - blockdata replaced with run time initialization. +C +C EXTERNAL VELDAT + call veldat +C -NOAO +C +C --------------------------------------------------------------------- +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('NSSL','VELVCT','VELVCT','VERSION 6') +C +C INITIALIZE AND TRANSFER SOME ARGUMENTS TO LOCAL VARIABLES. +C + BIG = -R1MACH(2) + MX = LU + MY = LV + NX = M + NY = N + GL = FLO + HA = HI + ISP = ISPV + NC = 0 +C +C COMPUTE CONSTANTS BASED ON THE ADDRESSABILITY OF THE PLOTTER. +C + CALL GETUSV('XF',ISX) + CALL GETUSV('YF',ISY) + ISX = 2**(15-ISX) + ISY = 2**(15-ISY) + LEN = LENGTH*ISX +C +C SET UP THE SCALING OF THE PLOT. +C + CALL GQCNTN(IERR,IOLDNT) + CALL GQNT(IOLDNT,IERR,WIND,VIEW) + X1 = VIEW(1) + X2 = VIEW(2) + Y1 = VIEW(3) + Y2 = VIEW(4) + X3 = WIND(1) + X4 = WIND(2) + Y3 = WIND(3) + Y4 = WIND(4) + CALL GETUSV('LS',IOLLS) +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT(1,IERR,WIND,VIEW) +C + IF (NSET) 101,102,106 +C + 101 X3 = 1. + X4 = FLOAT(NX) + Y3 = 1. + Y4 = FLOAT(NY) + GO TO 105 +C + 102 X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = 1. + Y3 = 1. + X4 = FLOAT(NX) + Y4 = FLOAT(NY) + IF (AMIN1(X4,Y4)/AMAX1(X4,Y4) .LT. EXT) GO TO 105 +C + IF (NX-NY) 103,105,104 + 103 X2 = XLT+SIDE*X4/Y4 + GO TO 105 + 104 Y2 = YBT+SIDE*Y4/X4 +C + 105 CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,1) + IF (NSET .EQ. 0) CALL PERIM (1,0,1,0) +C +C CALCULATE A LENGTH IF NONE PROVIDED. +C + 106 IF (LEN .NE. 0) GO TO 107 + CALL FL2INT(FX(1.,1.),FY(1.,1.),MX,MY) + CALL FL2INT(FX(FLOAT(1+INCX),FLOAT(1+INCY)), + + FY(FLOAT(1+INCX),FLOAT(1+INCY)),LX,LY) + LEN = SQRT((FLOAT(MX-LX)**2+FLOAT(MY-LY)**2)/2.) +C +C SET UP SPECIAL VALUES. +C + 107 IF (ISP .EQ. 0) GO TO 108 + SPV1 = SPV(1) + SPV2 = SPV(2) + IF (ISP .EQ. 4) SPV2 = SPV(1) +C +C FIND THE MAXIMUM VECTOR LENGTH. +C + 108 IF (HA .GT. 0.) GO TO 118 +C + HA = BIG + IF (ISP .EQ. 0) GO TO 115 +C + DO 114 J=1,NY,INCY + DO 113 I=1,NX,INCX + IF (ISP-2) 109,111,110 + 109 IF (U(I,J) .EQ. SPV1) GO TO 113 + GO TO 112 + 110 IF (U(I,J) .EQ. SPV1) GO TO 113 + 111 IF (V(I,J) .EQ. SPV2) GO TO 113 + 112 HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 113 CONTINUE + 114 CONTINUE + GO TO 126 +C + 115 DO 117 J=1,NY,INCY + DO 116 I=1,NX,INCX + HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 116 CONTINUE + 117 CONTINUE +C +C BRANCH IF NULL VECTOR SIZE. +C + 126 IF (HA .LE. 0.) GO TO 125 +C +C COMPUTE SCALE FACTORS. +C + 118 SFX = SCALEX(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + SFY = SCALEY(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 1.0 + IF (IOFFDT .NE. 0) + 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA)))-500.)-500) + IZFLG = 0 +C +C COMPUTE ZMN AND ZMX, WHICH ARE USED IN DRWVEC. +C + ZMN = LEN*(GL/HA) + ZMX = FLOAT(LEN)+.01 +C +C DRAW THE VECTORS. +C + DO 123 J=1,NY,INCY + DO 122 I=1,NX,INCX + UI = U(I,J) + VI = V(I,J) + IF (ISP-1) 121,119,120 + 119 IF (UI-SPV1) 121,122,121 + 120 IF (VI .EQ. SPV2) GO TO 122 + IF (ISP .GE. 3) GO TO 119 + 121 X = I + Y = J + CALL FL2INT(FX(X,Y),FY(X,Y),MX,MY) + LX = MAX0(1,MXF(X,Y,UI,VI,SFX,SFY,MX,MY)) + LY = MAX0(1,MYF(X,Y,UI,VI,SFX,SFY,MX,MY)) + IZFLG = 1 + IF (ILAB .NE. 0) CALL ENCD(VLAB(UI,VI,I,J),ASH,LABEL,NC, + + IOFFDT) + CALL DRWVEC (MX,MY,LX,LY,LABEL,NC) + 122 CONTINUE + 123 CONTINUE +C + IF (IZFLG .EQ. 0) GO TO 125 +C + IF (IOFFM .NE. 0) GO TO 200 +C +NOAO - FTN internal write replaced with call to encode +C WRITE(LABEL,'(E10.3)')HA + call encode (10, '(e10.3)', label, ha) +C -NOAO +C +C TURN OFF CLIPPING SO ARROW CAN BE DRAWN +C + CALL GQCLIP(IER,ICLP,IAR) + CALL GSCLIP(0) + CALL DRWVEC (28768,608,28768+LEN,608,LABEL,10) +C +C RESTORE CLIPPING +C + CALL GSCLIP(ICLP) + IX = 1+(28768+LEN/2)/ISX + IY = 1+(608-(5*ISX*MAX0(256/ISX,8))/4)/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'MAXIMUM VECTOR',MAX0(256/ISX,8),0,0) + CALL GSELNT(ICN) +C +C DONE. +C + GOTO 200 +C +C ZERO-FIELD ACTION. +C + 125 IX = 1+16384/ISX + IY = 1+16384/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'ZERO FIELD',MAX0(960/ISX,8),0,0) + CALL GSELNT(ICN) +C +C RESTORE TRANS 1 AND LOG SCALING AND ORIGINAL TRANS NUMBER +C + 200 CONTINUE + IF (NSET .LE. 0) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF + CALL GSELNT(IOLDNT) + RETURN + END + SUBROUTINE EZVEC (U,V,M,N) +C +C THIS SUBROUTINE IS FOR THE USER WHO WANTS A QUICK-AND-DIRTY VECTOR +C PLOT WITH DEFAULT VALUES FOR MOST OF THE ARGUMENTS. +C + SAVE +C + DIMENSION U(M,N) ,V(M,N) ,SPVAL(2) +C + DATA FLO,HI,NSET,LENGTH,ISPV,SPVAL(1),SPVAL(2) / + + 0.,0., 0, 0, 0, 0., 0. / +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','EZVEC','VERSION 6') +C + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPVAL) +C +NOAO - call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC) +C +C THIS ROUTINE IS CALLED TO DRAW A SINGLE ARROW. IT HAS ARGUMENTS AS +C FOLLOWS - +C +C (M1,M2) - COORDINATE OF ARROW BASE, ON A 2**15 X 2**15 GRID. +C (M3,M4) - COORDINATE OF ARROW HEAD, ON A 2**15 X 2**15 GRID. +C LABEL - CHARACTER LABEL TO BE PUT ABOVE ARROW. +C NC - NUMBER OF CHARACTERS IN LABEL. +C + SAVE +C +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX + CHARACTER*10 LABEL +C +C SOME LOCAL PARAMETERS ARE THE FOLLOWING - +C +C CL - ARROW HEAD LENGTH SCALE FACTOR - EACH SIDE OF THE ARROW +C HEAD IS THIS LONG RELATIVE TO THE LENGTH OF THE ARROW +C ST,CT - SIN AND COS OF THE ARROW HEAD ANGLE +C PI - THE CONSTANT PI +C TWOPI - TWO TIMES PI +C OHOPI - ONE HALF OF PI +C FHOPI - FIVE HALVES OF PI +C + DATA CL / .25 / + DATA ST / .382683432365090 / + DATA CT / .923879532511287 / + DATA PI / 3.14159265358979 / + DATA TWOPI / 6.28318530717959 / + DATA OHOPI / 1.57079632679489 / + DATA FHOPI / 7.85398163397448 / +C + DIST(X,Y) = SQRT(X*X+Y*Y) +C +C TRANSFER ARGUMENTS TO LOCAL VARIABLES AND COMPUTE THE VECTOR LENGTH. +C + N1 = M1 + N2 = M2 + N3 = M3 + N4 = M4 + DX = N3-N1 + DY = N4-N2 + R = DIST(DX,DY) +C +C SORT OUT POSSIBLE CASES, DEPENDING ON VECTOR LENGTH. +C + IF (R .LE. ZMN) RETURN +C + IF (R .LE. ZMX) GO TO 101 +C +C PLOT A POINT FOR VECTORS WHICH ARE TOO LONG. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N1,N2,1) + CALL PLOTIT (N1,N2,0) + RETURN +C +C ADJUST THE COORDINATES OF THE VECTOR ENDPOINTS AS IMPLIED BY THE +C CENTERING OPTION. +C + 101 IF (ICTRFG) 102,103,104 +C + 102 N3 = N1 + N4 = N2 + N1 = FLOAT(N1)-DX + N2 = FLOAT(N2)-DY + GO TO 104 +C + 103 N1 = FLOAT(N1)-.5*DX + N2 = FLOAT(N2)-.5*DY + N3 = FLOAT(N3)-.5*DX + N4 = FLOAT(N4)-.5*DY +C +C DETERMINE THE COORDINATES OF THE POINTS USED TO DRAW THE ARROWHEAD. +C + 104 C1 = CL +C +C SHORT ARROWS HAVE HEADS OF A FIXED MINIMUM SIZE. +C + IF (R .LT. RMN) C1 = RMN*CL/R +C +C LONG ARROWS HAVE HEADS OF A FIXED MAXIMUM SIZE. +C + IF (R .GT. RMX) C1 = RMX*CL/R +C +C COMPUTE THE COORDINATES OF THE HEAD. +C + N5 = FLOAT(N3)-C1*(CT*DX-ST*DY) + N6 = FLOAT(N4)-C1*(CT*DY+ST*DX) + N7 = FLOAT(N3)-C1*(CT*DX+ST*DY) + N8 = FLOAT(N4)-C1*(CT*DY-ST*DX) +C +C PLOT THE ARROW. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N5,N6,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N7,N8,1) + CALL PLOTIT (0,0,0) +C +C IF REQUESTED, PUT THE VECTOR MAGNITUDE ABOVE THE ARROW. +C + IF (NC .EQ. 0) RETURN + PHI = ATAN2(DY,DX) + IF (AMOD(PHI+FHOPI,TWOPI) .GT. PI) PHI = PHI+PI + IX = 1+IFIX(.5*FLOAT(N1+N3)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*COS(PHI+OHOPI))/ISX + IY = 1+IFIX(.5*FLOAT(N2+N4)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*SIN(PHI+OHOPI))/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR(XC,YC, + + LABEL,MAX0(IFIX(SIZE)/ISX,8), + + IFIX(57.2957795130823*PHI),0) + CALL GSELNT(ICN) + RETURN + END + SUBROUTINE VELVEC (U,LU,V,LV,M,N,FLO,HI,NSET,ISPV,SPV) +C +C THIS ROUTINE SUPPORTS USERS OF THE OLD VERSION OF THIS PACKAGE. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) +C + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','VELVEC','VERSION 4') + CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,0,ISPV,SPV) + RETURN + END +C +C REVISION HISTORY ---------------------------------------------------- +C +C FEBRUARY, 1979 ADDED REVISION HISTORY +C MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JULY, 1979 FIXED HI VECTOR TRAP AND MESSAGE INDICATING +C MAXIMUM VECTOR PLOTTED. +C +C DECEMBER, 1979 CHANGED THE STATISTICS CALL FROM CRAYLIB TO NSSL +C +C MARCH, 1981 FIXED SOME FRINGE-CASE ERRORS, CHANGED THE CODE TO +C USE FL2INTT AND PLOTIT INSTEAD OF MXMY, FRSTPT, AND +C VECTOR, AND MADE THE ARROWHEADS NARROWER (45 DEGREES +C APART, RATHER THAN 60 DEGREES APART) +C +C FEBRUARY, 1984 PROVIDED A DIMENSION STATEMENT FOR A VARIABLE INTO +C WHICH A TEN-CHARACTER STRING WAS BEING ENCODED. ON +C THE CRAY, WHEN THE ENCODE WAS DONE, A WORD FOLLOWING +C THE VARIABLE WAS CLOBBERED, BUT THIS APPARENTLY MADE +C NO DIFFERENCE. ON AT LEAST ONE OTHER MACHINE, THE +C CODE BLEW UP. (ERROR REPORTED BY GREG WOODS) +C +C JULY, 1984 CONVERTED TO FORTRAN77 AND GKS. +C +C --------------------------------------------------------------------- |